Create Distributionlist for a Contact Category

This procedure finds all contacts of a certain category in the default contact folder and creates the distribution list for the found email addresses. If a contact has more than one email address, only the first one will be added to the list. (See below two samples for how to call the macro.)

  How to add macros to Outlook

Private Sub CreateDistlist_ex(Category As String)
  Dim obj As Object
  Dim Ct As Outlook.ContactItem
  Dim Items As Outlook.Items
  Dim Dl As Outlook.DistListItem
  Dim Mail As Outlook.MailItem
  Dim Ns As Outlook.NameSpace
  Dim Recips As Outlook.Recipients
  Dim Filter As String
  
  If Len(Category) Then
    Filter = "@SQL=(" & "http://schemas.microsoft.com/mapi/proptag/0x8014101F" & " LIKE '%" & Category & "%')"
    Set Ns = Application.Session
    Set Items = Ns.GetDefaultFolder(olFolderContacts).Items
    Set Items = Items.Restrict(Filter)
    If Items.Count Then
      Set Mail = Application.CreateItem(olMailItem)
      Set Recips = Mail.Recipients
      For Each obj In Items
        If TypeOf obj Is Outlook.ContactItem Then
          Set Ct = obj
          If Len(Ct.Email1Address) Then
            Recips.Add Ct.Email1Address
          End If
        End If
      Next
      If Recips.Count Then
        If Recips.ResolveAll Then
          Set Dl = Application.CreateItem(olDistributionListItem)
          Dl.DLName = Category
          Dl.AddMembers Recips
          Dl.Display
        End If
      End If
    End If
  End If
End Sub

This gets the category that is assigned to the current item, either the open one or the one selected in a folder. If the item has more than one category assigned, only the first one will be used. Call this macro, for instance, by pressing ALT+F8.

Sub CreateDistlist_1()
  Dim obj As Object
  Dim Coll As VBA.Collection
  Dim Category As String
  
  Set Coll = GetCurrentItems()
  If Coll.Count Then
    Set obj = Coll(1)
    If Len(obj.Categories) Then
      Category = Trim$(Split(Replace(obj.Categories, ",", ";"), ";")(0))
    End If
  End If
  CreateDistlist_ex Category
End Sub

Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
  Dim c As VBA.Collection
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&
  
  Set c = New VBA.Collection
  
  If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    IsInspector = True
    c.Add Application.ActiveInspector.CurrentItem
  Else
    IsInspector = False
    Set Sel = Application.ActiveExplorer.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        c.Add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = c
End Function

This sample lets you enter the category manually.

Sub CreateDistlist_2()
  Dim Category As String
  
  Category = InputBox("Find this Category")
  CreateDistlist_ex Category
End Sub