Es geht um den ersten Auschnitt den ich gepostet habe. Der Code ist aus dem Netz.
Er funktioniert einwandfrei bis auf das Löschen bereits vorhanderner Listen.
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
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
Public 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
|