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.
- On the Developer ribbon, click Visual Basic
- Once the Visual Basic window opens, go to Tools -> References…
- From the References dialog box, check/enable Microsoft Outlook 16.0 Object Library
- 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.
Once the code is properly added to the workbook, the function may be called as part of an Excel formula.
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
- First Name
- Last Name
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.
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
=GetOutlookAddressBookProperty("Dalesandro, John", "Job Title")
Returns the value “Supervisor”.
=GetOutlookAddressBookProperty("Dalesandro, John", "Last Name")
Returns the value “Dalesandro”.
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) 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) 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