Copying Global Address List contacts including "External Contacts" - vba

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?

Answer 1

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