Hallo,

ich bräuchte bitte Hilfe, da ich wenig bis keine Ahnung von Outlook VBA habe.

In der Masse an Beiträgen im Netz habe ich kein für meine Zwecke funktionierendes VBA Skript für Outlook gefunden. Leider kann ich die vermutlich wenigen Anpassungen nicht selbst vornehmen.

Das Skript speichert die Anhänge von markierten E-Mails in einem ausgewählten Ordner. Für jede E-Mail wird ein Unterordner mit dem Betreff der E-Mail erstellt, in dem die Anhänge gespeichert werden.

Sub SaveAttachmentsFromSelectedEmails()
    Dim objSelection As Selection
    Dim objItem As Object
    Dim objMail As MailItem
    Dim objAttachment As Attachment
    Dim strFolderPath As String
    Dim strSubFolderPath As String
    Dim objFSO As Object
    Dim objSubFolder As Object
    Dim strFileName As String
    Dim strSubject As String
    Dim i As Integer

    ' Auswahl der markierten E-Mails
    Set objSelection = Application.ActiveExplorer.Selection
    
    ' Wenn keine E-Mail ausgewählt ist
    If objSelection.Count = 0 Then
        MsgBox "Bitte wähle eine oder mehrere E-Mails aus.", vbExclamation
        Exit Sub
    End If
    
    ' Benutzer wählt den Ordner, in den die Anhänge gespeichert werden
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Wähle den Ordner, in dem die Anhänge gespeichert werden sollen"
        If .Show <> -1 Then Exit Sub
        strFolderPath = .SelectedItems(1)
    End With
    
    ' FileSystemObject für die Ordnerverwaltung
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    ' Schleife durch alle ausgewählten E-Mails
    For Each objItem In objSelection
        ' Prüfen, ob es sich um eine E-Mail handelt
        If TypeOf objItem Is MailItem Then
            Set objMail = objItem
            
            ' Betreff der E-Mail als Unterordnername (nicht erlaubte Zeichen ersetzen)
            strSubject = objMail.Subject
            strSubject = Replace(strSubject, ":", "")
            strSubject = Replace(strSubject, "\", "")
            strSubject = Replace(strSubject, "/", "")
            strSubject = Replace(strSubject, "?", "")
            strSubject = Replace(strSubject, "*", "")
            strSubject = Replace(strSubject, "<", "")
            strSubject = Replace(strSubject, ">", "")
            strSubject = Replace(strSubject, "|", "")
            strSubject = Replace(strSubject, """", "")
            
            ' Pfad für den Unterordner
            strSubFolderPath = strFolderPath & "\" & strSubject
            
            ' Erstelle den Unterordner, falls er nicht existiert
            If Not objFSO.FolderExists(strSubFolderPath) Then
                objFSO.CreateFolder strSubFolderPath
            End If
            
            ' Speichern der Anhänge
            If objMail.Attachments.Count > 0 Then
                For i = 1 To objMail.Attachments.Count
                    Set objAttachment = objMail.Attachments(i)
                    
                    ' Dateiname des Anhangs
                    strFileName = objAttachment.FileName
                    
                    ' Speichern des Anhangs im Unterordner
                    objAttachment.SaveAsFile strSubFolderPath & "\" & strFileName
                Next i
            End If
        End If
    Next objItem
    
    MsgBox "Anhänge wurden erfolgreich gespeichert.", vbInformation
End Sub

Ich bekomme eine Fehlermeldung, dass die Dialogbox für die Ordnerauswahl nicht unterstützt wird.

Folgende Eigenschaften benötige ich:

1. Auswahl der markierten E-Mails: Das Skript greift auf die markierten E-Mails in Outlook zu.

2. Ordnerauswahl: Es wird ein Dateiauswahl-Dialog angezeigt, um den Zielordner zu wählen, in dem die Anhänge gespeichert werden.

3. Erstellung eines Unterordners für jede E-Mail: Ein Unterordner wird für jede E-Mail erstellt, wobei der Betreff der E-Mail als Name des Unterordners dient.

4. Speichern der Anhänge: Alle Anhänge der E-Mail werden im entsprechenden Unterordner gespeichert.

Vielen Dank vorab!!!