Outlook Mailexport mit Zeitstempel

Um Mails aus Outlook heraus zu exportieren, kann man diese schlicht per Drag’n’Drop in einen gewünschten Ordner ziehen. Dort werden diese dann als MSG-Dateien abgelegt und gut.

Aber wie bekommt man es hin, dass der Dateiname inkl. Zeitstempel erzeugt wird, um die zeitliche Mailreihenfolge nachvollziehen zu können?
Und was, wenn man nicht nur einzelne Mails, sondern einen ganzen Ordner rekursiv – also inkl. Unterordner – exportieren möchte?

Eine einfache Möglichkeit ist es, mit einem entsprechenden Makro zu arbeiten. Dazu einfach wie folgt vorgehen:

1. Im Outlook per ALT + F11 den VBA-Editor öffnen.
2. Den nachfolgenden VBA-Code als neues Modul dort einfügen.
3. Im Code noch den Speicherort der Variable SavePath anpassen bzw. dafür sorgen, dass der Zielordner existiert.
   ACHTUNG: Die Variable wird im Code 2x definiert!
4. Per ALT + F8 das gewünschte Makro ausführen:
   • ExportFolderAndSubfoldersToMSG
     Export eines gesamten Ordners.
     Diesen auswählen und mit OK bestätigen.
   • ExportSelectedMailsWithTimestamp
     Export der markierten Mails.
5. Das Makro exportiert nun alle Mails bzw. den gewählten Ordners inkl. Unterordner entsprechend in den Zielordner.

Sub ExportSelectedMailsWithTimestamp()
    Dim Selection As Outlook.Selection
    Dim Mail As Outlook.MailItem
    Dim SavePath As String
    Dim FileName As String
    Dim TimeStamp As String
    Dim i As Integer
    
    ' Zielpfad definieren – hier bitte anpassen
    SavePath = "C:\Users\BENUTZERNAME\Documents\ExportierteMails\"
    
    ' Sicherstellen, dass der Pfad existiert
    If Dir(SavePath, vbDirectory) = "" Then
        MsgBox "Speicherordner nicht gefunden: " & SavePath, vbCritical
        Exit Sub
    End If
    
    Set Selection = Application.ActiveExplorer.Selection

    If Selection.Count = 0 Then
        MsgBox "Keine E-Mails ausgewählt.", vbExclamation
        Exit Sub
    End If

    For i = 1 To Selection.Count
        If TypeOf Selection.Item(i) Is MailItem Then
            Set Mail = Selection.Item(i)
            
            ' Zeitstempel generieren (z. B. 2025-05-13_1430)
            TimeStamp = Format(Mail.ReceivedTime, "yyyymmdd-HHmm")
            
            ' Dateiname: Zeitstempel + Betreff, ungültige Zeichen entfernen
            FileName = TimeStamp & "_" & CleanFileName(Mail.Subject) & ".msg"
            
            ' Datei speichern
            Mail.SaveAs SavePath & FileName, olMSG
        End If
    Next i
    
    MsgBox Selection.Count & " E-Mails wurden exportiert nach: " & SavePath, vbInformation
End Sub

Sub ExportFolderAndSubfoldersToMSG()
    Dim OutlookNamespace As Outlook.NameSpace
    Dim RootFolder As Outlook.MAPIFolder
    Dim SavePath As String
    
    ' Zielpfad definieren – hier bitte anpassen
    SavePath = "C:\Users\BENUTZERNAME\Documents\ExportierteMails\"

    ' Root-Ordner festlegen (z. B. Posteingang)
    Set OutlookNamespace = Application.GetNamespace("MAPI")
    Set RootFolder = OutlookNamespace.PickFolder ' Benutzer wählt Ordner

    If RootFolder Is Nothing Then
        MsgBox "Kein Ordner ausgewählt.", vbExclamation
        Exit Sub
    End If

    ExportFolderRecursive RootFolder, SavePath
    MsgBox "Export abgeschlossen.", vbInformation
End Sub

Sub ExportFolderRecursive(Folder As Outlook.MAPIFolder, BasePath As String)
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim Mail As Outlook.MailItem
    Dim FileName As String
    Dim TimeStamp As String
    Dim FolderPath As String
    Dim i As Integer
    
    ' Pfad inkl. Ordnerstruktur aufbauen
    FolderPath = BasePath & GetFolderPathFromRoot(Folder)
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    ' Ordner anlegen (rekursiv)
    MkDirRecursive FolderPath
    
    ' Alle E-Mails im aktuellen Ordner exportieren
    For i = 1 To Folder.Items.Count
        Set Item = Folder.Items(i)
        If TypeOf Item Is MailItem Then
            Set Mail = Item
            TimeStamp = Format(Mail.ReceivedTime, "yyyy-mm-dd_HHmm")
            FileName = TimeStamp & "_" & CleanFileName(Mail.Subject) & ".msg"
            
            On Error Resume Next
            Mail.SaveAs FolderPath & FileName, olMSG
            On Error GoTo 0
        End If
    Next i

    ' Rekursiv alle Unterordner verarbeiten
    For Each SubFolder In Folder.Folders
        ExportFolderRecursive SubFolder, BasePath
    Next SubFolder
End Sub

Function GetFolderPathFromRoot(Folder As Outlook.MAPIFolder) As String
    Dim PathParts As Collection
    Dim Current As Outlook.MAPIFolder
    Set PathParts = New Collection
    
    Set Current = Folder
    Do While Not Current.Parent Is Nothing And TypeOf Current.Parent Is Outlook.MAPIFolder
        PathParts.Add CleanFileName(Current.Name)
        Set Current = Current.Parent
    Loop
    
    Dim i As Integer, PathStr As String
    For i = PathParts.Count To 1 Step -1
        PathStr = PathStr & PathParts(i) & "\"
    Next i
    GetFolderPathFromRoot = PathStr
End Function

Sub MkDirRecursive(ByVal Path As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Not FSO.FolderExists(Path) Then
        Dim Parts() As String
        Dim SubPath As String
        Dim i As Integer
        
        Parts = Split(Path, "\")
        SubPath = Parts(0)
        For i = 1 To UBound(Parts)
            SubPath = SubPath & "\" & Parts(i)
            If Not FSO.FolderExists(SubPath) Then
                FSO.CreateFolder SubPath
            End If
        Next i
    End If
End Sub

Function CleanFileName(FileName As String) As String
    ' Entfernt ungültige Zeichen für Dateinamen
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Pattern = "[\/:*?""<>|]"
        .Global = True
        CleanFileName = .Replace(FileName, "_")
    End With
End Function