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

Uzma Shaheen

Active Member
Joined
Nov 10, 2012
Messages
442
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,857
Office Version
2007
Platform
Windows
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

Code:
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

Active Member
Joined
Nov 10, 2012
Messages
442
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
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
8,857
Office Version
2007
Platform
Windows
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

Code:
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

Active Member
Joined
Nov 10, 2012
Messages
442
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,857
Office Version
2007
Platform
Windows
Sorry, I forgot to translate.

Code:
[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

Active Member
Joined
Nov 10, 2012
Messages
442
Thank you

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
8,857
Office Version
2007
Platform
Windows
Add the instruction on error, it may work for some.

Code:
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

Active Member
Joined
Nov 10, 2012
Messages
442
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

Active Member
Joined
Nov 10, 2012
Messages
442
Add the instruction on error, it may work for some.

Code:
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
 

Forum statistics

Threads
1,082,133
Messages
5,363,341
Members
400,728
Latest member
Hoan1985

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top