Das geniale Makro – in Outlook hinzufügen

Option Explicit
Option Base 1

' Dieser Makro erweitert eine Regel zum Verschieben von Mails.
' Der Domänen-Name von markierten Mails wird in die
' Regel-Liste zum Verschieben aufgenommen.
' Die erweiterte Regel wird 1x per Makro ausgeführt

' Es gibt zwei Bedingungen:
' - Der Name des Ordners, in den verschoben werden soll,
'   darf in der Ordnerstruktur nur 1x vorhanden sein.
' - Die Regel, die in der Konstanten 'regelName' genannt ist,
'   muss mindestens 1 Bedingung enthalten,
'   dass Mails mit bestimmtem Text in der Absender-Adresse
'   in den angegebenen Ordner verschoben werden sollen.

Sub verschieben()
    ' Diese zwei Konstanten nach Wunsch anpassen:
    Const nachOrdner As String = "PR"   ' Der Ordner, in den die Mails verschoben werden
    Const regelName As String = "PR01"  ' Der Name der Regel, die erweitert wird.
    
    Dim zielOrdner As Outlook.Folder    ' Der Zielordner als Objekt
    Dim regeln As Outlook.Rules         ' Alle Regeln als Objekt
    Dim absender As Variant             ' Die Liste der Absender in der Regel
    Dim explorer As Outlook.explorer    ' Der Outlook-Explorer als Objekt
    Dim email As Object                 ' Die ausgewählte(n) E-Mail(s) als Objekt
    Dim domäne As String                ' Domäne einer Mail-Adresse
    Dim domänenListe As String          ' Liste aller Domänen in der Regel-Liste als ein String
    Dim i As Integer                    ' Schleifen-Laufvariable
    Dim ordner As Outlook.Folder        ' Ein Outlook-Ordner als Objekt
    
    Set explorer = Application.ActiveExplorer       ' Den Outlook-Explorer holen
    Set ordner = explorer.CurrentFolder             ' Den aktiven Outlook-Ordner holen
    If explorer.Selection.Count < 1 Then Exit Sub   ' Wenn keine Mail ausgewählt ist, den Makro beenden
  
    Set zielOrdner = ziel(nachOrdner)       ' Den Ziel-Ordner als Objekt über die Funktion 'ziel' finden
    If zielOrdner Is Nothing Then                               ' Wenn es den Ziel-Ordner nicht gibt...
        MsgBox "Zielordner nicht gefunden", , "Tut mir Leid"    ' ...Meldung ausgeben...
        Exit Sub                                                ' ...und Makro beenden
    End If
    
    Set regeln = Application.Session.DefaultStore.GetRules()    ' Die Regeln als Objekt holen
    With regeln(regelName)                                      ' Aus den Regeln die ausgewählte Regel als Objekt holen
        With .Conditions.SenderAddress                          ' Aus der ausgewählten Regel die Bedingung für Absender-Adressen als Objekt holen
            absender = .Address                                 ' Die Adressenliste in ein Variablenfeld holen
            domänenListe = ""                                   ' Die Domänenliste als leer initialisieren
            For i = 0 To UBound(absender)                       ' Alle Domänen in der Liste durchgehen
                domänenListe = domänenListe & absender(i) & "," ' Die Domänen zu einem einzigen Text zusammenbauen
            Next i
            
            For Each email In explorer.Selection                ' Alle ausgewählten Mails durchgehen
                With email
                    domäne = Mid(.SenderEmailAddress, InStr(.SenderEmailAddress, "@"))  ' Die Domäne der Mail extrahieren
                    If InStr(domänenListe, domäne & ",") = 0 Then                       ' Wenn die Domäne noch nicht in der Liste ist...
                        ReDim Preserve absender(0 To UBound(absender) + 1)              ' ...das Datenfeld der Domänen erweitern...
                        absender(UBound(absender)) = domäne                             ' ...und die neue Domäne hinzufügen.
                        domänenListe = domänenListe & domäne & ","                      ' Die neue Domäne in die Domänenliste mit aufnehmen
                    End If
                End With
            Next email
            
            .Address = absender         ' Das erweiterte Datenfeld mit den Domänen in die Adressenliste der Regel schreiben
        End With
        regeln.Save                     ' Alle Regeln sichern
        ' Die Regel einmalig ausführen.
        ' 1. False:                                     Keine Fortschrittsanzeige
        ' ordner:                                       Die Regel im aktuellen Ordner ausführen
        ' 2. False:                                     Unterordner nicht mit berücksichtigen
        ' OlRuleExecuteOption.olRuleExecuteAllMessages  Regel für alle Mails im Ordner anwenden, egal ob gelesen oder ungelesen
        .Execute False, ordner, False, OlRuleExecuteOption.olRuleExecuteAllMessages
    End With
End Sub

' Die Funktion ermittelt den Hauptordner des eigenen Mail-Accounts.
' Diesen Hauptordner und den Namen des gesuchten Ziel-Ordners
' übergibt sie an die Funktion 'finde'
' Deren Ergebnis wird zurückgegeben
Function ziel(ordner As String) As Outlook.Folder
    Dim start As Outlook.Folder
    
    Set start = Application.Session.DefaultStore.GetRootFolder   ' Der Hauptordner des eigenen Mail-Accounts als Objekt
    Set ziel = finde(start, ordner)     ' Aufruf der Funktion 'ziel' mit Übergabe des Hauptordnders und des Zielordners
End Function

' Die Funktion sucht den Zielordner in der Struktur des Hauptordners
' und gibt diesen als Objekt zurück
' Wird er nicht gefunden, kommt 'Nothing' zurück
Function finde(of As Outlook.Folder, ordner As String) As Outlook.Folder
    Dim osf As Outlook.Folder   ' Outlook Unterordner als Objekt
    
    Set finde = Nothing             ' Das Ergebnis initialisieren
    For Each osf In of.Folders      ' Alle Unterordner des Hauptordners bearbeiten
        If osf.Name = ordner Then   ' Wenn der Zielordner gefunden wurde...
            Set finde = osf         ' ...den Zielordner als Rückgabewert setzen...
            Exit Function           ' ...und die Funktion beenden
        End If
        Set finde = finde(osf, ordner)  ' Sonst die Funktion rekursiv aufrufen, mit dem Unterordner als Startpunkt.
        If Not finde Is Nothing Then                    ' Wenn etwas gefunden wurde...
            If finde.Name = ordner Then Exit Function   '...und der Fund ist der Zielordner, Funktion beenden
        End If
    Next osf
End Function