Retrieve Outlook Address Book Data Using Custom Excel VBA Function

I have an Excel worksheet containing thousands of rows of names. For each name, I need to add the individual’s job title as listed in the Outlook address book. I came across several solutions that would loop through the worksheet and add every available attribute from Outlook to the corresponding row. These solutions were all implemented as a sub procedure that operated across the entire worksheet. Instead of a sub procedure and looping, I implemented this as a generic function. This allows for more precision with respect to the attributes/properties to retrieve from Outlook and avoids operating on the entire worksheet when a name is added/changed.

The following custom VBA function will query the Outlook address book given a specific name/alias and return the requested attribute/property value.

To use this function, you must enable Microsoft Outlook 16.0 Object Library. The version number will vary based on the installed version of Microsoft Excel.

1. On the Developer ribbon, click Visual Basic
2. Once the Visual Basic window opens, go to Tools -> References…
3. From the References dialog box, check/enable Microsoft Outlook 16.0 Object Library
4. Click the OK button

Now that the Microsoft Outlook reference is activated, insert a new module into the workbook if one doesn’t already exist. The code will not work if added directly to a worksheet object.

Add the below code to the module. The function is then a usable formula in the workbook.

Usage

Once the code is properly added to the workbook, the function may be called as part of an Excel formula.

=GetOutlookAddressBookProperty(alias, propertyName)

alias accepts any string value, but the function works best if the value is a uniquely resolvable attribute of an address book entry (full name, alias name, alias, etc.). The function fails if it is unable to resolve to an individual entry in the address book.

propertyName accepts the following values:

• Job Title
• Company Name
• Department
• Name
• First Name
• Last Name
• Country/Region

There are many other properties available as part of the ExchangeUser, however, I’ve only exposed a handful through this function. The code may be easily modified to include additional properties as needed. Country/Region is a little different because it uses the PropertyAccessor to retrieve the value for an Exchange user. I found a list of MAPI Property Tags from Microsoft but it doesn’t appear to be regularly updated so please be aware that it may be outdated. As an example, the Unicode property tag value for Country/Region isn’t even listed. There are actively maintained tools available to help identify MAPI property tags, e.g., MFCMAPI and Outlook Spy (which also publishes a list of property tags). In this code, the Country/Region field corresponds to the PR_BUSINESS_ADDRESS_COUNTRY property tag which has a property tag value of 0x3A26001F.

Examples

Assume the Outlook address list includes an entry with the following attributes:

• Last Name: Dalesandro
• First Name: John
• Name: Dalesandro, John
• Department: Super Important Button Clickers
• Company Name: Widgets International
• Job Title: Supervisor
• Country/Region: United States

=GetOutlookAddressBookProperty("Dalesandro, John", "Job Title")

Returns the value “Supervisor”.

=GetOutlookAddressBookProperty("Dalesandro, John", "Last Name")

Returns the value “Dalesandro”.

Source Code

Option Explicit

Public Function GetOutlookAddressBookProperty(alias As String, propertyName As String) As Variant
  On Error GoTo errorHandler

  Dim olApp As Outlook.Application
  Dim olNameSpace As Namespace
  Dim olRecipient As Outlook.Recipient
  Dim olExchUser As Outlook.ExchangeUser
  Dim olContact As Outlook.AddressEntry

  Set olApp = CreateObject("Outlook.Application")
  Set olNameSpace = olApp.GetNamespace("MAPI")
  Set olRecipient = olNameSpace.CreateRecipient(LCase(Trim(alias)))

  olRecipient.Resolve

  If olRecipient.Resolved Then
    Set olExchUser = olRecipient.AddressEntry.GetExchangeUser

    If Not olExchUser Is Nothing Then
      'Attempt to extract information from Exchange
      GetOutlookAddressBookProperty = Switch(propertyName = "Job Title", olExchUser.JobTitle, _
                                             propertyName = "Company Name", olExchUser.CompanyName, _
                                             propertyName = "Department", olExchUser.Department, _
                                             propertyName = "Name", olExchUser.Name, _
                                             propertyName = "First Name", olExchUser.FirstName, _
                                             propertyName = "Last Name", olExchUser.LastName, _
                                             propertyName = "Country/Region", olExchUser.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3A26001F"))
    Else
      'If Exchange not available, then attempt to extract information from local Contacts
      Set olContact = olRecipient.AddressEntry
      
      If Not olContact Is Nothing Then
        GetOutlookAddressBookProperty = Switch(propertyName = "Job Title", olContact.GetContact.JobTitle, _
                                               propertyName = "Company Name", olContact.GetContact.CompanyName, _
                                               propertyName = "Department", olContact.GetContact.Department, _
                                               propertyName = "Name", olContact.GetContact.FullName, _
                                               propertyName = "First Name", olContact.GetContact.FirstName, _
                                               propertyName = "Last Name", olContact.GetContact.LastName, _
                                               propertyName = "Country/Region", olContact.GetContact.BusinessAddressCountry)
      Else
        GetOutlookAddressBookProperty = CVErr(xlErrNA)
      End If
    End If
  Else
    GetOutlookAddressBookProperty = CVErr(xlErrNA)
  End If

errorHandler:
  If Err.Number <> 0 Then
    GetOutlookAddressBookProperty = CVErr(xlErrNA)
  End If
End Function