|
Hallo,
das folgende Makro in das Objekt "ThisOutlookSession" kopieren:
Option Explicit
Private Sub Application_NewMail()
Dim f As Folder
Dim m As MailItem
Dim o As Object
Set f = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each o In f.Items
If TypeName(o) = "MailItem" Then
Set m = o
If m.UnRead Then
m.SaveAs Environ("USERPROFILE") & "\Desktop\" & Left(ReplaceCharsForFileName(m.Subject, "_"), 50) & ".txt", olTXT
m.UnRead = False
End If
Set m = Nothing
End If
Next o
Set f = Nothing
End Sub
Private Function ReplaceCharsForFileName(sName As String, sChr As String) As String
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
ReplaceCharsForFileName = sName
End Function
Passe ggfs. noch den Speicherpfad an, aktuell werden alle Mails auf dem Deskop abgelegt.
Viele Grüße
|