Option Explicit
Const strPath As String = "C:\Path\ContactGroup.csv" 'The full name of the CSV file to be created.

Sub GetList()
Dim olNS As NameSpace
Dim olItem As DistListItem
Dim olAddrList As AddressList
Dim olContact As AddressEntry
Dim sContact As String
Dim sName As String
Dim sCompany As String
Dim sAddress As String
Dim i As Long
    sContact = "Company,Name,E-Mail"
    AddToCSV sContact
    Set olNS = GetNamespace("MAPI")
    Set olAddrList = olNS.AddressLists("Contacts") 'The name of the contacts' list

    'On Error Resume Next
    Set olItem = ActiveExplorer.Selection.Item(1)
    For i = 1 To olItem.MemberCount
        sAddress = olItem.GetMember(i).Address
        sName = Replace(Trim(Split(olItem.GetMember(i).Name, "(")(0)), ",", " ")
        Set olContact = olAddrList.AddressEntries(sName)
        sCompany = olContact.GetContact.CompanyName
        AddToCSV sCompany & "," & sName & "," & sAddress
    Next i
    MsgBox strPath & " created"
lbl_Exit:
    Exit Sub
End Sub


Sub AddToCSV(strLine As String)
'Graham Mayor - www.gmayor.com
'strline is the line of text to be added
Dim oFSO As Object
Dim oFile As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFSO.OpenTextFile(strPath, 8, True, 0)
    oFile.Write strLine & vbCrLf
    oFile.Close
lbl_Exit:
    Set oFSO = Nothing
    Set oFile = Nothing
    Exit Sub
End Sub