Copying Global Address List contacts including "External Contacts"

Question

I have a VBA code to get whole Global Address List from Outlook 2013 and place the values Name and E-mail Address in an Excel sheet.

The problem is it's only returning e-mails/users from my SMTP (I guess).

In this image, we can see the users from the SMTP as mine covered in black and an external user covered in red. My code:

Sub tgr()

    Dim appOL As Object
    Dim oGAL As Object
    Dim oContact As Object
    Dim oUser As Object
    Dim arrUsers(1 To 75000, 1 To 2) As String
    Dim UserIndex As Long
    Dim i As Long

    Set appOL = CreateObject("Outlook.Application")

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries

    For i = 1 To oGAL.Count
        Set oContact = oGAL.Item(i)
        If oContact.AddressEntryUserType = 0 Then
            Set oUser = oContact.GetExchangeUser
            If Len(oUser.lastname) > 0 Then
                UserIndex = UserIndex + 1
                arrUsers(UserIndex, 1) = oUser.Name
                arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
            End If
        End If
    Next i

    appOL.Quit

    If UserIndex > 0 Then
        Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If

    Set appOL = Nothing
    Set oGAL = Nothing
    Set oContact = Nothing
    Set oUser = Nothing
    Erase arrUsers

End Sub

So, am I doing something wrong?

PatricK · Accepted Answer · 2015-10-07T23:15:33.647

According to this documentation, the oContact.AddressEntryUserType value should include olExchangeRemoteUserAddressEntry (5) for External Users.

What's in your code is just to list Exchange Users, so it also skips mail-enabled PublicFolders, Distribution Lists, etc.

EDIT
Found a better way to extract name and email address (if any):
Reference: Obtain the E-mail Address of a Recipient

Option Explicit

Sub tgr()
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim appOL As Object
    Dim oGAL As Object
    Dim arrUsers() As String
    Dim UserIndex As Long
    Dim i As Long
    Dim sEmail As String

    Set appOL = GetObject(, "Outlook.Application")
    If appOL Is Nothing Then Set appOL = CreateObject("Outlook.Application")

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
    Debug.Print oGAL.Parent.Name & " has " & oGAL.Count & " entries"
    ReDim arrUsers(1 To oGAL.Count, 1 To 2)
    On Error Resume Next
    For i = 1 To oGAL.Count
        With oGAL.Item(i)
            Application.StatusBar = "Processing GAL entry #" & i & " (" & .Name & ")"
            sEmail = "" ' Not all entries has email address
            sEmail = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            If Len(sEmail) = 0 Then Debug.Print "No Email address configured for " & .Name & " (#" & i & ")"
            UserIndex = UserIndex + 1
            arrUsers(UserIndex, 1) = .Name
            arrUsers(UserIndex, 2) = sEmail
        End With
    Next
    On Error GoTo 0
    Application.StatusBar = False
    appOL.Quit

    If UserIndex > 0 Then
        Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If

    Set appOL = Nothing
    Set oGAL = Nothing
    Erase arrUsers

End Sub

Yes. You right. Using "oContact.AddressEntryUserType = 0 or oContact.AddressEntryUserType = 5" it returned the same previous result + another 7k contacts. Including e-mails out of my domain. But I still see some addresses in the GAL inside the Outlook and they're not being returned in the sheet using that code. — MWsan, Oct 07 '15 at 17:09

Copying Global Address List contacts including "External Contacts"

1 Answers1