AW: Outlook Verteiler Makro
02.04.2025 00:33:56
Tob1as
Hallo Uwe,
ich habe es nun nach Ewigkeiten des Probierens mithilfe von chatgpt geschafft.
Danke für deine Hilfe!
Viele Grüße
Tobias
Hier der finale Code, der bisher gut funktioniert hat:
Option Explicit
Sub OutlookVerteiler()
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olDistList As Object
Dim olRecipient As Object
Dim dictEmails As Object
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim vorname As String, nachname As String, email As String
Dim emails As Variant, key As Variant
Dim olItems As Object
Dim olItem As Object
Dim olDistLists As Object
Dim existingDistList As Object
Dim distListName As String
Dim dictContacts As Object
Dim contactExists As Boolean
Dim updatedContacts As Long
distListName = "NAME VERTEILER"
' Outlook-Objekte initialisieren
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
If Err.Number > 0 Then
MsgBox "Fehler: Outlook konnte nicht gestartet werden.", vbCritical
Exit Sub
End If
On Error GoTo 0
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.Folders("beispiel@email.de").Folders("Kontakte") ' Kontakte-Ordner des spezifischen Postfachs
' Dictionary für E-Mail-Adressen und zugehörige Namen
Set dictEmails = CreateObject("Scripting.Dictionary")
Set dictContacts = CreateObject("Scripting.Dictionary") ' Speichert Kontakte mit Name-Email-Zuordnung
' Arbeitsblatt festlegen
Set ws = ThisWorkbook.Sheets("TABELLENBLATT")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
' Daten aus Excel durchgehen
For i = 2 To lastRow
vorname = Trim(ws.Cells(i, 1).Value)
nachname = Trim(ws.Cells(i, 2).Value)
email = Trim(ws.Cells(i, 10).Value) ' Spalte J = 10
' Stelle sicher, dass nur gültige Zeilen verarbeitet werden
If vorname > "" And nachname > "" And email > "" And InStr(email, "@") > 0 Then
emails = Split(email, ";")
Dim e As Variant
For Each e In emails
e = LCase(Trim(e))
' Falls E-Mail noch nicht existiert, hinzufügen
If Not dictEmails.exists(e) Then
dictEmails.Add e, vorname & " " & nachname
Else
' Falls gleiche Mailadresse für Geschwister, Namen zusammenführen
If InStr(dictEmails(e), vorname & " " & nachname) = 0 Then
dictEmails(e) = dictEmails(e) & " & " & vorname & " " & nachname
End If
End If
Next e
End If
Next i
' Bestehende Verteilerlisten durchsuchen
Set olDistLists = olFolder.Items
If olDistLists Is Nothing Then
MsgBox "Fehler: Outlook-Kontakte konnten nicht geladen werden.", vbCritical
Exit Sub
End If
Set existingDistList = Nothing
On Error Resume Next
For Each olItem In olDistLists
If Not olItem Is Nothing Then
If TypeName(olItem) = "DistListItem" Then
If olItem.DLName = distListName Then
Set existingDistList = olItem
Exit For
End If
End If
End If
Next olItem
On Error GoTo 0
' Falls der Verteiler existiert, löschen
If Not existingDistList Is Nothing Then
existingDistList.Delete
End If
' Neuen Verteiler erstellen
Set olDistList = olFolder.Items.Add(7) ' 7 = olDistributionList
olDistList.DLName = distListName
' Mitglieder zum Verteiler hinzufügen
For Each key In dictEmails.keys
Set olRecipient = olApp.Session.CreateRecipient(key)
olRecipient.Resolve
If olRecipient.Resolved Then
olDistList.AddMember olRecipient
Else
Debug.Print "Fehler: Konnte " & key & " nicht hinzufügen."
End If
Next key
olDistList.Save
' Kontakte in Outlook hinzufügen oder aktualisieren
Dim addedContacts As Long
addedContacts = 0
updatedContacts = 0
For Each key In dictEmails.keys
contactExists = False
' Bestehenden Kontakt suchen
For Each olItem In olFolder.Items
If TypeName(olItem) = "ContactItem" Then
If LCase(Trim(olItem.Email1Address)) = key Or LCase(Trim(olItem.Email2Address)) = key Or LCase(Trim(olItem.Email3Address)) = key Then
' Falls der Name oder die Anzeige geändert werden muss
If olItem.FullName > dictEmails(key) Or olItem.Email1DisplayName > dictEmails(key) Then
olItem.FullName = dictEmails(key)
olItem.Email1DisplayName = dictEmails(key)
olItem.Save
updatedContacts = updatedContacts + 1
End If
contactExists = True
Exit For
End If
End If
Next olItem
' Falls der Kontakt nicht existiert, neuen Kontakt anlegen
If Not contactExists Then
Dim olContact As Object
Set olContact = olFolder.Items.Add("IPM.Contact")
olContact.FullName = dictEmails(key)
olContact.Email1Address = key
olContact.Email1DisplayName = dictEmails(key)
olContact.Save
addedContacts = addedContacts + 1
End If
Next key
' Erfolgsnachricht
MsgBox addedContacts & " Kontakte wurden erfolgreich hinzugefügt!" & vbCrLf & _
updatedContacts & " Kontakte wurden erfolgreich aktualisiert!" & vbCrLf & _
"Der Verteiler wurde aktualisiert!", vbInformation
' Objekte freigeben
Set olDistList = Nothing
Set olRecipient = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub