|VBOffice Reporter is an easy to use tool for data analysis and reporting in Outlook. A single click, for instance, allows you to see the number of hours planned for meetings the next month.|
If you receive an email from someone whos data is stored in your contact folder, Outlook doesn't join the email with the contact. Hence it isn't possible for instance to see the first and lastname or the company name of the sender in the inbox.
These VBA functions look up the sender's email address in the default contact folder and add user properties to the email where the contact data will be stored. All of this happens automatically as soon as an email is added to the default inbox. After the macro has processed at least one email, customize the folder view in order to make the new fields visible.
Private WithEvents m_Inbox As Outlook.Items Private m_Contacts As Outlook.Items Friend Sub Application_Startup() Set m_Inbox = Application.Session.GetDefaultFolder(olFolderInbox).Items End Sub Private Sub m_Inbox_ItemAdd(ByVal Item As Object) If TypeOf Item Is Outlook.MailItem Then Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items UpdateEmail Item End If End Sub Private Sub UpdateEmail(Mail As Outlook.MailItem) Dim Contact As Outlook.ContactItem Dim Props As Outlook.UserProperties Dim Prop As Outlook.UserProperty Dim Name As String Set Contact = GetContact(Mail.SenderEmailAddress) If Not Contact Is Nothing Then Set Props = Mail.UserProperties Set Prop = GetUserProperty(Props, "SenderFullname") Prop.Value = Contact.Fullname Set Prop = GetUserProperty(Props, "SenderCompany") Prop.Value = Contact.CompanyName Mail.Save End If End Sub Private Function GetUserProperty(Props As Outlook.UserProperties, Name As String) As Outlook.UserProperty Dim Prop As Outlook.UserProperty Set Prop = Props.Find(Name) If Prop Is Nothing Then Set Prop = Props.Add(Name, olText, True) End If Set GetUserProperty = Prop End Function Private Function GetContact(Adr As String) As Outlook.ContactItem Dim Contact As Outlook.ContactItem Set Contact = m_Contacts.Find("[Email1Address]='" & Adr & "'") If Contact Is Nothing Then Set Contact = m_Contacts.Find("[Email2Address]='" & Adr & "'") End If If Contact Is Nothing Then Set Contact = m_Contacts.Find("[Email3Address]='" & Adr & "'") End If Set GetContact = Contact End Function
|Determine the "identity" of your emails. Set with SAM the sender and the folder folder for sent items with the help of rules.|
And here comes another function, which can be started manually, for instance, by pressing F8. This one updates all emails of the current folder, which isn't necessarily the inbox. Use it, for instance, when the contact data has changed and you want to update all existing emails.
Public Sub UpdateAllEmails() Dim Item As Object Dim Folder As Outlook.MAPIFolder Set Folder = Application.ActiveExplorer.CurrentFolder If Folder.DefaultItemType = olContactItem Then MsgBox "Select a non contact folder" Exit Sub End If Set m_Inbox = Folder.Items Set m_Contacts = Application.Session.GetDefaultFolder(olFolderContacts).Items For Each Item In m_Inbox If TypeOf Item Is Outlook.MailItem Then UpdateEmail Item End If Next MsgBox "Update done" End Sub