How to export members of the distribution list into MS Excel spreadsheet

When a user creates a distribution list in MS Outlook it is not possible to export addresses from it, and therefore, no ability to create a new list based on the old one (for example, by limiting the amount of its members).

This operation can be achieved in two ways: from within Excel by connecting to the Outlook and from Outlook by creating a new Microsoft Excel spreadsheet.

For a given distribution list name, the following macro exports email addresses of its members to the Excel spreadsheet along with their description.

The macro code for Outlook:

Sub ExtractDistLists()
    Const proces = "Export of the distribution list members"
    Dim oFolder As MAPIFolder, strDistListNames$, strDistListMembers As New Collection, x&
    Dim oDistList As DistListItem, nIndex&, oDistListFound As Boolean, item As Object, ext As Object
    oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

    strDistListNames = InputBox("Provide the distribution list name.", proces)
    For Each item In oFolder.Items
        If item.Class = 69 Then
            oDistList = item
            If oDistList.DLName = strDistListNames Then
                oDistListFound = True
                For nIndex = 1 To oDistList.MemberCount
                    strDistListMembers.Add(oDistList.GetMember(nIndex).Address & _
                    ";" & oDistList.GetMember(nIndex).Name)
                Next
            End If
        End If
    Next

    If oDistListFound = False Then
        If Len(strDistListNames) = 0 Then
            MsgBox("The distribution list name was not provided." & vbCr & _
            "Action interrupted!", _
            vbExclamation, proces & " VBATools.pl")
        Else
            MsgBox("No such distribution list " & _
            Chr(34) & strDistListNames & Chr(34), _
            vbCritical, proces & " VBATools.pl")
        End If
    Else
        ext = MsgBox("Read " & strDistListMembers.Count & " entries. " & _
        "Export to Excel spreadsheet?", _
        vbYesNo + vbQuestion, proces & " VBATools.pl")
        If ext = vbYes Then
            Dim xlApp As Object, xlWkb As Object
            xlApp = CreateObject("Excel.Application")
            With xlApp
                .Visible = True
                xlWkb = .Workbooks.Add(1)
            End With
            For x = 1 To strDistListMembers.Count
                With xlWkb.Worksheets(1).Cells(x, 1)
                    .value = Split(strDistListMembers(x), ";")(0)
                    .Offset(, 1) = Split(strDistListMembers(x), ";")(1)
                End With
            Next x
        End If
    End If

    xlWkb = Nothing
    xlApp = Nothing
    oDistList = Nothing
    oFolder = Nothing
End Sub

The macro code for MS Excel:

Sub ExtractDistLists_XL()
    Const proces = " Export of the distribution list members "
    Dim oFolder As MAPIFolder, strDistListNames$, strDistListMembers As New Collection, OutApp As Object
    Dim oDistList As DistListItem, nIndex&, oDistListFound As Boolean, item As Object, ext As Object, x&

    OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon()
    oFolder = OutApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

    strDistListNames = "Clients" 'dist list name
    For Each item In oFolder.Items
        If item.Class = 69 Then
            oDistList = item
            If oDistList.DLName = strDistListNames Then
                oDistListFound = True
                For nIndex = 1 To oDistList.MemberCount
                    strDistListMembers.Add(oDistList.GetMember(nIndex).Address & _
                    ";" & oDistList.GetMember(nIndex).Name)
                Next
            End If
        End If
    Next

    If oDistListFound = False Then
        If Len(strDistListNames) = 0 Then
            MsgBox(" The distribution list name was not provided." & vbCr & _
            " Action interrupted!", _
            vbExclamation, proces & " VBATools.pl")
        Else
            MsgBox(" No such distribution list " & _
            Chr(34) & strDistListNames & Chr(34), _
            vbCritical, proces & " VBATools.pl")
        End If
    Else
        ext = MsgBox("Read " & strDistListMembers.Count & " entries. " & _
        " Export to Excel spreadsheet?", _
        vbYesNo + vbQuestion, proces & " VBATools.pl")
        If ext = vbYes Then
            Workbooks.Add()
            For x = 1 To strDistListMembers.Count
                With Cells(x, 1)
                    .value = Split(strDistListMembers(x), ";")(0)
                    .Offset(, 1) = Split(strDistListMembers(x), ";")(1)
                End With
            Next x
        End If
    End If

    oDistList = Nothing
    oFolder = Nothing
    OutApp = Nothing
End Sub