Microsoft Office Forums - View Single Post - [Solved] Adding Company Name to Contact Group

gmayor · 04-23-2016, 05:58 AM

That was an interesting problem that required a little lateral thinking, but the following appears to work. You need to change the items were indicated if necessary. I chose a CSV file as the destination which is much faster than faffing around with Excel, while being Excel compatible. I have not added any error correction so you need to select the Distribution liost and run the macro - once!

Code:

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