Create a Contact Group from selected Contacts

When you create a new Contact Group (also known as a Distribution List), Outlook doesn’t offer you much flexibility when it comes to finding and selecting contacts via the “Add Members” dialog.

For instance, there is no way to quickly add several people belonging to the same company or Category to your Contact Group.

The VBA macro from this article allows you to select your members directly from your Contacts folder. This enables you to first sort or filter your Contacts folder by a specific field such by Company or Category and/or do a search query and thus select your contact group members more conveniently.

• AddContactsToDL macro
• Quick Install
• Macro code

AddContactsToDL macro

The AddContactsToDL macro allows you to directly create a add your currently selected contacts to a Contact Group. With this method you can bypass the inflexible “Add Members” dialog which doesn’t allow any filtering or sorting.

When executing the macro, you’ll be prompted to name your Contact Group. If you already have a Contact Group with that name, you’ll be asked if the macro should add the currently selected Contacts as members to the already existing Contact Group or if it should create a new one with the same name.

You can even quickly add selected contacts to an existing Contact Group.

Quick Install

Use the following instructions to configure the macro in Outlook;

1. Download this code-file (add2dl.zip) or copy the code below.
2. Open the VBA Editor (keyboard shortcut ALT+F11)
3. Extract the zip-file and import the Add2DL.bas file via File-> Import…
   If you copied the code, paste it into a new module.
4. Sign your code so you won’t get any security prompts and the macro won’t get disabled. 
5. Add a button for easy access to the macro or press ALT+F8 and select the macro you want to execute.

Add a button to the Ribbon or the QAT to execute the Add2DL macro.

Macro Code

The following code is contained in the zip-file referenced in the Quick Install. You can use the code below for review or manual installation.

Public Sub AddContactsToDL()
'=================================================================
'Description: Outlook macto to create a new contact group or
'             update an existing one with the currently selected
'             contact items.
'
' author : Robert Sparnaaij
' version: 1.0
' website: https://www.howto-outlook.com/howto/addcontactstodl.htm
'=================================================================
    
    Dim oDL As Outlook.DistListItem
    Dim oRecipients As Outlook.Recipients
    Dim oMail As Outlook.MailItem
    Dim objItemsCollection As Object
    Dim objItem As Object
    Dim oSelectedContact As Outlook.ContactItem
    Dim oSelectedDL As Outlook.DistListItem
    Dim oSelection As Outlook.Selection
    Dim CurrentFolder As Outlook.Folder
    Dim Result As Integer
    Dim Found As Boolean
    Dim strDisplayName As String
    Dim strDLName As String
    
    Set CurrentFolder = Application.ActiveExplorer.CurrentFolder
    If CurrentFolder.DefaultItemType <> olContactItem Then
        MsgBox "Please make your selection in a Contacts folder.", vbCritical, "Add Contacts to Contact Group"
        Exit Sub
    End If
    
    strDLName = InputBox("Please specify a name for your Contact Group:", _
                            "Contact Group Name")
    Set objItemsCollection = CurrentFolder.Items.Restrict("[FullName] = '" & strDLName & "'")
    Found = False
    
    If objItemsCollection.Count > 0 Then
        For Each objItem In objItemsCollection
                If objItem.Class = Outlook.olDistributionList Then
                Found = True
                Set oDL = objItem
                Exit For
            End If
        Next
    End If
    
    If Found = True Then
        Result = MsgBox("This Contact Group already exisits." & vbNewLine & _
                        "Would you like to add the selected members to this " & _
                        "Contact Group (Yes) or create it as a new " & _
                        "Contact Group (No)?", vbQuestion + vbYesNoCancel, "Contact Group already exisits")
        If Result = vbYes Then
            'Nothing to do, we already set the oDL to the found object.
        ElseIf Result = vbNo Then
            Set oDL = Application.CreateItem(olDistributionListItem)
            oDL.DLName = strDLName
        Else
            Exit Sub
        End If
    Else
        Set oDL = Application.CreateItem(olDistributionListItem)
        oDL.DLName = strDLName
    End If
    
    Set oMail = Application.CreateItem(olMailItem)
    Set oRecipients = oMail.Recipients
    Set oSelection = Application.ActiveExplorer.Selection
    
    For Each objItem In oSelection
        If objItem.Class = Outlook.olContact Then
            Set oSelectedContact = objItem
            strDisplayName = oSelectedContact.Email1DisplayName
            If Len(strDisplayName) > 0 Then
                oRecipients.Add strDisplayName
            End If
        ElseIf objItem.Class = Outlook.olDistributionList Then
            Set oSelectedDL = objItem
            oRecipients.Add oSelectedDL.DLName
        End If
    Next
    
    oRecipients.ResolveAll
    oDL.AddMembers oRecipients
    oDL.DLName = strDLName
    oDL.Save
    
    Set CurrentFolder = Nothing
    Set objItemsCollection = Nothing
    Set oSelectedDL = Nothing
    Set oMail = Nothing
    Set oRecipients = Nothing
    Set oSelection = Nothing
    Set oSelectedContact = Nothing
    Set oDL = Nothing
        
End Sub