Anhang aus E-Mails in Ordner speichern

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Anhang aus E-Mails in Ordner speichern
von: Ralf
Geschrieben am: 05.11.2015 09:28:21

Hallo,
ich habe ein Modul in Outlook, welches die E-Mails in einem Ordner speichert den ich frei auswählen kann. Ich kann mit diesem Makro auch die Anhänge speichern, jedoch werden diese immer in den selben Pfad gespeichert den ich ganz zu Anfang angegeben habe. Ich würde jedoch gerne die Anhänge unter dem selben Ordner wie die Mails abspeichern was aber nicht funktioniert.
Hier mal der Code:


Sub EmailSpeichernUnter()
On Error GoTo Ende
Dim obj As Object
Dim objNewMail As MailItem
Dim F As Outlook.MAPIFolder
Dim olInspector As Inspector
Dim objInspector As Inspector
Dim Datei As String
Dim intAnlagen As String
Dim SaveInPath As String
Dim oMailSendFromAccount As String
Dim strNewFolder As String
Dim objSubject As String
Dim SpeichernAls As OPENFILENAME
Dim ExistiertDatei
Dim i As Integer
If GetSetting("RMH_Installationen", "Outlook", "SaveInPath") = "" Then
SaveInPath = InputBox("Sie haben noch keinen Standardpfad definiert." & vbCrLf & _
"Bitte geben Sie jetzt den Pfad an, in welchem" & vbCrLf & _
"die Dateien standardmäßig gespeichert werden sollen!")
SaveSetting "RMH_Installationen", "Outlook", "SaveInPath", SaveInPath
End If
SaveInPath = GetSetting("RMH_Installationen", "Outlook", "SaveInPath")
If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
Set obj = Application.ActiveWindow
Set obj = obj.Selection(1)
Else
Set objInspector = ActiveInspector
objInspector.Activate
If objInspector.IsWordMail Then
Set obj = Application.ActiveInspector.CurrentItem
End If
End If
With SpeichernAls
.lStructSize = Len(SpeichernAls)
.hWndOwner = FindWindow("XLMAIN", "Outlook")
.hInstance = GetModuleHandle("Outlook.EXE")
.lpstrFilter = "Email-Dateien (*.msg)" & vbNullChar & "*.msg" & vbNullChar & vbNullChar
.lpstrCustomFilter = vbNullString
.nFilterIndex = 1
.lpstrFile = Space(255) & vbNullChar
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = SaveInPath
.lpstrTitle = "Email speichern"
.flags = OFN_EXTENSIONDIFFERENT
End With
    
If GetSaveFileName(SpeichernAls) = 0 Then Exit Sub
Datei = SpeichernAls.lpstrFile
Datei = Left(Datei, InStr(1, Datei, vbNullChar) - 1)
If Right(Datei, 3) <> ".msg" Then Datei = Datei & ".msg"
On Error Resume Next
ExistiertDatei = Not CBool(GetAttr(Datei) And (vbVolume))
On Error GoTo 0
If Datei = "Falsch" Then Exit Sub
If ExistiertDatei Then
    If MsgBox("Diese Datei existiert schon!" & vbCrLf & _
    "Möchten Sie sie überschreiben?", vbYesNo, "Datei existiert schon!") = vbNo Then
        MsgBox "Datei wurde nicht exportiert", vbInformation, "Abgebrochen"
        Exit Sub
    End If
End If
With obj
Datei = Replace(Datei, ".msg", "")
Dim strTxtSZ As String
Dim Sender As String
Dim Empfaenger As String
 With obj
      strTxtSZ = .Subject
      Sender = .SenderName
      Empfaenger = .To
      datum = Format(Date, "mm_dd_yy")
            
            strTxtSZ = Replace(strTxtSZ, "AW: ", "")
            strTxtSZ = Replace(strTxtSZ, "FW: ", "")
            strTxtSZ = Replace(strTxtSZ, "WG: ", "")
            strTxtSZ = Replace(strTxtSZ, ":", "_")
            strTxtSZ = Replace(strTxtSZ, Chr$(34), "_")
            strTxtSZ = Replace(strTxtSZ, "<", "_")
            strTxtSZ = Replace(strTxtSZ, ">", "_")
            strTxtSZ = Replace(strTxtSZ, "?", "_")
            strTxtSZ = Replace(strTxtSZ, "/", "_")
            strTxtSZ = Replace(strTxtSZ, "\", "_")
            strTxtSZ = Replace(strTxtSZ, "*", "_")
            strTxtSZ = Replace(strTxtSZ, ".", ". ")
            strTxtSZ = Replace(strTxtSZ, "ä", "ae")
            strTxtSZ = Replace(strTxtSZ, "ü", "ue")
            strTxtSZ = Replace(strTxtSZ, "ö", "oe")
             
             ' zwischen den "" wird das Sonderzeichen angegben, welches die anderen  _
Sonderzeichen ersetzt
       
         .SaveAs Format(Date, "mm_dd_yy") & "__" & Sender & "__" & strTxtSZ & "__" & Empfaenger  _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
 _
& ".msg", olMSG
        '.SaveAs Format(Date, "mm_dd_yy") & "__" & Sender & "__" & strTxtSZ & "__" & . _
ReceivedByName & ".msg", olMSG
 
 End With
If MsgBox("Möchten Sie die Anhänge speichern?", vbYesNo + vbQuestion, "Frage") = vbYes Then
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
.Attachments.Item(i).SaveAsFile SaveInPath & "\" & datum & "__" & strTxtSZ & "__" & . _
Attachments.Item(i).FileName
Next i
End If
End If
End With
Ende:
End Sub

Bei der Erstellung des Moduls hat mir das Forum hier übrigens sehr gut geholfen. Daher wende ich mich jetzt nochmal an euch. Vielleicht kann mir nochmal jemand helfen.
Danke. Gruß Ralf

Bild

Betrifft: AW: Anhang aus E-Mails in Ordner speichern
von: Michael
Geschrieben am: 08.11.2015 19:19:02
Hi Ralf,
ich verwende kein OL, also bearbeite ich Deine Frage nicht weiter.
Allerdings solltest Du die Zeile

If Right(Datei, 3) <> ".msg" Then Datei = Datei & ".msg"

überprüfen: die Bedingung wird IMMER false sein, weil Right(Datei,3) *3* Zeichen zurückgibt und ".msg" *4* Zeichen enthält.
Schöne Grüße,
Michael

Bild

Betrifft: AW: Anhang aus E-Mails in Ordner speichern
von: Ralf
Geschrieben am: 11.11.2015 09:19:48
Hallo Michael,
danke für deinen Hinweis. Werde mal weiterfragen. Vielleicht findet sich noch eine Lösung.
Viele Grüße,
Ralf

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Anhang aus E-Mails in Ordner speichern"