Outlook version of GetDistListMembers

Here is the Outlook version of the GetDistListMembers function. This one works from Outlook and doesn't trigger the OMG.

Function WriteDistListMembersToExcel(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

' get reference to Outlook contacts folder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olContactsFolder As Outlook.Items

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olContactsFolder = olNS.GetDefaultFolder(olFolderContacts).Items

' find specific dist list
Dim olDistList As Outlook.DistListItem
Set olDistList = olContactsFolder.item(ListName)

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 Outlook.Recipient
For i = 1 To lMemberCount
  ' no Object Model Guard!
  Set objRecip = olDistList.GetMember(i)
  tempVar(i, 1) = objRecip.Name
  tempVar(i, 2) = objRecip.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
WriteDistListMembersToExcel = True
xlApp.Visible = True
GoTo ExitProc

ErrorHandler:

ExitProc:
On Error Resume Next
Erase tempVar
Set objRecip = Nothing
Set olDistList = Nothing
Set olContactsFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set xlBk = Nothing
Set rngStart = Nothing
Set rngHeader = Nothing
Set xlApp = 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

Usage:

Sub test()
Dim success As Boolean

If WriteDistListMembersToExcel("Managers") Then
  MsgBox "ok"
End If

End Sub

Related Articles:

• November 23, 2011 -- Display Contact Group Member Count
• December 28, 2009 -- Create Distribution Lists from Email
• March 2, 2009 -- Extract distribution list members to Excel