Join Appointment Item with Contact Data

You can link any Outlook items with your contacts. So you can add a contact to an appointment item, and if you double click the contact, you could see, for instance, its mailing address. This is useless, however, on the road with your smartphone where the contact linking isn't available.

(Since Outlook 2007 the 'Contacts' field isn't shown by default. Read here how to get the field back.)

With a few lines of VBA code you can copy important information from the contact to the appointment item. That way the information will be available even on the road. This sample copies the mailing address to the 'Location' field if the field is still empty.

After pasting the code into 'ThisOutlookSession', restart Outlook, create an appointment item, and add a name from your contacts folder, then save it. If the contact is found (Outlook will display it underlined), the mailing address will be displayed under 'Location'.

  How to add macros to Outlook

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