Verteilerliste für eine Kontaktkategorie erstellen

Diese Funktion sucht alle Kontakte einer bestimmten Kategorie im Standardkontakteordner und erstellt eine neue Verteilerliste mit allen gefundenen Emailadressen. Für jeden gefundenen Kontakt wird nur die erste der drei möglichen Emailadressen betrachtet. (Zwei Aufrufbeispiele folgen unten.)

  So fügen Sie Makros in Outlook ein

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

Das erste Aufrufbeispiel verwendet für die Suche die Kategorie, die dem aktuellen Element (geöffnet oder Auswahl im Ordner) zugewiesen ist. Wenn dem Element mehrere Kategorien zugewiesen sind, wird nur die erste verwendet. Aufrufen können Sie diese Funktion z.B. über 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

Dieses zweite Aufrufbeispiel läßt Sie die zu suchende Kategorie manuell eingeben.

Sub CreateDistlist_2()
  Dim Category As String
  
  Category = InputBox("Diese Kategorie suchen")
  CreateDistlist_ex Category
End Sub