Macro to Extract Values from Outlook GAL

legalhustler

Well-known Member
Joined
Jun 5, 2014
Messages
1,105
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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;
VBA Code:
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.

VBA 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 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
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

legalhustler

Well-known Member
Joined
Jun 5, 2014
Messages
1,105
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Anyone know how to extract values from Outlook GAL via macro or Power Query?
 

legalhustler

Well-known Member
Joined
Jun 5, 2014
Messages
1,105
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Jun 5, 2014
Messages
1,105
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Here is my current code:

VBA 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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,057
Messages
5,599,550
Members
414,316
Latest member
ExcelLee

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top