Pick Contacts using VBA

Last reviewed on April 16, 2012

Use the following VBA code to create a contact picker. You can change the code to allow for a manual pick of contacts folder, ie not hardcoded. If you have contacts stored in another folder, this change will make it easier to use.

Sub ReconnectLinks()
  Dim objApp As Application
  Dim objNS As NameSpace
  Dim objFolder As MAPIFolder
  Dim colItems As Items
  Dim objItem As Object
  Dim colLinks As Links
  Dim objLink As Link
  Dim colContacts As Items
  Dim objContact As ContactItem
  Dim strFind As String
  Dim intCount As Integer
  Dim myFolder1 As MAPIFolder


  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  'set contacts folder
  Set myFolder1 = objNS.PickFolder
  'set tasks folder
  Set objFolder = objNS.PickFolder
  If TypeName(objFolder) <> "Nothing" Then
    'Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items     
    Set colContacts = myFolder1.Items
    Set colItems = objFolder.Items
    For Each objItem In colItems

      Set colLinks = objItem.Links
      intCount = colLinks.Count
      If intCount > 0 Then
        For i = intCount To 1 Step -1
          Set objLink = colLinks.Item(i)
          On Error Resume Next

          If objLink.Item Is Nothing Then

            strFind = "[FullName] = " & AddQuotes(objLink.Name)
            Set objContact = colContacts.Find(strFind)

            If Not objContact Is Nothing Then
            ' remove the old link
            colLinks.Remove i
            ' add the replacement link
            colLinks.Add objContact
            End If
          End If
        Next
        If Not objItem.Saved Then
          objItem.Save
        End If
      End If
    Next
  End If

  Set objLink = Nothing
  Set colLinks = Nothing
  Set objItem = Nothing
  Set objItems = Nothing
  Set objFolder = Nothing
  Set objNS = Nothing
    Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
    AddQuotes = Chr(34) & MyText & Chr(34)
End Function

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

If the Post Coment button disappears, press your Tab key.