Pick Contacts using VBA

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

Related Posts:

1. How to use Outlook VBA with items that are open in an Inspector window

   Outlook VBA: work with open item or selected item
2. 

   Check Contacts before moving them to Hotmail Contacts folder
3. Outlook includes fax numbers in the address book because they are vali

   Make the Address Book show only e-mail addresses, not fax numbers
4. If you have Contacts in the Contacts folder but they are not accessibl

   Imported Addresses are Missing from Address Book