Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Dim WshShell As Object
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
Set WshShell = CreateObject("WScript.Shell")
If Not F Is Nothing Then
Select Case F.Title
Case "Desktop"
BrowseFolder = WshShell.SpecialFolders("Desktop")
Case "My Documents"
BrowseFolder = WshShell.SpecialFolders("MyDocuments")
Case "My Computer"
MsgBox "Invalid selection", vbCritical + vbOKOnly, "Error"
Exit Function
Case "My Network Places"
MsgBox "Invalid selection", vbCritical + vbOKOnly, "Error"
Exit Function
Case Else
BrowseFolder = F.Items.Item.Path
End Select
End If
Set SH = Nothing
Set F = Nothing
Set WshShell = Nothing
End Function
Sub SaveAttachment()
Set MyOlApplication = CreateObject("Outlook.Application")
Set MyOlNameSpace = MyOlApplication.GetNamespace("MAPI")
Set MyOlSelection = MyOlApplication.ActiveExplorer.Selection
If MyOlSelection.Count = 0 Then
Response = MsgBox("Markieren Sie zunächst eine E-Mail.", vbExclamation, MyApplName)
Exit Sub
End If
If MyOlSelection.Count > 1 Then
Response = MsgBox("Bitte wählen Sie NUR EINE E-Mail.", vbExclamation, MyApplName)
Exit Sub
End If
Set MySelectedItem = MyOlSelection.Item(1)
Dim colAttachments As Outlook.Attachments
Dim objAttachment As Outlook.Attachment
Set colAttachments = MySelectedItem.Attachments
Dim FolderPath As String
FolderPath = BrowseFolder("Wählen Sie bitte einen vorhandenen Ordner aus oder erstellen Sie einen neuen.")
If FolderPath = "" Then
Response = MsgBox("Die Auswahl eines Ordners ist erforderlich. Vorgang abgebrochen.", vbExclamation, MyApplName)
Exit Sub
End If
Dim DateStamp As String
Dim MyFile As String
For Each objAttachment In colAttachments
MyFile = objAttachment.FileName
DateStamp = Format(MySelectedItem.CreationTime, " - yyyymmdd_hhnnss")
intPos = InStrRev(MyFile, ".")
If intPos > 0 Then
MyFile = Left(MyFile, intPos - 1) & DateStamp & Mid(MyFile, intPos)
Else
MyFile = MyFile & "DateStamp"
End If
objAttachment.SaveAsFile (FolderPath & "\" & MyFile)
Next
Set objAttachment = Nothing
Set colAttachments = Nothing
Set MyOlApplication = Nothing
Set MyOlNameSpace = Nothing
Set MyOlSelection = Nothing
Set MySelectedItem = Nothing
End Sub