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...