This code sample was contributed by Thomas Hill.
Today, I found your procedure for extracting data from a GAL. Last week I found someone else's code for extracting from Contacts to Excel. When I cobbled the two together, I successfully exported the GAL to Excel, which is useful for a couple of processes here. It resides in Excel, so the Outlook library must be incorporated at design time.
To use, you need to set a reference to Outlook object model in Excel's Tools, References menu.
It is slow!
Sub GetAllGALMembers() 'This is an Excel Macro Dim i As Long, j as long, lastRow As Long 'Set up Outlook Dim olApp As Outlook.Application Dim olNS As Outlook.Namespace Dim olGAL As Outlook.AddressList Dim olEntry As Outlook.AddressEntries Dim olMember As Outlook.AddressEntry Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set olGAL = olNS.GetGlobalAddressList() 'Set Up Excel Dim wb As Workbook, ws As Worksheet 'set the workbook: Set wb = ThisWorkbook 'set the worksheet where you want to post Outlook data: Set ws = wb.Sheets("Sheet1") 'clear all current entries Cells.Select Selection.ClearContents 'set and format headings in the worksheet: ws.Cells(1, 1).Value = "First Name" ws.Cells(1, 2).Value = "Last Name" ws.Cells(1, 3).Value = "Phone/Ext" ws.Cells(1, 4).Value = "Email" ws.Cells(1, 5).Value = "Title" ws.Cells(1, 6).Value = "Department" Application.ScreenUpdating = False With ws.Range("A1:F1") .Font.Bold = True .HorizontalAlignment = xlCenter End With Set olEntry = olGAL.AddressEntries On Error Resume Next 'first row of entries j = 2 ' loop through dist list and extract members For i = 1 To olEntry.Count Set olMember = olEntry.Item(i) If olMember.AddressEntryUserType = olExchangeUserAddressEntry Then 'add to worksheet ws.Cells(j, 1).Value = olMember.GetExchangeUser.FirstName ws.Cells(j, 2).Value = olMember.GetExchangeUser.LastName ws.Cells(j, 3).Value = olMember.GetExchangeUser.BusinessTelephoneNumber ws.Cells(j, 4).Value = olMember.GetExchangeUser.PrimarySmtpAddress ws.Cells(j, 5).Value = olMember.GetExchangeUser.JobTitle ws.Cells(j, 6).Value = olMember.GetExchangeUser.Department j =j +1 End If Next i Application.ScreenUpdating = True 'determine last data row, basis column B (contains Last Name): lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row 'format worksheet data area: ws.Range("A2:F" & lastRow).Sort Key1:=ws.Range("B2"), Order1:=xlAscending ws.Range("A2:F" & lastRow).HorizontalAlignment = xlLeft ws.Columns("A:F").EntireColumn.AutoFit wb.Save 'quit the Outlook application: applOutlook.Quit 'clear the variables: Set olApp = Nothing Set olNS = Nothing Set olGAL = Nothing End Sub
How to use the Macro
First: You will need macro security set to low during testing.
To check your macro security in Excel 2010 and up, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. Note: after you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Now open the VBA Editor by pressing Alt+F11 on your keyboard and paste the code into the Editor pane. More information is at How to use the VBA Editor.
I found that this is really slow if I have the outlook client open. When I close the outlook client, it is reasonably fast...
I want to export my GAL, and also sort my data. Is there a VBA code?
Hi Thomas
Thanks for the post, was looking for this, is there a way to make list only emails found an a range?
EG: i have a list of emails lets say in a sheet, and i want to extract the info for them, (comparing the email to defaultsmtpaddress.
would that reduce run time (i have 24K plus entries)
It is a very helpfull macro.
But what if I don't need all the GAL members?
Is there any chance to select specific contacts from a GAL defining criteria such as, all GAL entries with the same "Company" field?
Hello, thanks for posting this - very helpful. In using the script I found a minor bug in that the First / Last name are reversed when copying to the spreadsheet which also makes the sort order be by First Name rather than your intended last name. These are easy to fix but I thought I'd let you know.
Thanks for letting me know - i fixed it.