Email mit Kontaktdaten verknüpfen

Wenn Sie eine Email von jemanden erhalten, dessen Kontaktdaten Sie gespeichert haben, verknüpft Outlook die Email nicht mit den Kontaktdaten. Darum ist es z.B. nicht möglich, im Posteingang den Vor- und Nachnamen oder Firmennamen anzuzeigen.

Die folgenden VBA-Funktionen suchen die Emailadresse des Absenders im Kontakteordner und fügen der Email benutzerdefinierte Felder hinzu, in welchen die Kontaktdaten geschrieben werden. Angestoßen wird das automatisch, sobald dem Standardposteingang eine Email hinzugefügt wird. Nachdem die erste Email vom Makro bearbeitet wurde, können Sie die neuen Felder dann im Ordner über Anpassen der Ordneransicht sichtbar machen.

  So fügen Sie Makros in Outlook ein

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, "AbsenderName")
    Prop.Value = Contact.Fullname
    
    Set Prop = GetUserProperty(Props, "AbsenderFirma")
    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

Und hier kommt noch eine Funktion, die Sie manuell, z.B. über F8, aufrufen können. Diese aktualisiert alle Emails im aktuellen Ordner; das muss nicht zwingend der Posteingang sein. Das ist z.B. dann nützlich, wenn sich die Kontaktdaten geändert haben und Sie alle Emails auf den neuesten Stand bringen wollen.

Public Sub UpdateAllEmails()
  Dim Item As Object
  Dim Folder As Outlook.MAPIFolder
  
  Set Folder = Application.ActiveExplorer.CurrentFolder
  If Folder.DefaultItemType = olContactItem Then
    MsgBox "Wählen Sie einen Ordner, der keine Kontakte enthält"
    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 erledigt"
End Sub