Outlook version of GetDistListMembers
March 13, 2009 • JP • No Comments • Rate This Article
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
' 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
Dim success As Boolean
If WriteDistListMembersToExcel("Managers") Then
MsgBox "ok"
End If
End Sub
Rate This Article:
(No Ratings Yet)
Loading ...
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
(No Ratings Yet) Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Excel VBA Performance in Office 2007
Next Post: Get Parent Application Name
Can you tell me how I would go about exporting distribution lists held in the global address list, not just those saved in my contacts folder?
Thanks
Lee, I'll see what I can come up with.
I posted another version of the code here:
Extract GAL members to Excel
Hi Jimmy,
Awesome site!! So far has saved me at least 10 hours manual work. In the reply to Lee, it looks like you may have a typo in the link.
Keep up the great work!!
Scott
Fixed, thanks Scott.