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
Set objSelection = Application.ActiveExplorer.Selection
If objSelection.Count = 0 Then
MsgBox "Bitte wähle eine oder mehrere E-Mails aus.", vbExclamation
Exit Sub
End If
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
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objItem In objSelection
If TypeOf objItem Is MailItem Then
Set objMail = objItem
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, """", "")
strSubFolderPath = strFolderPath & "\" & strSubject
If Not objFSO.FolderExists(strSubFolderPath) Then
objFSO.CreateFolder strSubFolderPath
End If
If objMail.Attachments.Count > 0 Then
For i = 1 To objMail.Attachments.Count
Set objAttachment = objMail.Attachments(i)
strFileName = objAttachment.FileName
objAttachment.SaveAsFile strSubFolderPath & "\" & strFileName
Next i
End If
End If
Next objItem
MsgBox "Anhänge wurden erfolgreich gespeichert.", vbInformation
End Sub