Export Address Book to Excel

[starsky]

Hi,

Is it possible to export an Address Book (not Contacts) to Excel?

Thanks.

[JP2112]

Yes, just reference it like this:

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntry

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olAL = olNS.AddressLists("Personal Address Book")
For Each olEntry In olAL.AddressEntries
' your looping code here
Next olEntry

Just replace "Personal Address Book" with the name of the address book you want. (Go to Tools > Address Book and look in the "Show Names" dropdown).

For sample looping code, see http://www.codeforexcelandoutlook.com/blog/2009/03/extract-gal-members-to-excel/

HTH,
JP

[starsky]

Thanks for your response.

The sample code you linked to is exactly the thing I want. However, I'm unable to get it working as of yet. Have you ever used it?

I've tried to run it from Excel & Outlook and get the same error - type mismatch at the Erase tempVar line in the Error Handler (which indicates that it's erroring earlier).

[JP2112]

Yes sir. Have you tried stepping through the code to see where it fails? What specific line causes the error?

[starsky]

I placed this in an Excel module with the Sub Test macro to run it. It errors at the highlighted 'Erase tempVar' line, having already prompted Outlook for permission for access. It appears that it is going to the Error Handler at stopping at the quoted line. Same thing happens in an Outlook module. I've had very little experience of interaction between Outlook & Excel, so I'm not sure what I'm looking for.

Function WriteGALMembersToExcel(ListName As String) As Boolean
' adapted from http://www.slovaktech.com/code_samples.htm#DLToWord
' writes dist list members to a worksheet, one row for each contact in dist list

On Error GoTo ErrorHandler

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntry
Dim oldlMember As Outlook.AddressEntry

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olAL = olNS.AddressLists("Global Address List")

Set olEntry = olAL.AddressEntries(ListName)

' get count of dist list members
Dim lMemberCount As Long
lMemberCount = olEntry.Members.Count

' create temp variant and set size to one row for each contact
Dim tempVar As Variant
ReDim tempVar(1 To lMemberCount, 1 To 2)

' loop through dist list and extract members
Dim i As Long
For i = 1 To lMemberCount
Set oldlMember = olEntry.Members.Item(i)
tempVar(i, 1) = oldlMember.Name
tempVar(i, 2) = oldlMember.Address
Next i

' get new Excel instance
Dim xlApp As Object ' Excel.Application
Dim xlBk As Object ' Excel.Workbook
Dim xlSht As Object ' Excel.Worksheet
Dim rngStart As Object ' Excel.Range
Dim rngHeader As Object ' Excel.Range

Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc

xlApp.ScreenUpdating = False

Set xlBk = xlApp.Workbooks.Add
Set xlSht = xlBk.Sheets(1)

' set up worksheet and write to range
xlSht.Name = ListName
Set rngStart = xlSht.Range("A1")
Set rngHeader = xlSht.Range(rngStart, rngStart.Offset(0, 1))

rngHeader.Value = Array("Name", "Email Address")

rngStart.Offset(1, 0).Resize(UBound(tempVar), 2).Value = tempVar

' if we got this far, assume success
WriteGALMembersToExcel = True
xlApp.Visible = True
GoTo ExitProc

ErrorHandler:

ExitProc:
On Error Resume Next
Erase tempVar
Set rngHeader = Nothing
Set rngStart = Nothing
Set xlSht = Nothing
Set xlBk = Nothing
Set xlApp = Nothing
Set olAL = Nothing
Set olEntry = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function GetExcelApp() As Object
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0
End Function


Thanks

[JP2112]

Just take out that line (Erase tempVar), it isn't really needed anyway.