Sub AnlageSpeichernAuswählen()
Dim strSavePath As String
Dim objMail As MailItem
Dim intAnlagen As Integer, i As Integer
On Error Resume Next
strSavePath = BrowseForFolder
For Each objMail In Outlook.ActiveExplorer.Selection
With objMail
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
.Attachments.Item(i).SaveAsFile strSavePath & Format(.ReceivedTime, "DD.MM.YYYY_hh-mm_") & .Attachments.Item(i).FileName
Next i
End If
End With
Next objMail
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function