Excel VBA code to extract all outlook global address emails and UserID

[Uzma Shaheen]

Hi All,

Im trying to get outlook global email address and userId in to my workbook

What is the best way to achieve this

Please can you help me

Many many many thanks

 

[DanteAmor]

I found the following in this link, I hope it helps you
https://www.mrexcel.com/forum/excel-questions/63083-global-address-list-excel.html

Sub GetOutlookAddressBook()
  Dim objOutlook As Outlook.Application, objAddressList As Outlook.AddressList
  Dim objAddressEntry As Outlook.AddressEntry, i As Long
  
  Application.ScreenUpdating = False
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("Global Address List")
  Sheets("Sheet1").Range("A:B").Clear
  i = 2
  For Each objAddressEntry In objAddressList.AddressEntries
    If objAddressEntry.Address <> "" Then
      Sheets("Sheet1").Cells(i, "A") = objAddressEntry.Name
      i = i + 1
    End If
  Next objAddressEntry
  Application.ScreenUpdating = True
End Sub

 

[Uzma Shaheen]

Thank you

How can i retrieve the alias and Name too?

So i want to get back the Name, Alias and email address

Thank you

 

[DanteAmor]

Thank you
How can i retrieve the alias and Name too?
So i want to get back the Name, Alias and email address
Thank you

Try this

Sub GetOutlookAddressBook()
  Dim objOutlook As Outlook.Application, objAddressList As Outlook.AddressList
  Dim oItem As Outlook.AddressEntry, i As Long
  Application.ScreenUpdating = False
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("Lista global de direcciones")
  Sheets("Sheet1").Range("A:C").ClearContents
  i = 2
  For Each oItem In objAddressList.AddressEntries
    If oItem.Address <> "" Then
      Cells(i, "A") = oItem.Name
      Cells(i, "B") = oItem.GetExchangeUser.Alias
      Cells(i, "C") = oItem.GetExchangeUser.PrimarySmtpAddress
      i = i + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Uzma Shaheen]

Hi Thank you

i changed the address list to Global Address List as it could not find the way you had it in the latest post (think it was in Portuguese)

I get an object not defined or set error on the getuserexchange code for both alias and email address

ive had this issue all day and can’t figure out why

 

[DanteAmor]

Sorry, I forgot to translate.

[COLOR=#333333]Set objAddressList = objOutlook.Session.AddressLists("[/COLOR][COLOR=#333333]Global Address List[/COLOR][COLOR=#333333]")[/COLOR]

These are the instructions I found and they work for me.
What version of office do you have?
Hopefully someone can help.

 

[Uzma Shaheen]

Thank you

I have outlook 2013 and have set a reference to outlook 15.0 library

 

[DanteAmor]

Add the instruction on error, it may work for some.

Sub GetOutlookAddressBook()
  Dim objOutlook As Outlook.Application, objAddressList As Outlook.AddressList
  Dim oItem As Outlook.AddressEntry, i As Long
  Application.ScreenUpdating = False
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("[COLOR=#0000ff]Global Address List[/COLOR]")
  Sheets("Sheet1").Range("A:C").ClearContents
  i = 2
[COLOR=#ff0000]  On Error Resume Next[/COLOR]
  For Each oItem In objAddressList.AddressEntries
    If oItem.Address <> "" Then
      Cells(i, "A") = oItem.Name
      Cells(i, "B") = oItem.GetExchangeUser.Alias
      Cells(i, "C") = oItem.GetExchangeUser.PrimarySmtpAddress
      i = i + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Uzma Shaheen]

That actually did the trick....thank you so much

the issue was that not every one was connected in the address book hence why it threw an error

 

[Uzma Shaheen]

Add the instruction on error, it may work for some.

Sub GetOutlookAddressBook()
  Dim objOutlook As Outlook.Application, objAddressList As Outlook.AddressList
  Dim oItem As Outlook.AddressEntry, i As Long
  Application.ScreenUpdating = False
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("[COLOR=#0000ff]Global Address List[/COLOR]")
  Sheets("Sheet1").Range("A:C").ClearContents
  i = 2
[COLOR=#ff0000]  On Error Resume Next[/COLOR]
  For Each oItem In objAddressList.AddressEntries
    If oItem.Address <> "" Then
      Cells(i, "A") = oItem.Name
      Cells(i, "B") = oItem.GetExchangeUser.Alias
      Cells(i, "C") = oItem.GetExchangeUser.PrimarySmtpAddress
      i = i + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Hiya

Ive ran the update and it’s taken ages to get the information. Looking like it might take over an hour to get all the info.

Can you please help me store it into an array and then I can paste into the sheet right at the end to see if I can speed it up more?

do you know any other way that I can speed it up?
Thank you