Microsoft Office Forums - View Single Post

gmayor · 11-20-2014, 03:36 AM

The following Excel function will create the named distribution list, if it doesn't exist, and will add the named member to that list, if not already a member.

You can loop through your worksheet repeatedly calling the function for each name.

That name must be in the format:
"DisplayName (e-mail address)" with the e-mail address in brackets as shown.

You can derive this from more than one cell's data as required.
The code uses late binding to Outlook so does not require a reference to the Outlook object library.

Code:

Option Explicit

Function CreateDistributionList(strListName As String, strMember As String)
'strMember should be in the format "Name (e-mail address)"
Dim olApp As Object
Dim olNameSpace As Object
Dim olFolder As Object
Dim olDistList As Object
Dim olFolderItems As Object
Dim olRecipient As Object
Dim x As Integer
Dim y As Integer
Dim iCount As Integer
Dim bList As Boolean
Dim bMember As Boolean

    On Error Resume Next
    'Get Outlook if it's running
    Set olApp = GetObject(, "Outlook.Application")

    'Outlook wasn't running, start it from code
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(10)
    Set olFolderItems = olFolder.Items
    bList = False
    bMember = False
    iCount = olFolderItems.Count
    For x = 1 To iCount
        If TypeName(olFolderItems.Item(x)) = "DistListItem" Then
            Set olDistList = olFolderItems.Item(x)
            'Check if the distribution list exists
            If olDistList.DLName = strListName Then
                bList = True
                For y = 1 To olDistList.MemberCount
                    'Check if the member exists
                    If InStr(1, olDistList.GetMember(y).Name, strMember) Then
                        bMember = True
                        Exit For
                    End If
                Next y
            End If
        End If
    Next x
    'If the distribution list doesn't exist - add it
    If Not bList Then
        Set olDistList = olApp.CreateItem(7)
        olDistList.DLName = strListName
    End If
    'If the member doesn't exist add it
    If Not bMember Then
        Set olRecipient = olNameSpace.CreateRecipient(strMember)
        olRecipient.Resolve
        olDistList.AddMember olRecipient
    End If
    'Save the change to the list
    olDistList.Save
    Set olApp = Nothing
    Set olNameSpace = Nothing
    Set olFolder = Nothing
    Set olFolderItems = Nothing
    Set olDistList = Nothing
    Set olRecipient = Nothing
End Function

Test it with the following

Code:

Sub Test()
    CreateDistributionList "A_Test", "Graham Mayor (support@gmayor.com)"
End Sub