Extract distribution list members to Excel

Ken Slovak has some code for extracting Outlook distribution lists to Word, so I went ahead and ported it to Excel.

The usual caveats apply; since you are accessing email addresses in Outlook from Excel, the OMG (Object Model Guard) will be triggered.

You specify the distribution list name as the parameter for the function. The name and email address of each distribution are added to a variant and returned to the calling sub.

Function GetDistListMembers(ListName As String) As Variant
' adapted from http://www.slovaktech.com/code_samples.htm#DLToWord
' returns a variant N rows high by 2 columns wide
' one row for each contact

' get reference to Outlook contacts folder
Dim olApp As Object ' Outlook.Application
Dim olNS As Object ' Outlook.Namespace
Dim olContactsFolder As Object ' Outlook.Items
Set olApp = GetOutlookApp

If olApp Is Nothing Then GoTo ExitProc

Set olNS = olApp.GetNamespace("MAPI")
Set olContactsFolder = olNS.GetDefaultFolder(10).Items ' olFolderContacts

' find specific dist list
Dim olDistList As Object ' Outlook.DistListItem

On Error Resume Next
Set olDistList = olContactsFolder.Item(ListName)
On Error GoTo 0

If olDistList Is Nothing Then GoTo ExitProc

' get count of dist list members
Dim lMemberCount As Long
lMemberCount = olDistList.MemberCount

' 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
Dim objRecip As Object ' Outlook.Recipient
For i = 1 To lMemberCount
  ' Object Model Guard
  Set objRecip = olDistList.GetMember(i)
  tempVar(i, 1) = objRecip.Name
  tempVar(i, 2) = objRecip.Address
Next i

GetDistListMembers = tempVar

ExitProc:
On Error Resume Next
Erase tempVar
Set objRecip = Nothing
Set olDistList = Nothing
Set olContactsFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
If bWeStartedOutlook Then
  olApp.Quit
End If
End Function

Function GetOutlookApp() As Object
On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0
End Function

Sample Usage:

The following code takes a single distribution list and dumps the names and email addresses starting with cell A2:

Sub test()
Dim emails As Variant

With Range("A1")
  .Value = "Name"
  .Font.Bold = True
End With
With Range("B1")
  .Value = "E-mail Address"
  .Font.Bold = True
End With

emails = GetDistListMembers("My Dist List Name")

Range("A2").Resize(UBound(emails), 2).Value = emails

Range("A1").CurrentRegion.Columns.AutoFit

End Sub

And this version loops through an imaginary list of distribution list names in column A (starting from A2) and writes the members of each to the worksheet.

Sub test2()

Dim emails As Variant
Dim i As Long
Dim DistListToFind As String

With Range("D1")
  .Value = "Name"
  .Font.Bold = True
End With

With Range("E1")
  .Value = "E-mail Address"
  .Font.Bold = True
End With

' start loop at row 2
i = 2

Do While Not IsEmpty(Cells(i, 1))
  DistListToFind = Cells(i, 1).Value

  emails = GetDistListMembers(DistListToFind)

  Range("D" & Rows.Count).End(xlUp).Offset(1, 0). _
     Resize(UBound(emails), 2).Value = emails
  Range("D1").CurrentRegion.Columns.AutoFit

i = i + 1
Loop

End Sub

In a couple of days I'll post the Outlook version, which will have the added benefit of not triggering the OMG! I'll also work on a non-Office-specific version, so you could do this from any Office program with VBA (PowerPoint, for example).

Related Articles:

• November 23, 2011 -- Display Contact Group Member Count
• December 28, 2009 -- Create Distribution Lists from Email
• April 15, 2009 -- Reply to Recipient