Email mit Betreff ...in Ordner speichern
06.01.2021 20:07:19
flyingwordhero
ich möchte gerne meine E-Mails archivieren. Hierzu habe ich mir ein Makro aus dem Forum kopiert und in Outlook eingefügt bzw. für meine Zwecke angepasst. Funktioniert soweit. Nun möchte ich dieses Makro soweit ergänzen das nicht nur die letzte Email, welche ich markiert habe, im jeweiligen Ordner archiviert wird. Ich habe zwar eine "Schleife" im Makro, diese scheint aber nicht richtig zu funktionieren.
Kann mir jemand helfen und den Code soweit erweitern, das alle Emails, welche ich in meinem Postfach markiert habe im von mir vorgegebenen Ordner archiviert werden?
Vielen Dank für eure Hilfe.
Gruß flyingwordhero
Sub Emails_speichern()
Dim strPath As String
Dim strText As String
Dim objMail As MailItem
On Error Resume Next
'Pfad zu meinem Ordner
strPath = "D:\DSUsers\Username\Allgemeine Infos & Dokumente\Test"
'Schleife
For Each objMail In Outlook.ActiveExplorer.Selection
'Mails als gelesen markieren
If objMail.UnRead Then
objMail.UnRead = False
End If
'Mail abspeichern
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
'Sonderzeichen aus Betreff entfernen
With obj
strText = Replace(.Subject, "/", "_")
strText = Replace(strText, "!", "")
strText = Replace(strText, ".", "_")
strText = Replace(strText, "\", "_")
strText = Replace(strText, ":", "_")
strText = Replace(strText, "(", "")
strText = Replace(strText, ")", "")
strText = Replace(strText, """", "")
'Speicherpfad und Dateiformat vorgeben
.SaveAs strPath & "\" & Format(.ReceivedTime, "YYYY-MM-DD_hh-mm") & "_" & strText & ".msg", _
olMSG
End With
'Mails löschen
objMail.Delete
Next objMail
End Sub