Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1456to1460
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Anhang aus E-Mails in Ordner speichern
05.11.2015 09:28:21
Ralf
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, "ä", "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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Anhang aus E-Mails in Ordner speichern
08.11.2015 19:19:02
Michael
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

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

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige