Termin mit Kontaktdaten verknüpfen

In Outlook lassen sich alle Elemente mit Kontakten verknüpfen. So können Sie für einen Termin unter 'Kontakte' die Person eintragen, mit der Sie den Termin haben. Durch einen Doppelklick auf den Kontakt erfahren Sie dann z.B. die Postanschrift. Das nützt Ihnen aber nichts unterwegs mit dem Smartphone, wo diese Verlinkung nicht funktioniert.

(Seit Outlook 2007 wird das 'Kontakte'-Feld standardmäßig nicht mehr angezeigt. Auf dieser Seite wird beschrieben, wie das Feld angezeigt werden kann.)

Mit ein paar Zeilen VBA-Code können Sie wichtige Informationen aus dem Kontakt in den Termin kopieren. So haben Sie die Informationen auch unterwegs parat. Dieses Beispiel kopiert die Postanschrift in das Feld 'Ort', wenn das Feld noch leer ist.

Starten Sie Outlook nach dem Einfügen des Codes in 'DieseOutlookSitzung' neu, erstellen Sie einen Termin und tragen Sie in das 'Kontakte'-Feld einen Namen aus Ihrem Kontakteordner ein, dann speichern. Wenn der Kontakt gefunden wird (Outlook stellt den Namen dann unterstrichen dar), wird die Anschrift im Feld 'Ort' angezeigt.

  So fügen Sie Makros in Outlook ein

Private WithEvents m_Items As Outlook.Items

Private Sub Application_Startup()
  Set m_Items = Application.Session.GetDefaultFolder(olFolderCalendar).Items
End Sub

Private Sub m_Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.AppointmentItem Then
    AddContactInfo Item
  End If
End Sub

Private Sub m_Items_ItemChange(ByVal Item As Object)
  If TypeOf Item Is Outlook.AppointmentItem Then
    AddContactInfo Item
  End If
End Sub

Private Sub AddContactInfo(Appt As Outlook.AppointmentItem)
  On Error GoTo ERR_HANDLER
  Dim Link As Outlook.Link
  Dim Contact As Outlook.ContactItem
  Dim Adr As String
  Static Busy As Boolean
  
  If Busy Then Exit Sub Else Busy = True
  
  If Appt.Location = "" Then
    If Appt.Links.Count Then
      Set Link = Appt.Links(1)
      If Not Link.Item Is Nothing Then
        Set Contact = Link.Item
        If Not Contact Is Nothing Then
          Adr = Contact.MailingAddress
          Adr = Replace(Adr, vbCrLf, ", ")
          If Right$(Adr, 2) = ", " Then
            Adr = Left$(Adr, Len(Adr) - 2)
          End If
          Appt.Location = Adr
          Appt.Save
        End If
      End If
    End If
  End If
ERR_HANDLER:
  Busy = False
End Sub