Gelöst Outlook: Könnte dieses VBA-Makro aus dem ChatGPT-Vorschlag funktionieren? (Ziel: Absender-Domain zu bestehender Regel hinzufügen)

Dieser Thread ist Teil einer Diskussion zu einem Artikel:  Zum News-Artikel gehen

Gaby Salvisberg

Super-Moderator
Hallo alle

Erste Frage: Wie schaffe ich es, in Outlook überhaupt ein eigenes Makro laufen zu lassen? Es heisst stets "Die Makros in diesem Projekt sind deaktiviert", auch wenn ich im Trust Center testhalber auf "Alle zulassen" schalte. [edit] Diese Frage ist mit https://www.howto-outlook.com/howto/selfcert.htm beantwortet. Makro wirft aber immer wieder Fehler aus, die der Bot unzureichend korrigiert :-D

Die zweite Frage: Das Makro, das ich ausprobieren wollte, war das folgende.
Ausgangslage: Ich habe in Outlook eine Filterregel namens PR01, die Mails von bestimmten Domains beim Eintreffen automatisch in einen Ordner namens PR verschiebt. Darin habe ich beim Filterkriterium "Mit (Zeichenfolge) in der Absenderadresse" bereits mehrere Domains eingetragen. Ich will nicht Dutzende verschiedene Regeln, die alle dasselbe tun (Grund: hier). Das manuelle Nachtragen einer einzelnen Domain in einer bestehenden Regel ist aber unglaublich kompliziert: Ich muss mühselig mit mehreren Klicks die Domain aus der Mail herausfriemeln, die Regel bearbeiten, dort die Domain einfügen, zweimal auf Weiter klicken, das Kästchen für "jetzt ausführen" anhaken und Fertigstellen.

Mir schwebt ein VBA-Makro vor, das folgendes tut: Wenn beim Ausführen des Makros eine Mail markiert ist, soll es die Domain dieser Mail inkl. @-Zeichen aus der Absenderadresse kopieren. Anschliessend soll das Makro die bestehende Filterregel namens PR01 bearbeiten und dort die Domain im Kriterium "Mit (Zeichenfolge) in der Absenderadresse" hinzufügen und die Regel auch gleich einmal ausführen.

Weil ich verschiedentlich gelesen habe, dass ChatGPT bei Code-Fragen gar nicht mal so schlecht sei, habe ich ihm die obige Aufgabe gestellt. Nachfolgend der Code, den mir ChatGPT vorgeschlagen hat. In meinen Code-Laien-Augen sieht das plausibel aus und sollte beim Ausprobieren wohl auch nichts beschädigen. Oder übersehe ich da was? Es kann aber auch sein, dass ChatGPT irgendwelches Zeug erfunden hat, das es in Outlook so gar nicht gibt. Ausprobieren kann ich es nicht, weil: siehe "Erste Frage".

Code:
Sub UpdateFilterRuleAndRun()
    Dim olApp As Outlook.Application
    Dim olExplorer As Outlook.Explorer
    Dim olSelection As Outlook.Selection
    Dim olItem As Object
    Dim olRule As Outlook.Rule
    Dim olCondition As Outlook.Condition
    Dim domain As String
  
    ' Outlook-Anwendung und aktiven Explorer erhalten
    Set olApp = Outlook.Application
    Set olExplorer = olApp.ActiveExplorer
  
    ' Aktuelle Auswahl im Explorer erhalten
    Set olSelection = olExplorer.Selection
  
    ' Überprüfen, ob eine E-Mail markiert ist
    If olSelection.Count = 1 Then
        Set olItem = olSelection.Item(1)
      
        ' E-Mail-Domain aus der Absenderadresse extrahieren
        domain = GetDomainFromAddress(olItem.SenderEmailAddress)
      
        ' Filterregel PR01 suchen
        For Each olRule In olApp.Session.DefaultStore.GetRules()
            If olRule.Name = "PR01" Then
                ' Bedingung zur Filterregel hinzufügen
                Set olCondition = olRule.Conditions.SenderAddress
                olCondition.Text = olCondition.Text & " " & domain
              
                ' Regel speichern und ausführen
                olRule.Execute ShowProgress:=True
                Exit For
            End If
        Next olRule
    End If
End Sub

Function GetDomainFromAddress(emailAddress As String) As String
    Dim atIndex As Long
  
    ' Position des @-Zeichens in der E-Mail-Adresse finden
    atIndex = InStr(emailAddress, "@")
  
    ' Domain extrahieren
    GetDomainFromAddress = Mid(emailAddress, atIndex + 1)
End Function

Dritte Frage: Falls das mit dem Makro nichts wird, wie könnte ich die Aufgabe aus "Frage zwei, Ausgangslage" dennoch vereinfachen?

Bin gespannt, ob jemand von euch eine sinnvolle Idee hat.

Herzliche Grüsse
Gaby
 
Zuletzt bearbeitet:

11291PCtipp

Stammgast
Nicht genau das gewünschte Verhalten:
Das erhaltene E-Mail mit der rechten Maustaste anwählen, > Verwandtes suchen > Nachrichten vom gleichen Absender > anwählen.
Jetzt können alle angezeigten E-Mails einfach ins gewünschte Verzeichnis verschoben werden.
 

nochEinAndreas

Stammgast
Hallo Gaby,

deine Frage hat mich dazu gebracht, mich das erste Mal mit VBA in Outlook zu beschäftigen. Ich habe den Code von ChatGPT mal in ein Modul in Outlook VBA eingefügt. Dann habe ich ihn schrittweise mit F8 ausgeführt.
Erste Auffälligleit: ChatGPT scheint etwas Fantasie zu haben: Ein Objekt namens "Outlook.Condition" kennt VBA nicht.
Ich habe dann mal die Anweisung auf "Dim olCondition" gekürzt.
Dann ging es schrittweise fehlerlos weiter bis
"For Each olRule In olApp.Session.DefaultStore.GetRules()".
Hier kommt die kryptische Fehlermeldung im Anhang.
Meine Recherchen im Netz zu dieser Meldung haben bisher leider gar nichts ergeben. Alle Codezeilen, die irgend etwas mit Rules zu tun haben, erzeugen diesen Fehler.
Sollte ich wider Erwarten weiter kommen, melde ich mich.

Sorry, Grüße und schönen Abend,
Andreas
 

Anhänge

  • Outlook VBA Fehler.jpg
    Outlook VBA Fehler.jpg
    25,9 KB · Aufrufe: 4

Gaby Salvisberg

Super-Moderator
Hallo Andreas
Danke, dass du dir den Code angeschaut hast. Ja, ChatGPT ist bekannt dafür, irgendwelches Zeug zu halluzinieren. So offenbar auch Outlook-Objekte. :-D
Herzliche Grüsse
Gaby
 

nochEinAndreas

Stammgast
Guten Abend Gaby,

es hat lange gedauert, aber ich habe mich durchgekämpft ... und hier ist das Ergebnis. (Es ist viel komplizierter als ChatGPT uns das erzählen wollte).

Drücke in Outlook Alt-F11, um den VBA Editor aufzurufen.
Klicke Einfügen - Modul
Füge den Code in das Modulfenster ein.
Schließe den VBA Editor.
In Outlook kannst du dir jetzt einen Button für den Makro setzen:
Datei - Optionen - Symbolleiste für den Schnellzugriff.
Im Dropdown über dem mittleren Fenster "Makros" auswählen.
Darunter sollte jetzt "Projekt1.verschieben" erscheinen.
Anklicken und über den "Hinzufügen >>" Button zur Symbolleiste hinzufügen.
OK klicken.

Der Makro funktioniert so:
Wähle die Mails aus, die in die Verschiebe-Regel aufgenommen werden sollen.
Starte den Makro.
Die Regel wird mit den Domains der ausgewählten Mails erweitert.
Die Regel wird dann vom Makro 1x ausgeführt.

Was gibt es zu beachten:
  • Sehr weit oben im Code habe ich 2 Konstanten definiert, nach deinen Vorgaben:
    • Die Konstante "nachOrdner" enthält den Ordner "PR", in den verschoben werden soll.
    • Die Konstante "regelName" enthält "PR01", den Namen der Regel, den du vorgegeben hattest.
Ändere das falls nötig.
  • Bedingung 1: Der Name des Ordners, in den verschoben werden soll (bei dir "PR") darf in der Ordner-Struktur nur 1x vorhanden sein. Ansonsten wird evtl. der falsche Ordner benutzt.

  • Bedingung 2: Die Verschiebe-Regel "PR01" oder wie sie auch heißen mag, muss existieren.
    Darin muss eine Bedingung "Mit bestimmten Wörtern in der Absenderadresse" und "Diese in den Ordner Zielordner verschieben" vorhanden sein. Ich hatte dich aber so verstanden, dass das so stimmt.
Ich bin gespannt, ob es bei dir funktioniert. Da ich blutiger Anfänger bei Outlook-Makros bin, habe ich keine Ahnung , was passiert.

Grüße und einen schönen Abend,
Andreas

Code:
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) Email(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 Ootlook-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 Objektholen
        With .Conditions.SenderAddress                          ' Aus der ausgesä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 eizigen 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.
                    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 ausü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.Folders(Application.Session.CurrentUser.Name)   ' Der Hauptordner der 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 such 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ückgabgewert setzen...
            Exit Function           ' ...und die Funkton 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
 

Gaby Salvisberg

Super-Moderator
Hallo Andreas
Danke sehr fürs Tüfteln!

Beim Ausführen des Makros erscheint ein Laufzeitfehler, weil ein Objekt nicht gefunden wurde. Der Klick auf Debuggen führt in die Function ziel, genauer hierhin:
Set start = Application.Session.Folders(Application.Session.CurrentUser.Name) ' Der Hauptordner der eigenen Mail-Accounts als Objekt

Sagt dir das was?

Herzliche Grüsse
Gaby
 

nochEinAndreas

Stammgast
Hallo Gaby,

danke fürs Testen. Die Zeile lief bei mir ohne Probleme. Sie soll den Root-Ordner in Outlook finden. Vielleicht gibts da Probleme wegen dem CurrentUser.Name, keine Ahnung.
Versuch mal die Zeile zu ersetzen durch
Code:
Set start = Application.Session.DefaultStore.GetRootFolder

Gruß und viel Erfolg,
Andreas
 

Gaby Salvisberg

Super-Moderator
Es klappt! Du bist der Beste, Andreas, vielen lieben Dank! 🥳

Dann wäre dies der aktuelle Code:

Code:
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) Email(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.
                    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 der 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 such 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ückgabgewert setzen...
            Exit Function           ' ...und die Funkton 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
 
Zuletzt bearbeitet:

nochEinAndreas

Stammgast
Uii, das ist ja geil. Damit hätte ich nicht so schnell gerechnet.
Jetzt denke ich natürlich über eine Erweiterung nach. Z.B. könnte der Makro prüfen, ob es schon eine Regel gibt. Wenn nicht, würde er eine erstellen.
Und mir ist noch ein Bug aufgefallen: Wenn du mehrere Mails auswählst, die alle von der selben Domäne kommen, wird diese mehrmals in die Liste eingetragen. Ich werde das heute Abend noch korrigieren und poste dann den neuen Code.

Grüße, Andreas
 

Gaby Salvisberg

Super-Moderator
Habs bis jetzt nur mit einzelnen Mails ausprobiert. Am Anfang war ich etwas skeptisch, ob es überhaupt was tut: Nachdem eine Mail angeklickt ist und ich im Schnellzugriff oben die Makroverknüpfung anklicke, scheint sich ein paar Sekunden lang nichts zu tun. Man sieht erst, dass sich etwas getan hat, wenn die Mail aus dem Posteingang verschwindet. Aber das stört immer noch viel weniger, als alle manuell in der Regel nachzutragen.
 

nochEinAndreas

Stammgast
Gute Abend Gaby,
warum es bei dir so lange dauert, bis die Mail sichtbar verschoben ist, weiß ich nicht. Bei mir im Test ging es blitzschnell. Vielleicht kommt es darauf an, wo die Mailordnerstruktur ist: POP3 auf dem lokalen PC oder IMAP auf irgend einem Server. Aber ich denke die Hauptsache ist, dass es funktioniert.
Wie angekündigt hier noch die leicht veränderte Version. Ein und die selbe Domäne wird jetzt nur noch 1x in die Liste eingetragen.
Grüße und noch einen schönen Abend,
Andreas

Code:
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) Email(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 Ootlook-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 Objektholen
        With .Conditions.SenderAddress                          ' Aus der ausgesä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 eizigen 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 ausü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 der 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 such 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ückgabgewert setzen...
            Exit Function           ' ...und die Funkton 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
 

chevi111

Neues Mitglied
Tolle Sache,
Genau sowas habe ich gesucht, da das "Regelwerk" von OL tatsächlich irgendwann völlig unübersichtlich wird. (Bei mir gibt's viele Regeln, da ich Anhänge gleich ins DMS übernehme)

Im Prinzip funktioniert es bei mir, allerdings bekomme ich beim "Regel-ausführen" eine Fehlermeldung:

Laufzeitenfehler 5: Ungültiger Prozeduraufruf oder ungültiges Argument

.Execute False, ordner, False, OlRuleExecuteOption.olRuleExecuteAllMessages
MEINE WERTE:
.Execute Falsch, "markierte und ungelesene", Falsch, OlRuleExecuteOption.olRuleExecuteAllMessages=0

Kann es daran liegen das der aktuelle Ordner ein "Suchordner" ist?

EDIT:
Eben mal im Posteingang direkt getestet: Funktioniert!
Scheint so dass der Suchordner (virtuell?) nicht funktioniert...
Irgendwer eine Idee?

LG Chevi
 
Zuletzt bearbeitet:

nochEinAndreas

Stammgast
Hallo chevi,

bin eben erst aus dem Urlaub zurück und war deshalb 4 Wochen offline und rechner-abstinent. Sorry.
Dein Ordner-Name "markierte und ungelesene" enthält Leerzeichen. Deswegen vermute ich, dass das Outlook-VBA die Teile als verschiedene Argumente interpretiert. Versuch mal, die Zeile
.Execute False, ordner, False, OlRuleExecuteOption.olRuleExecuteAllMessages
zu ersetzen durch
.Execute False, Chr(34) & ordner & Chr(34), False, OlRuleExecuteOption.olRuleExecuteAllMessages
Das schließt den Ordner-Namen in Anführungszeichen ein. Vielleicht klappt es dann.

Grüße, Andreas
 

chevi111

Neues Mitglied
Hallo Andreas,

Danke für deine Rückmeldung!
Das könnte natürlich funktionieren.

Da es sich in meinem Suchordner um Daten aus "inbox" und "junkfolder" handelt, habe ich das jetzt erstmal so gelöst, dass ich einfach beide Ordner abarbeite:

Code:
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.NameSpace
Dim olSelection As Outlook.Selection
Dim olJunkFolder As Outlook.Folder
Dim olInbox As Outlook.Folder
Dim olMailItem As Outlook.MailItem
   
' Get the Outlook application and namespace
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olJunkFolder = olNamespace.GetDefaultFolder(olFolderJunk)  ' Get the "Junk E-Mail" folder
Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) ' Get the "Posteingang" folder

.
.
.
.Execute False, olInbox, False, OlRuleExecuteOption.olRuleExecuteAllMessages
.Execute False, olJunkFolder, False, OlRuleExecuteOption.olRuleExecuteAllMessages

funktioniert prächtig.

LG Chevi
 
Oben