Email mit Betreff, Datum ... in Ordner speichern
27.05.2015 09:47:51
Ralf
ich möchte gerne meine E-Mails archivieren. Hierzu habe ich mir ein Makro aus dem Forum kopiert und in Outlook eingefügt. Funktioniert soweit. Nun möchte ich dieses Makro soweit erweitern bzw. ergänzen das ich die E-Mails mit Betreff, Absender, Datum... im Dateinamen abspeichern kann. Ich habe schon versucht aus anderen Makros hier weitere Teil zu ergänzen, leider bin ich in VBA bisher nur Anwender und habe leider noch kaum Erfahrung im selbst erstellen von Makros. Daher hatte ich mit dieser Methode wenig Erfolg. Kann mir jemand helfen und mir den Code soweit erweitern, das ich beim speichern den Betreff, Absender, Datum usw. auch gleich im Dateinamen mit drin habe?
Vielen Dank für eure Hilfe.
Gruß Ralf
Hier noch das Makro:
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", "")
.SaveAs Datei & "_" & Date & "_" & SenderName & ".msg"
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 & "\" & .Attachments.Item(i).FileName
Next i
End If
End If
.Delete
End With
Ende:
End Sub