Link a Contact Item to Other Items

This sample explains the Links property, which is used to join any item (task item, contact item, etc.) with other items.

Last modified: 2014/02/26 | Accessed: 17.676  | #91
◀ Previous sample Next sample ▶
Category-Manager Category-Manager
With Category-Manager you can group your Outlook categories, share them with other users, filter a folder by category, automatically categorize new emails, and more. You can use the Addin even for IMAP.

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.

tip  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
        MsgBox "Could not resolve '" & Names(i) & _
          "'. Try with the email address.", vbInformation
        Exit Sub
      End If
    End If

  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
    If obj.Saved = False Then
    End If
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
    Set Sel = Application.ActiveExplorer.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        c.Add Sel(i)
    End If
  End If
  Set GetCurrentItems = c
End Function
Determine the "identity" of your emails. Set with SAM the sender and the folder folder for sent items with the help of rules.
email  Send a message