Join Email with Contact Data

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.

  How to add macros to Outlook

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

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