Macro to Extract Values from Outlook GAL

[legalhustler]

I want to extract values such as the Full Name, Alias, Phone Number etc from Outlook Global Address List (GAL) based on a range of emails I have listed in column A. The range in column A is called "Emails". I found the following code but it seems to run at an error at this line;

sEmails = sEmails & C1.Value & ","

. I'm not sure what to do. If this can be done via Power Query I would def go try that route. Appreciate any help.

Sub tgr() 
Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 7) As String
Dim UserIndex As Long
Dim i As Long
Dim sEmails as String
Dim cl as Range
Dim rngEmails as Range

With Worksheets("Users")
Set rngEmails = .Range("A2:" & .Range("A" & .Rows.Count).End(xlup).Address)
End With

'This is for debugging only and should be removed once all is fixed
Debug.Print rngEmails.Address

For each cl in rngEmails
If Len(cl.value)>0 Then
sEmails = sEmails & C1.Value & ","
Else
'No email in cell, ignore it
End If
Next cl

'This is for debugging only and should be removed once all is fixed
Debug.Print sEmails

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 InStr(1, sEmails, oUser.PrimarySmtpAddress, vbTextCompare) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 1) = oUser.PrimarySmtpAddress
arrUsers(UserIndex, 2) = oUser.Department
arrUsers(UserIndex, 3) = oUser.Name
arrUsers(UserIndex, 4) = oUser.CompanyName
arrUsers(UserIndex, 5) = oUser.BusinessTelephoneNumber
arrUsers(UserIndex, 6) = oUser.Alias
arrUsers(UserIndex, 7) = oUser.MobileTelephoneNumber

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

 

[legalhustler]

Anyone know how to extract values from Outlook GAL via macro or Power Query?

 

[legalhustler]

Here's an update on my progress:

I have a defined range called Emails in column A. The header in cell A1 is also called Emails. Then in cell A2, A3 I have an email in each cell. For the two email I want to retrieve the PrimarySmtpAddress, Name, BusinessTelephoneNumber and Alias from Outlook GAL.

I was able to modify the code and step in to the code and see that the code is going through the GAL list of emails but it's extremely slow and I'm not sure if it'll produce the results I want. Can the code be modified to run faster and retrieve those four fields for the two emails?

P.S. I check marked Microsoft Outlook 16.0 Object Library to my References (under Tools).

 

[legalhustler]

Here is my current code:

Sub tgr()

Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 4) As String
Dim UserIndex As Long
Dim i As Long
Dim sEmails As String
Dim cl As Range
    Dim rngEmails As Range


With Worksheets("Users")
Set rngEmails = .Range("A2:" & .Range("A" & .Rows.Count).End(xlUp).Address)
    End With


'This is for debugging only and should be removed once all is fixed
    'Debug.Print rngEmails.Address


For Each cl In rngEmails
If Len(cl.Value) > 0 Then
sEmails = sEmails & cl.Value & ","
Else
'No email in cell, ignore it
End If
    Next cl


'This is for debugging only and should be removed once all is fixed
    'Debug.Print sEmails


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 InStr(1, sEmails, oUser.PrimarySmtpAddress, vbTextCompare) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 1) = oUser.PrimarySmtpAddress
arrUsers(UserIndex, 2) = oUser.Name
arrUsers(UserIndex, 3) = oUser.BusinessTelephoneNumber
arrUsers(UserIndex, 4) = oUser.Alias

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