Outlook – Mail verschieben mit VBA

Ich organisiere meine E-Mails in Outlook in verschiedenen Ordnern. Dabei landen diese in den Unterordnern wenn ich die Mails gelesen habe. Die Anzahl der Unterordner in Outlook wird mit der Zeit recht groß. Jedoch gibt es eine “Top Ten” der Ordner in denen die E-Mails landen.

Um die E-Mails schneller dahin zu verschieben, habe ich im Outlook die Ribbon Bar angepasst und verschiedene Makros abgelegt. Mit Hilfe der Makros werden die markierten Mails dann in entsprechende Ordner verschoben und als gelesen markiert.

VBA – Makros zum verschieben von E-Mails

Mit dem folgenden VBA Makros werden meine Mails verschoben.

Teil 1 – VerschiebeInGelesen()

Die Funktion VerschiebeInGelesen() gibt es pro Zielordner . Hier wird die Hauptfunktion aufgerufen und der Pfad zum Ordner übergeben.

Teil 2 – VerschiebeEMail(ZielOrdner As String)

Hier wird in der Funktion VerschiebeEMail(ZielOrdner As String) in einer FOR Schleife jede markierte E-Mail als gelesen markiert und in den Unterordner verschoben.

Zuvor wird der Zielordner Pfad in ein Array umgewandelt und anschließend als MAPIFolder Objekt zurück gegeben.

''' Je Ordner ein Sub Aufruf
''' Teil 1
Sub VerschiebeInGelesen()
    VerschiebeEMail ("\\<Postfachname>\Posteingang\<Zielordner>")
End Sub

''' Verschiebt E-Mails in einen Zielordner
''' Die Pfadangabe aus Outlook kopieren
''' Teil 2
Sub VerschiebeEMail(ZielOrdner As String)
    Dim strOutlookFolderPath As String
    Dim oulAusgewaehlte As Outlook.Selection
    Dim intZähler As Integer
    Dim strOutlookMAPIFolders() As String
    Dim mapFld As MAPIFolder
    
    Set oulAnwendung = CreateObject("Outlook.Application")
    Set oulAusgewaehlte = oulAnwendung.ActiveExplorer.Selection
    
    strOutlookFolderPath = ZielOrdner
    strOutlookMAPIFolders = GetOutlookMapiFolder(strOutlookFolderPath)
    Set mapFld = GetOutlookMapiObject(strOutlookMAPIFolders)
       
    For intZähler = 1 To oulAusgewaehlte.Count
        oulAusgewaehlte.Item(intZähler).UnRead = False
        oulAusgewaehlte.Item(intZähler).Move mapFld
    Next intZähler
End Sub

Teil 3 – GetOutlookMapiObject(OutlookMAPIFolders() As String) As MAPIFolder

Erstellt aus dem Array OutlookMAPIFolders() ein MAPIFolder Objekt. Dieses enthält den Pfad zum Ziel Ordner in Outlook

Teil 4 – GetOutlookMapiFolder(OutlookPath As String) As Variant

Wandelt den String Pfad zum Zielordner in ein Array um

''' Erstellt aus einem Outlook Ordner Array eine MAPIFolder Objekt
''' Teil 3
Private Function GetOutlookMapiObject(OutlookMAPIFolders() As String) As MAPIFolder
    Dim zaehler As Integer
    Dim retVal As MAPIFolder
    Dim mapFld As MAPIFolder
    
    zaehler = 0
    ''Set retVal = Application.Session.Folders()
    
    For Each strFolder In OutlookMAPIFolders
        If zaehler = 0 Then
            Set retVal = Application.Session.Folders(strFolder)
            zaehler = zaehler + 1
        Else
            Set retVal = retVal.Folders(strFolder)
        End If
    Next
    Set GetOutlookMapiObject = retVal
End Function

''' String mit Pfad zum Outlook Ordner in Array speichern
''' Teil 4
Private Function GetOutlookMapiFolder(OutlookPath As String) As Variant
    Dim retVal() As String
    
    If InStr(1, OutlookPath, "\\") Then
        strTemp = Mid(OutlookPath, 3)
        retVal = Split(strTemp, "\")
    End If
    
    GetOutlookMapiFolder = retVal
End Function

Das damit angelegte Makro kann nun in Outlook eingebunden werden.

Ich habe dazu im Ribbon eine neue Registerkarte angelegt.

Neue Registerkarte im Outlook Ribbon / Menüband anlegen

In Outlook Datei und dann Optionen öffnen. In den Outlook-Optionen auf Menüband anpassen klicken.

Neue Registerkarte anklicken. Dort Neue Gruppe öffnen.

Nun kann über Befehle auswählen – Makros ein Makros in die neue Registerkarte hinzugefügt werden.