Pick Contacts using VBA

Last reviewed on May 28, 2014   —  2 comments

Use the following VBA code to create a contact picker to link contacts to tasks. 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.

Open Outlook's Folder Picker

To use a folder picker with other macros, use this code snippet to bring up the dialog:

Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder

Set objApp = CreateObject(“Outlook.Application”)
Set objNS = objApp.GetNamespace(“MAPI”)
Set objFolder = objNS.PickFolder

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
        If Not objItem.Saved Then
        End If
      End If
  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

About Diane Poremsky

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.

Please post long or more complicated questions at Outlook forums by Slipstick.com.

2 responses to “Pick Contacts using VBA”

  1. Claud

    Due to the problems with Links in 2013 will this solution work in office 2013?

    1. Diane Poremsky

      I haven't tested it yet, but I am assuming that it won't.

Leave a Reply

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

This site uses XenWord.