Public Sub SaveAttachments()
Dim coll As VBA.Collection
Dim obj As Object
Dim Att As Outlook.Attachment
Dim Sel As Outlook.Selection
Dim Path$
Dim i&
Dim Dateiname As String
Path = "C:\Users\DB\.1 L1\PL\"
Set coll = New VBA.Collection
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
coll.Add Application.ActiveInspector.CurrentItem
Else
Set Sel = Application.ActiveExplorer.Selection
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
For Each obj In coll
For Each Att In obj.Attachments
Dateiname = InputBox("Bitte Dateinamen vergeben", "Anhang speichern als")
Att.SaveAsFile Path & Dateiname
Next
Next
End Sub