Link a Contact Item to Other Items

Via contact activities you can view other items that are linked with the contact, like e-mails, appointments, journal items, etc. If you address an email, the link is automatically created. For all of the other items you need to do that yourself. For that there's a Contacts field at the bottom of each form except for emails. You need to display the options dialog if you want to link an email to another contact that isn't listed as a recipient.

So, as the process is done fairly quickly for most of the items, some more clicks are necessary for emails. Even more effort is necessary if you want to link multiple items with one or more contacts. The following VBA script makes it very easy. Just select one or more items you want to link to one or more contacts, then start the LinkItemToContact procedure, and enter one or more contact names, separated by a comma or semicolon. The condition is that every name can be resolved by Outlook. That means the contact must not have more than one email address. If it has, you must enter the address instead of just the name.

  How to add macros to Outlook

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("Contacts:"))
  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 "Could not resolve '" & Names(i) & _
          "'. Try with the email address.", 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