Sub Anhang()
Dim FilePath As String
Dim OutlookApp As New Outlook.Application
Dim OutlookExpl As Outlook.Explorer
Dim OutlookSelect As Outlook.Selection
Dim Mail, Anhang As Object
FilePath = InputBox("Speicherort", "Anhänge Speichern unter: ", "C:\Anhaenge\")
On Error Resume Next
Set OutlookExpl = OutlookApp.ActiveExplorer
Set OutlookSelect = OutlookExpl.Selection
For Each Mail In OutlookSelect
Set Anhang = Mail.Attachments
If Anhang.Count <> 0 Then
For i = 1 To Anhang.Count
Anhang(i).SaveAsFile FilePath & Anhang(i).DisplayName
Next i
While Anhang.Count <> 0
Anhang.Remove 1
Wend
Mail.Save
End If
Next
Set Mail = Nothing
Set Anhang = Nothing
Set OutlookApp = Nothing
Set OutlookExpl = Nothing
Set OutlookSelect = Nothing
Resume
End Sub