We see lots of example on how to create a new Outlook Contact (now called People), but what about wanting to retrieve the information of an existing Contact through VBA? Well, similarily to my post List Outlook Calendar Appointments it is quite straightforward.

The Basic Solution

'---------------------------------------------------------------------------------------
' Procedure : OTLK_GetContact
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve Outlook Contact(s)' information
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFirstName    : First Name of the contact to retrieve
' sLastName     : Last Name of the contact to retrieve
'
' Usage:
' ~~~~~~
' Call OTLK_GetContact("Julie", "Evans")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2018-12-09              Initial Release
'---------------------------------------------------------------------------------------
Public Function OTLK_GetContact(ByVal sFirstName As String, ByVal sLastName As String)
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oContacts             As Object
    Dim oFilterContacts       As Object
    Dim sFilter               As String
    Dim bOutlookOpened        As Boolean
    Const olFolderContacts = 10

    'Get/Start Outlook
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
    If Err.Number <> 0 Then        'Could not get instance, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    Else        'Was already running
        bOutlookOpened = True
    End If
    On Error GoTo Error_Handler

    Set oNS = oOutlook.GetNamespace("MAPI")
    Set oContacts = oNS.GetDefaultFolder(olFolderContacts)
    'Apply a filter to retrieve the specific contact(s) we seek.
    sFilter = "[FirstName]='" & sFirstName & "' and [LastName]='" & sLastName & "'"
    Set oFilterContacts = oContacts.Items.Restrict(sFilter)
    Debug.Print oFilterContacts.Count & " appointments found."
    For Each oFilterContacts In oFilterContacts 'Iterate through each contact
        'Do what you want with the retrieved contact(s)' information
        Debug.Print oFilterContacts.FullName, oFilterContacts.CompanyName, oFilterContacts.Email1Address
    Next

    If bOutlookOpened = False Then      'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit    'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    If Not oFilterContacts Is Nothing Then Set oFilterContacts = Nothing
    If Not oContacts Is Nothing Then Set oContacts = Nothing
    If Not oNS Is Nothing Then Set oNS = Nothing
    If Not oOutlook Is Nothing Then Set oOutlook = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: OTLK_GetContact" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Now the above performs a search on the contact’s First and Last names, but you can change that and search by any field you wish to.

Taking Things a Little Further

Now the above is great, but is limited to searching through the root Contacts folder and doesn’t check any user created subfolders. I wanted a solution that would work on any system regardless of how a user set things up and I didn’t want to have to hard code subfolder names in my code either. So I came up with a procedure that simply iterates through Contacts forlder as well as all its subfolder when performing the search. Below is what I put together.

'---------------------------------------------------------------------------------------
' Procedure : OTLK_GetContact
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve Outlook Contact(s)' information
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFirstName    : First Name of the contact to retrieve
' sLastName     : Last Name of the contact to retrieve
'
' Usage:
' ~~~~~~
' Call OTLK_GetContact("Julie", "Evans")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2018-12-09              Initial Release
' 2         2018-12-10              Add recursive searching
'---------------------------------------------------------------------------------------
Public Function OTLK_GetContact(ByVal sFirstName As String, ByVal sLastName As String, _
                                Optional oFolder As Object)
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oContacts             As Object
    Dim oFilterContacts       As Object
'    Dim oFolder               As Object
    Dim sFilter               As String
    Dim bOutlookOpened        As Boolean
    Const olFolderContacts = 10

    'Get/Start Outlook
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
    If Err.Number <> 0 Then        'Could not get instance, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    Else        'Was already running
        bOutlookOpened = True
    End If
    On Error GoTo Error_Handler

    Set oNS = oOutlook.GetNamespace("MAPI")
    If oFolder Is Nothing Then
        Set oContacts = oNS.GetDefaultFolder(olFolderContacts)
        
        'Let's search the default contact folder
        Debug.Print "Processing Folder " & oContacts.Name
        'Apply a filter to retrieve the specific contact(s) we seek.
        sFilter = "[FirstName]='" & sFirstName & "' and [LastName]='" & sLastName & "'"
        Set oFilterContacts = oContacts.Items.Restrict(sFilter)
        Debug.Print , oFilterContacts.Count & " appointments found."
        For Each oFilterContacts In oFilterContacts    'Iterate through each contact
            'Do what you want with the retrieved contact(s)' information
            Debug.Print , oContacts.Name, oFilterContacts.FullName, oFilterContacts.CompanyName, oFilterContacts.Email1Address
        Next
    Else
        Set oContacts = oFolder
    End If

    'Recursively search through any contact folders created by the user
    For Each oFolder In oContacts.Folders
        Debug.Print "Processing Folder " & oFolder.Name
        'Apply a filter to retrieve the specific contact(s) we seek.
        sFilter = "[FirstName]='" & sFirstName & "' and [LastName]='" & sLastName & "'"
        Set oFilterContacts = oFolder.Items.Restrict(sFilter)
        Debug.Print , oFilterContacts.Count & " appointments found."
        For Each oFilterContacts In oFilterContacts    'Iterate through each contact
            'Do what you want with the retrieved contact(s)' information
            Debug.Print , oFolder.Name, oFilterContacts.FullName, oFilterContacts.CompanyName, oFilterContacts.Email1Address
        Next

        Call OTLK_GetContact(sFirstName, sLastName, oFolder)
    Next oFolder

    If bOutlookOpened = False Then      'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit    'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    If Not oFolder Is Nothing Then Set oFolder = Nothing
    If Not oFilterContacts Is Nothing Then Set oFilterContacts = Nothing
    If Not oContacts Is Nothing Then Set oContacts = Nothing
    If Not oNS Is Nothing Then Set oNS = Nothing
    If Not oOutlook Is Nothing Then Set oOutlook = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: OTLK_GetContact" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function