Add Email Addresses to a Contact Group

I'd like to quickly - with a click or two, assign a particular sender of email to a Contact Group.

You can use a macro to add the sender of a selected message to a Contact Group (aka distribution list or DL) in one click (ok, two, as you need to select the Contract group name too).

When you run this macro after selected an email message, it asks if you want to add to an existing contact group or create a new one.

If you choose to add it to an existing list, a list box containing the names of your existing Contact Groups displays. Double click on a name to add the email address to that list. If you said you wanted to create a new Contact Group, you'll enter a name for the Contact Group in the InputBox that comes up.

1. To use this project, right click on Project1 and choose Insert > Userform.
2. Select Listbox from the Toolbox and add it to the userform and drag to resize. Add a Command button.
   
3. Change the form and button captions in Properties.
   
4. Right click on the userform and choose View code.
5. Paste the first macro in the code page.
6. The completed userform will resemble this:
   
7. Right click on Project1 and choose Insert > Module.
8. Paste the second macro in the new module.
9. Select a message and run the macro to test it

Userform Code

Private Sub UserForm_Initialize()
Debug.Print "UF", myGroups
With ListBox1
    .Clear
    .List = Split(myGroups, ",")
End With
lbl_Exit:
  Exit Sub
End Sub
 
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
For lngCount = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(lngCount) = True Then
        strDLName = ListBox1.List(DLCount)
    End If
    Next
    Unload Me
  
lbl_Exit:
  Exit Sub
End Sub

Private Sub CommandButton1_Click()
For lngCount = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(lngCount) = True Then
        strDLName = ListBox1.List(lngCount)
    End If
    Next
     
    Unload Me
  
lbl_Exit:
  Exit Sub
End Sub

Module Code

Paste this macro in a new module.

    Public strDLName As String
    Public myGroups As String

Public Sub AddToDLGroup()
    Dim oDLGroup As Outlook.DistListItem
    Dim oRecipients As Outlook.Recipients
    Dim oMail As MailItem
    Dim newMail As MailItem
    Dim contactItems As Object
     
    Dim ContactsFolder As Outlook.Folder
    Dim Result As Integer
    Dim iCount As Integer
    myGroups = ""
    DLCount = 0
    
    
    On Error Resume Next
    Set oMail = Application.ActiveExplorer.Selection.Item(1)
    If TypeName(oMail) <> "MailItem" Then
       MsgBox "You need to select an email message."
       Exit Sub
    End If

    Set ContactsFolder = Application.Session.GetDefaultFolder(olFolderContacts)
        
    Result = MsgBox("Add to an existing Contact Group or create a new Contact Group?" & _
          vbCrLf & "Click Yes to select an existing Contact Group" & _
          vbCrLf & "No to create a New group ", _
          vbQuestion + vbYesNoCancel, "Contact Group already exists")
        
        If Result = vbYes Then
        
          Set contactItems = ContactsFolder.Items
            iCount = contactItems.Count
            If iCount = 0 Then
            MsgBox "No Contact Groups exist yet"
            Exit Sub
            End If
                For x = 1 To iCount
                If TypeName(contactItems.Item(x)) = "DistListItem" Then
                    myGroups = contactItems.Item(x) & "," & myGroups
                Debug.Print myGroups
                End If
                Next x
                
            UserForm1.Show

Set objContactItems = ContactsFolder.Items.Restrict("[FullName] = '" & strDLName & "'")
    
    If objContactItems.Count > 0 Then
        For Each objItem In objContactItems
                If objItem.Class = Outlook.olDistributionList Then
                Set oDLGroup = objItem
                Exit For
            End If
        Next
    End If

        ElseIf Result = vbNo Then
          strDLName = InputBox("Specify a name for your New Contact Group:", "Contact Group Name")
            Set oDLGroup = Application.CreateItem(olDistributionListItem)
            oDLGroup.DLName = strDLName
        Else
            Exit Sub
        End If
        

    Set newMail = oMail.Reply
    Set oRecipients = newMail.Recipients
            With oDLGroup
                .AddMembers oRecipients
' just save and close
                '.Close olSave
' if you want to see that the address was added to the DL
                .Save
                .Display
            End With
    
    newMail.Close olDiscard
    
    Set oMail = Nothing
    Set oRecipients = Nothing
    Set oDLGroup = Nothing
        
End Sub