Outlook: Emails mit Ordnerstruktur exportieren

Sub SaveSelectedMailsWithDate()
    Dim mail As MailItem, strNewSubject As String, strNewFilePath As String, objFolder As Object, OUTPUTPATH As String
    ' max Anzahl an zu übernehmenden Zeichen des Subjects    
    Const MAXSUBJECTCHARS = 30
    ' Filesystem Object erstellen    
    Set fso = CreateObject("Scripting.FileSystemObject")    
    Set objShell = CreateObject("Shell.Application")    
    ' Ausgabeordner mit FolderBrowserDialog abfragen    
    Set objFolder = objShell.BrowseForFolder(0, "Ausgabe-Ordner angeben", &H10)    
    ' prüfe auf gültigen Pfad    
    If fso.FolderExists(objFolder.Self.path) Then
       OUTPUTPATH = objFolder.Self.path
    Else
        MsgBox "Ungültiger Pfad!", vbExclamation    
        Exit Sub
    End If
    
    With ActiveExplorer
        ' wenn eine Auswahl besteht ...    
        If .Selection.Count > 0 Then
            ' verarbeite alle markierten Mails    
            For Each obj In .Selection
                If obj.Class = olMail Then
                    Set mail = obj
                    ' ersetze illegale Zeichen durch underscores    
                    strNewSubject = Trim(ReplaceIllegalChars(mail.SUBJECT))
                    ' wenn das Subject durch die Änderung leer istm benutze als Namen der Datei die eindeutige Outlook-EntryID    
                    If strNewSubject = "" Then    
                        strNewSubject = mail.EntryID
                    End If
                    ' kürze den Betreff wenn die definierte maximale Zeichenanzahl erreicht ist    
                    If Len(strNewSubject) > MAXSUBJECTCHARS Then
                        strNewSubject = Left(strNewSubject, MAXSUBJECTCHARS) & "..."    
                    End If
                    ' baue den neuen Pfad zusammen    
                    strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yymmdd") & "_" & strNewSubject & ".msg")    
                    ' sollte der Name bereits im Ausgabeordner existieren, hänge die Datum-Ticks als Randomizer an den Dateinamen an    
                    While fso.FileExists(strNewFilePath)
                        ticks = DateDiff("s", #1/1/1970#, Now())    
                        strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yymmdd") & "_" & strNewSubject & "_" & ticks & ".msg")    
                    Wend
                    ' speichere Mail als MSG(Unicode-Format)    
                    mail.SaveAs strNewFilePath, olMSGUnicode
                End If
            Next
        Else
            ' Keine Mail für den Export markiert    
            MsgBox "Bitte mindestens eine E-Mail für den Export markieren!", vbExclamation    
        End If
    End With
    MsgBox "Export abgeschlossen.", vbInformation    
End Sub

' Illegale Pfadzeichen ersetzen    
Function ReplaceIllegalChars(strText)
    Set regex = CreateObject("vbscript.regexp")    
    regex.Pattern = "[\\/:?<>|""*]"    
    regex.Global = True
    ReplaceIllegalChars = regex.Replace(strText, "_")    
    Set regex = Nothing
End Function

Public Sub CopyFolders()
  Dim Source As Outlook.Folder
  Dim Target As Outlook.Folder
  
  'Quellordner wählen  
  Set Source = Application.Session.PickFolder
  If Source Is Nothing Then Exit Sub
  
  'Zielordner wählen  
  Set Target = Application.Session.PickFolder
  If Target Is Nothing Then Exit Sub
  
  LoopFolders Source.Folders, Target.Folders, True
  MsgBox "fertig"  
End Sub

Private Sub LoopFolders(SourceFolders As Outlook.Folders, _
  TargetFolders As Outlook.Folders, _
  ByVal Recursive As Boolean _
)
  Dim Source As Outlook.MAPIFolder
  Dim Target As Outlook.MAPIFolder
  Dim FolderType As OlDefaultFolders
  
  For Each Source In SourceFolders
    Select Case Source.DefaultItemType
      Case olAppointmentItem
        FolderType = olFolderCalendar
      Case olContactItem, olDistributionListItem
        FolderType = olFolderContacts
      Case olJournalItem
        FolderType = olFolderJournal
      Case olNoteItem
        FolderType = olFolderNotes
      Case olTaskItem
        FolderType = olFolderTasks
      Case Else
        FolderType = olFolderInbox
    End Select
    Set Target = TargetFolders.Add(Source.Name, FolderType)

    If Recursive Then
      LoopFolders Source.Folders, Target.Folders, Recursive
    End If
  Next
End Sub