Outlook – Verteilerlisten automatisch aus Kategorien erstellen

Mein Kalender wird schon lange mit Outlook geführt aber meine Mails liefen bisher übder den (fast) perfekten Mailclienten von Opera. Dabei habe ich mir meine Adressdaten aus Outlook über ein VBA Skript in das Opera Adressbuch geschrieben, denn auch meine Adressen werden mit Outlook gefplegt. Nun hat Opera mit der aktuellsten Version den Mailclieneten nicht mehr mit an Bord, sondern in eine eigene Applikation ausgelagert. Zudem – und das wiegt zur Zeit schwerer, verweigert OperaMail nach wie vor S_Mime bzw. PGP Verschlüsselung.
Das aber soll nun irgendwann standard werden bei mir … – also muss Outlook nun doch für die Mailverwaltung hinhalten.

Was mich aber schon immer gestört hat: Verteilerlisten für das Versenden von Mails an mehrere Empfänger lassen sich nicht automatisch aus den Kategorien erstellen, die in Outlook für das Eimordnen von Kontakten, Terminen usw. zuständig sind. Ein Beispiel: Ich ordne einige Kontakte der Kategorie „Stammtisch“ zu. Nun möchte ich allen Mitgliedern des Stammtisches eine Mail schicken… – da gibt es zunächst die Möglichkeit per Hand eine Verteilerliste anzulegen und alle Personen da hinein zu schieben … mein Problem: Ich habe mehrere Dutzend Kontaktkategorien! Das wäre eine Menge Handarbeit. Zudem ist es so, dass sich Änderungen der Mailadressen bei den Kontakten nicht automatisch in den Verteilerlisten wiederfinden. Es braucht zum Aktualisieren zwar nur einen Klick aber … man muss eben auch dran denken.

Nun gibt es zwar eine recht einfache Möglichkeit, allen Kontakten einer Kategorie eine Mail zu schicken (Die Kontakte der Kategorie markieren und dann auf die Mail-Schaltfläche in der Navigationsleiste ziehen…) Aber das löst das Problem nur beim Neuerstellen einer Mail.

Ein weiteres Beispiel zeigt die weitere Schwierigkeit. Ich bekomme eine Mail vom Stammtisch und will die Neuigkeit an alle in der Kategorie „Sportverein“ weiterleiten… Jetzt erst eine neue Mail über die Kategorie eröffnen, die Adressen aus der An-Zeile herauskopieren und dann in die An-Zeile der weiterzuleitenden Mail kopieren … – total doof!

Fazit: Die „An..:“-Zeile einer Mailnachricht lässt sich nur komfortabel füllen, wenn die Kontaktgruppen als Verteilerliste vorliegen!

Also musste VBA ran und das Problem lösen. Vorweg – ich bin kein VBA Spezialist – eher ein „Bastler“.
Hier meine Bastelarbeit – wie immer in solchen Fällen: Keine Garantie!!! Und vorher am besten die Outlook.pst Datei sichern!:

Im VBA-Editor (Alt+F11) links oben unter „VBAProjekt“ ein Doppelklick auf „DieseOutlookSitzung“ und dann rechts in das Editorfeld folgenden Code eingeben.


Public Sub Application_Startup()
    Call Verteilerlisten.VerteilerlistenMenue 'erstellt den Button für das Erstellen der Verteielrlisten
End Sub

Das bewirkt, dass beim Starten von Outlook ein neuer Menüpunkt erstellt wird.

Vorher muss aber noch die Datei Verteilerlisten.bas als neues Modul über „Datei/importieren“ in das VBA Projekt eingefügt werden. (Basicdatei – ist in ZIPFile gepackt, weil der Server Basicdateien verständlicher Weise nicht mag. Wer Angst hat, sich eine „böse“ Datei damit herunterzuladen, kann auch den Code unten in ein neues Modul „Verteilerlisten“ im VBA Editor packen)
Verteilerlisten.zip

So – am besten einmal neu starten und dabei das VBA Projekt speichern. Nach Neustart sollte der Menüpunkt „Verteilerlisten“ erscheinen.

Hier der Code zur Bastelarbeit, der in dem Modul „Verteilerlisten“ steckt:

Code ohne Kommentare…
Code mit Kommentaren…


Public Sub VerteilerlistenMenue()
  Dim exFenster As Outlook.Explorer
  Dim menueListen As Office.CommandBar
  Dim btnListen As Office.CommandBarButton
  
  Set exFenster = Application.ActiveExplorer 
  Set menueListen = exFenster.CommandBars.Item("Erweitert")

  Set btnListen = menueListen.Controls.Add(, , , , True)
  With btnListen
    .Caption = "Verteilerlisten" 
    .BeginGroup = True 
    .DescriptionText = "Exportiert alle Kategorien mit den enthaltenen Kontakten in gleichnamige Verteilerlisten"
    .Visible = True
    .OnAction = "Listen" 
  End With
  

End Sub

Private Sub Listen()

Dim NameSpace As NameSpace
Dim objKategorie As Object
Dim colKategorien As New Collection
Dim strFilterKategorien As String
Dim strFilterListen As String
Dim folKontakte As Outlook.Folder
Dim dlVerteilerliste As Outlook.DistListItem
Dim rcEmpfaenger As Outlook.Recipient
Dim itsKontakte As Outlook.Items
Dim itsKontakteAlle As Outlook.Items
Dim itsListen As Outlook.Items
Dim itsZuLoeschen As Outlook.Items
Dim bolErfolg As Boolean
Dim objMail As MailItem

Set NameSpace = Application.GetNamespace("MAPI")
Set folKontakte = NameSpace.GetDefaultFolder(olFolderContacts)

For Each objKategorie In NameSpace.Categories
    colKategorien.Add (objKategorie.Name) 
Next

CollectionSort colKategorien 

For i = 1 To colKategorien.Count
    strFilterKategorien = "@SQL=" & Chr(34) _
    & "urn:schemas-microsoft-com:office:office#Keywords" & Chr(34) _
    & " Like '" & colKategorien(i) & "%'"
  
    strFilterListen = "[FullName] = ' _" & colKategorien(i) & "_' AND [MessageClass]='IPM.DistList'"

    Set itsZuLoeschen = folKontakte.Items.Restrict(strFilterListen)
    For h = itsZuLoeschen.Count To 1 Step -1               
        itsZuLoeschen.Remove (h)                          
     Next
 
    Set itsKontakte = folKontakte.Items.Restrict(strFilterKategorien)
    If itsKontakte.Count > 0 Then 
        Set dlVerteilerliste = CreateItem(olDistributionListItem)
        dlVerteilerliste.DLName = "_" & colKategorien(i) & " _"
      
         For j = 1 To itsKontakte.Count
            If itsKontakte(j).Email1Address <> "" Or itsKontakte(j).Email2Address <> "" Then
                bolErfolg = True 'brauche ich weiter unten ...
                Set rcEmpfaenger = Outlook.Session.CreateRecipient(itsKontakte(j).Email1Address)
                If rcEmpfaenger.Resolve = True Then 
                    dlVerteilerliste.AddMember rcEmpfaenger 
                End If
                Set rcEmpfaenger = Outlook.Session.CreateRecipient(itsKontakte(j).Email2Address)
                If rcEmpfaenger.Resolve = True Then
                    dlVerteilerliste.AddMember rcEmpfaenger
                End If
            End If
        Next
        If bolErfolg = True Then 
            dlVerteilerliste.Save 
            Set objMail = Application.CreateItem(olMailItem)
            With objMail
                .Recipients.Add ("_" & colKategorien(i) & " _")
                .Recipients.ResolveAll
                .Delete
            End With
        Else
            dlVerteilerliste.Delete 
        End If
  End If
  bolErfolg = False 
Next

End Sub

Function CollectionSort(ByRef oCollection As Collection, Optional bSortAscending As Boolean = True) As Long
    Dim lSort1 As Long, lSort2 As Long
    Dim vTempItem1 As Variant, vTempItem2 As Variant, bSwap As Boolean
    
    On Error GoTo ErrFailed
    For lSort1 = 1 To oCollection.Count - 1
        For lSort2 = lSort1 + 1 To oCollection.Count
            If bSortAscending Then
                If oCollection(lSort1) > oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            Else
                If oCollection(lSort1) < oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            End If
            If bSwap Then
                If VarType(oCollection(lSort1)) = vbObject Then
                    Set vTempItem1 = oCollection(lSort1)
                Else
                    vTempItem1 = oCollection(lSort1)
                End If
                
                If VarType(oCollection(lSort2)) = vbObject Then
                    Set vTempItem2 = oCollection(lSort2)
                Else
                    vTempItem2 = oCollection(lSort2)
                End If
                
                oCollection.Add vTempItem1, , lSort2
                oCollection.Add vTempItem2, , lSort1
                'Delete the original items
                oCollection.Remove lSort1 + 1
                oCollection.Remove lSort2 + 1
            End If
        Next
    Next
    Exit Function
    
ErrFailed:
    Debug.Print "Error with CollectionSort: " & Err.Description
    CollectionSort = Err.Number
    On Error GoTo 0
End Function


Public Sub VerteilerlistenMenue()
  Dim exFenster As Outlook.Explorer
  Dim menueListen As Office.CommandBar
  Dim btnListen As Office.CommandBarButton
  
  Set exFenster = Application.ActiveExplorer 'das Anwendungsfenster
  Set menueListen = exFenster.CommandBars.Item("Erweitert") 'die Erweitert-Menü-Leiste

  Set btnListen = menueListen.Controls.Add(, , , , True) 'dem Menü einen Button hinzufügen
  With btnListen
    .Caption = "Verteilerlisten" 'Beschriftung des Button
    .BeginGroup = True 'zur Gestaltung des Menüs vor den Button eine Trennlinie
    .DescriptionText = "Exportiert alle Kategorien mit den enthaltenen Kontakten in gleichnamige Verteilerlisten"
    .Visible = True
    .OnAction = "Listen" 'ruft beim Klicken die Subroutine "Listen" auf
  End With
  

End Sub

Private Sub Listen()

Dim NameSpace As NameSpace
Dim objKategorie As Object
Dim colKategorien As New Collection
Dim strFilterKategorien As String
Dim strFilterListen As String
Dim folKontakte As Outlook.Folder
Dim dlVerteilerliste As Outlook.DistListItem
Dim rcEmpfaenger As Outlook.Recipient
Dim itsKontakte As Outlook.Items
Dim itsKontakteAlle As Outlook.Items
Dim itsListen As Outlook.Items
Dim itsZuLoeschen As Outlook.Items
Dim bolErfolg As Boolean
Dim objMail As MailItem

'Arbeitsbereich vorbereiten
Set NameSpace = Application.GetNamespace("MAPI")
Set folKontakte = NameSpace.GetDefaultFolder(olFolderContacts)

'alle vorhandenen Kategorien auslesen und in eine Sammlung einfügen
For Each objKategorie In NameSpace.Categories
    colKategorien.Add (objKategorie.Name) 'die Collection "Kategorien" mit den Namen aller Kategorien füllen
Next
'es handelt sich hierbei um die Kategorien, die in der Liste unter "Alle KAtegorien" bzw. Farbkategorien aufgeführt wird.
'das bedeutet in diesem Zusammenhang, das Elemente mit Einträgen im Feld Kategorie, die aber nicht mehr in der Hauptliste vorkommen,
'von diesem Script nicht abgehandelt werden. Auch Verteilerlisten, die anders heißen als die Kategorien in der Hauptliste werden nicht angerührt,
'es bleibt also weiterhin möglich von Hand Verteilerlisten anzulegen, sofern diese nicht heißen, wie vorhandene Katgorien...

CollectionSort colKategorien 'die Sammlung der Kategorienamen alphabetisch sortiern - macht sich später im Handling besser ...

'nun Schleife durch alle Kategorien
For i = 1 To colKategorien.Count
 
    'Suchkriterien, um in den Kontakten die zu finden, die zu einer bestimmten Kategorie gehören
    strFilterKategorien = "@SQL=" & Chr(34) _
    & "urn:schemas-microsoft-com:office:office#Keywords" & Chr(34) _
    & " Like '" & colKategorien(i) & "%'"
    'Der Ausdruck ist deshalb so kompliziert, da da Kategorienfeld aus vielen Einträgen bestehen kann, die durch Semikolons getrennt sind ...
    
    'Bei der Suche nach einer bestimmten Verteilerliste per Namen ist es einfacher...
    'Suche nach Verteilerlisten (Messageclass=IPM.DistList), die genauso heißen, wie die aktuelle Kategorie
    strFilterListen = "[FullName] = ' _" & colKategorien(i) & "_' AND [MessageClass]='IPM.DistList'"

    'Sofern es bereits eine Verteilerliste mit dem Namen der aktuellen Kategorie gibt, soll die zunächst gelöscht werden
    Set itsZuLoeschen = folKontakte.Items.Restrict(strFilterListen) 'Suchen, ob es schon eine gibt
    For h = itsZuLoeschen.Count To 1 Step -1               'eigentlich sollte es nur eine geben können - aber man weiß ja nie ...
        itsZuLoeschen.Remove (h)                           'entfernen der Liste aus der KontakteAuflistung
        'da itsZuLoeschen letztlich eine Referenz auf den KontakteOrdner ist, wird die Liste nicht nur aus itsZuLoeschen entfernt...
    Next
    'Vielleicht ist es wem aufgefallen - vor den Namen der Kategroien/Verteilerlisten steht immer ein Unterstrich und hinten ebenfalls -
    'dazu unten mehr!
        
    
    'Nun kann die Liste neu aufgebaut werden - dazu alle Kontakte suchen, die zu aktuellen Kategorie gehören
    Set itsKontakte = folKontakte.Items.Restrict(strFilterKategorien)
    If itsKontakte.Count > 0 Then 'wenn es welche gibt, eine neue Verteilerliste erstellen
        Set dlVerteilerliste = CreateItem(olDistributionListItem)
        'die Liste erhält den Namen der aktuellen Kategorie und ein Zeichen, sodass der Name eindeutig wird - eindeutig ist wichtig für die Resolve-Methode
        dlVerteilerliste.DLName = "_" & colKategorien(i) & " _"
        'die Unterstriche haben aber einen weiteren Grund - dazu unten wie gesagt mehr ...
            
        'Schleife durch die zur Kategroie gehörigen Kontakte
        For j = 1 To itsKontakte.Count
            'Schauen, ob zu den Kontakten auch eine Mailadresse gehört
            '(ich nutze nur die ersten beiden Mailfelder - ggf. diese Schleife an weitere Mailfelder anpassen)
            If itsKontakte(j).Email1Address <> "" Or itsKontakte(j).Email2Address <> "" Then
                bolErfolg = True 'brauche ich weiter unten ...
                'nun aus der Mailadresse einen "Recipient", also einen Empfänger machen ...
                Set rcEmpfaenger = Outlook.Session.CreateRecipient(itsKontakte(j).Email1Address)
                If rcEmpfaenger.Resolve = True Then 'wird benötigt, um die Adresse "aufzulösen"
                    dlVerteilerliste.AddMember rcEmpfaenger 'Den Recipient der Liste hinzufügen
                End If
                'nun das gleiche für die zweite MAiladresse
                Set rcEmpfaenger = Outlook.Session.CreateRecipient(itsKontakte(j).Email2Address)
                If rcEmpfaenger.Resolve = True Then
                    'sollte die MAiladresse leer sein, dann ergibt die resolve Methode einen Fehler und es wird auch
                    'kein Empfänger hinzugefügt ...
                    dlVerteilerliste.AddMember rcEmpfaenger
                End If
            End If
        Next
        If bolErfolg = True Then 'wenn mindestens eine Mailadresse vorhanden war und deshalb also ein Empfänger eingteragen wurde
            dlVerteilerliste.Save 'die Liste nun auch speichern
            
            'ich lasse das Skript an dieser Stelle noch eine Mail an die neue Verteielrliste erstellen. Dadurch wird der Name der Liste auch
            'in die Vorschlagsliste für Autovervollständigung aufgenommen - also die Vorschläge, die man beim Tippen der Empängeradresse bekommt.
            Set objMail = Application.CreateItem(olMailItem)
            With objMail
                .Recipients.Add ("_" & colKategorien(i) & " _")
                .Recipients.ResolveAll
                'für diese Resolve Methode ist es gut, dass die Liste durch ddie Unterstriche einen eindeutigen Namen hat, damit es nicht mehrere
                'Möglichkeiten gibt (ich nutze nämlich "aufbauende" Kategorien - z.B.: 1) "Stammtisch" 2) "Stammtisch | Mitglieder" 3) "Stammtisch | Vorstand" 4) "Stammtisch | Vorsatand | Vorsitzender"
                'Würde ich ohne eindeutige Zeichen arbeiten, dann würde die ResolveMethode fehlschlagen
                
                'Der Unterstrich am Anfang wäre dazu eigentlich nicht nötig - aber der hat einen anderen Vorteil. Tippe ich in die Adresszeile
                'nur einen Unterstrich, dann werden bereits alle Listen angezeigt und so kann man ggfs auch durch die Kategorien scrollen
                
                'Das klappt nun also und so kann ich die dafür erstellte Mail wieder löschen...
                .Delete
            End With

        Else
            dlVerteilerliste.Delete 'falls keine Kontakte in der Kategorie vorhanden, die Liste wieder löschen, da die Liste leer wäre...
        End If
  End If
  bolErfolg = False 'Reset für nächsten Durchlauf
Next

End Sub



'wird zum Sortieren der Kategorien benötigt - habe ich aus dem Netzt "geraubt"
Function CollectionSort(ByRef oCollection As Collection, Optional bSortAscending As Boolean = True) As Long
    Dim lSort1 As Long, lSort2 As Long
    Dim vTempItem1 As Variant, vTempItem2 As Variant, bSwap As Boolean
    
    On Error GoTo ErrFailed
    For lSort1 = 1 To oCollection.Count - 1
        For lSort2 = lSort1 + 1 To oCollection.Count
            If bSortAscending Then
                If oCollection(lSort1) > oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            Else
                If oCollection(lSort1) < oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            End If
            If bSwap Then
                'Store the items
                If VarType(oCollection(lSort1)) = vbObject Then
                    Set vTempItem1 = oCollection(lSort1)
                Else
                    vTempItem1 = oCollection(lSort1)
                End If
                
                If VarType(oCollection(lSort2)) = vbObject Then
                    Set vTempItem2 = oCollection(lSort2)
                Else
                    vTempItem2 = oCollection(lSort2)
                End If
                
                'Swap the items over
                oCollection.Add vTempItem1, , lSort2
                oCollection.Add vTempItem2, , lSort1
                'Delete the original items
                oCollection.Remove lSort1 + 1
                oCollection.Remove lSort2 + 1
            End If
        Next
    Next
    Exit Function
    
ErrFailed:
    Debug.Print "Error with CollectionSort: " & Err.Description
    CollectionSort = Err.Number
    On Error GoTo 0
End Function

Wie bei jeder Bastelarbeit gibts auch hier ein paar unschöne Ecken:
Da die Kontakte über die Mailadressen in die Listen eingetragen werden, sind sie dort so zu sehen, als wenn sie über die Funktion "Neu hinzufügen" in einer Liste erstellt worden wären. Zwar führt ein Doppeklick auf die Mailadresse zum passenden Kontakt, aber dennoch sind beide nicht intern miteinander richtig verknüpft. Eine "Aktualisierung" über "jetzt aktualisieren" im Menü der Liste führt zu keiner Änderung, auch wenn der entsprechende Kontakt inzwischen eine neue Mailadresse bekommen hat.

Um das "richtig" hinzubekommen, habe ich auch nach langem Googeln keine Lösung gefunden. Mir ist das aber auch egal, ich aktualisiere die Listen bei Bedarf eben über das Skript und baue so alle Listen wieder neu auf.
Da liegt allerdings die zweite unschöne Ecke: Dank meiner vielen,vielen Kategorien braucht das Skript etwa eine ganze Minute zum Durchlaufen. Aber gut - so viel Zeit habe ich...

Hinterlassen Sie einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht.