Hallo Community,

in Outlook möchte ich über einen Button, Email Anhänge, in einem auswählbaren Ordner speichern. Außerdem soll dem Dateinamen das Datum der Email beigefügt werden.

Mit dem folgenden Code ist es mir bereits gelungen die Anhänge in einem zuvor definierten Speicherort abzulegen und den Dateinamen anzupassen.

Sub AnlageSpeichern()
Dim strPath As String
Dim objMail As MailItem
Dim intAnlagen As Integer, i As Integer
On Error Resume Next
'Pfad zu meinem Ordner
strPath = Environ("USERPROFILE") & "\Desktop\TEST\"
'Schleife
For Each objMail In Outlook.ActiveExplorer.Selection
With objMail
'Mails auf vorh. Anlagen prüfen
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
'Anlagen im vordefinierten Verzeichnis sichern
.Attachments.Item(i).SaveAsFile strPath & Format(.ReceivedTime, "DD.MM.YYYY_hh-mm_") & .Attachments.Item(i).FileName
Next i
End If
End With
Next objMail
End Sub

Mit dem folgenden Code habe ich probiert die Anhänge an einem auswählbaren Speicherort abzulegen.

Sub AnlageSpeichernAuswählen()
Dim strSavePath As String
Dim objMail As MailItem
Dim intAnlagen As Integer, i As Integer
On Error Resume Next
'Pfad zu meinem Ordner
strSavePath = BrowseForFolder
'Schleife
For Each objMail In Outlook.ActiveExplorer.Selection
With objMail
'Mails auf vorh. Anlagen prüfen
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
'Anlagen im vordefinierten Verzeichnis sichern
.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

Der Code funktioniert zunächst einmal, allerdings wird die Datei hierbei in den Vorordner von dem ausgewählten Ordner kopiert und an dem Dateinamen der Name des ausgewählten Ordners angefügt. Es ist vielleicht etwas schwer das nach zu vollziehen. Am besten ist es wahrscheinlich das ganze einfach mal auszuprobieren.Meine Frage besteht nun darin warum das ganze so ist wie es ist und wie ich das anpassen kann.

Über eine Antwort würde ich mich sehr freuen!

MfG Lukas