'Get email address from Outlook GAL?

I have the following code to try and grab the GAL from Outlook and drop the person's name + their email address into another sheet.

It gets the first name (but not email address) then stops. If I comment out Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress, it lists all the names succesfully, which suggests I might be using the wrong type to get the email address. VBA has no intellisense though so I'm not sure what to use instead!

Private Sub UpdateEmails()

' Need to add reference to Outlook
' Adds addresses to existing Sheet called Emails and
' defines name NamesAndEmailAddresses containing this list

On Error GoTo error

Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim intCounter As Integer

Application.ScreenUpdating = False

' Setup connection to Outlook application
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Global Address List")

Application.EnableEvents = False

' Clear existing list
Sheets("Emails").Range("A:A").Clear

'Step through each contact and list each that has an email address
For Each objAddressEntry In objAddressList.AddressEntries
    If objAddressEntry.Address <> "" Then
        intCounter = intCounter + 1
        Application.StatusBar = "Processing no. " & intCounter & " ... " & objAddressEntry.Address
        Sheets("Emails").Cells(intCounter, 1) = objAddressEntry.Name
        Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress
        DoEvents
    End If
Next objAddressEntry

' Define range called "NamesAndEmailAddresses" to the list of emails
Sheets("Emails").Cells(1, 2).Resize(intCounter, 1).Name = "NamesAndEmailAddresses"
error:
Set objOutlook = Nothing
Application.StatusBar = False

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

excel vba outlook

Solution 1:^[1]

Looking at the AddressEntry Object (Outlook) page on MSDN, the property you want is AddressEntry.Address

Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.Address

Also, if you early-bind Outlook from the Tools > References...* then you will get Intellisense. Or, you can hit [Alt]+[F11] in Outlook and use the Intellisense there.

{EDIT} Since this is giving the path on the Exchange Server rather than as a full e-mail address If the Contact is in an Exchange Address List, then you can use .GetExchangeUser.PrimarySmtpAddress to get the Primary Smtp Address for the user on the Exchange Server. (For local contacts on your account, use the GetContact.Email1Address instead)

Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.GetExchangeuser.PrimarySmtpAddress

Solution 2:^[2]

To obtain or check if a person has an email address on the GAL: (see this solution)

Sub testGetEmail()
Debug.Print GetEmailName("Dupont", "Alain")
End Sub

Function GetEmailName(FirstName As String, SecondName As String) As String
Dim oExUser As Outlook.ExchangeUser
Dim oAL As Outlook.AddressList

    Set oAL = Application.Session.AddressLists.Item(["Global Address List"])
    FullName = FirstName & ", " & SecondName
    Set oExUser = oAL.AddressEntries.Item([FullName]).GetExchangeUser
    GetEmailName = oExUser.PrimarySmtpAddress
End Function

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution	Source
Solution 1
Solution 2

'Get email address from Outlook GAL?

Solution 1:[1]

Solution 2:[2]

Sources

Related Questions

Solution 1:^[1]

Solution 2:^[2]