Outlook-Elemente mit Kontakten verknüpfen

Kontakte bieten die Möglichkeit, über die Ansicht Aktivitäten alle mit dem Kontakt verknüpften Elemente anzuzeigen, z.B. E-Mails, Termine, Journaleinträge etc. Wenn Sie eine E-Mail an den Kontakt adressieren, ist die Verknüpfung automatisch hergestellt. Für alle anderen Elemente müssen Sie das selbst erledigen. Bei Kontakten, Journaleinträgen, Terminen und Aufgaben gibt es dafür das Feld Kontakte am unteren Formularrand. Für E-Mails müssen Sie die E-Mail-Optionen aufrufen, wenn Sie die E-Mail mit einem zusätzlichen Kontakt verknüpfen möchten, der nicht in der Empfängerliste auftaucht.

Während der Vorgang also bei den meisten Elementen recht schnell erledigt ist, sind bei E-Mails schon viele Klicks nötig. Und richtig aufwendig wird es, wenn mehrere Elemente gleichzeitig mit einem oder mehreren Kontakten verknüpft werden sollen. Eine Erleichterung ist da folgendes VBA-Skript. Wählen Sie einfach beliebig viele Elemente, die mit einem oder mehreren Kontakten verknüpft werden sollen. In die Textbox können mehrere Namen durch Komma oder Semikolon getrennt eingegeben werden. Bedingung ist, dass jeder Name aufgelöst werden kann. Damit Outlook das kann, darf es zu einem Namen nur eine E-Mail-Adresse geben, andernfalls müssen Sie statt des Namens die E-Mail-Adresse direkt eingeben.

  So fügen Sie Makros in Outlook ein

Public Sub LinkItemToContact()
  Dim c As VBA.Collection
  Dim obj As Object
  Dim Links As Outlook.Links
  Dim Link As Outlook.Link
  Dim Contacts As VBA.Collection
  Dim Contact As Outlook.ContactItem
  Dim i&, y&, z&
  Dim Names() As String
  Dim b$

  b = Trim$(InputBox("Kontakte:"))
  If Len(b) = 0 Then Exit Sub
  b = Replace(b, ";", ",")
  Names = Split(b, ",")

  Set Contacts = New VBA.Collection
  For i = 0 To UBound(Names)
    If Len(Names(i)) Then
      Set Contact = GetContactByName_Ex(Names(i))
      If Not Contact Is Nothing Then
        Contacts.Add Contact
      Else
        MsgBox "Name konnte nicht aufgelöst werden: '" & Names(i) & _
          "'. Tragen Sie stattdessen die Emailadresse ein.", vbInformation
        Exit Sub
      End If
    End If
  Next

  Set c = GetCurrentItems
  For i = 1 To c.Count
    Set obj = c(i)
    Set Links = obj.Links
    For y = 1 To Contacts.Count
      Set Contact = Contacts(y)
      If Links.Item(Contact.Subject) Is Nothing Then
        Links.Add Contact
      End If
    Next
    If obj.Saved = False Then
      obj.Save
    End If
  Next
End Sub

Private Function GetContactByName_Ex(Name$) As Outlook.ContactItem
  Dim Folder As Outlook.MAPIFolder
  Dim Items As Outlook.Items
  Dim Item As Outlook.ContactItem
  Dim FindInDefault As Boolean
  Dim Recip As Outlook.Recipient

  If Len(Name) = 0 Then Exit Function
  Set Recip = Application.Session.CreateRecipient(Name)

  If Not Recip Is Nothing Then
    If Recip.Resolve Then
      Set Item = Recip.AddressEntry.GetContact
      If Not Item Is Nothing Then
        Set GetContactByName_Ex = Item
        Exit Function
      End If
    End If
  End If
End Function

Private Function GetCurrentItems(Optional IsInspector As Boolean _
) As VBA.Collection
  Dim c As VBA.Collection
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&

  Set c = New VBA.Collection

  If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    c.Add Application.ActiveInspector.CurrentItem
  Else
    Set Sel = Application.ActiveExplorer.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        c.Add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = c
End Function