AW: E-Mail auslesen und abspeichern
23.08.2017 09:44:26
Tino
Hallo,
habe die mal was zusammengebastelt.
Den Pfad wo die Mails gespeichert werden im Code anpassen!
Hier wird nach dem Erhalten Datum gespeichert.
Hier im Beispiel Mails die max. 5 Tage zurückliegen (Date -5 bis Date)
Du wirst nach dem Outlook Ordner gefragt der ausgelesen werden soll.
Die Mails-Fils werden mit dem bereinigten Betreff + dem Empfangs-Datum gespeichert.
(sollte in dem Ordner bereits Mails liegen, wirst du gefragt ob diese gelöscht werden sollen)
kommt als Code in Modul1
Option Explicit
Sub MailsSaveAs()
Dim objOutlook As Object, objSpace As Object, objFolder As Object, objMsg As Object
Dim RegExp As Object
Dim SavePath$, sFileName$
Dim FilterDateVon As Date, FilterDateBis As Date
Dim nCounter&
Const conExtention$ = ".msg"
Const conItemTyp& = 3 'olMSG
'Pfad wo Mail gespeichert werden soll
SavePath = "C:\TEMP\tempMail"
'Filter für Datum
FilterDateVon = Date - 5
FilterDateBis = Date
Call CheckFolderMails(SavePath, conExtention)
Set objOutlook = CreateObject("Outlook.Application")
Set objSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objSpace.PickFolder
If objFolder Is Nothing Then Exit Sub
For Each objMsg In objFolder.Items
With objMsg
' .SenderEmailAddress 'Mail- Adresse
' .ReceivedTime 'Datum
' .Subject 'Betreff
Select Case .ReceivedTime 'Datum
Case FilterDateVon To FilterDateBis
sFileName = CleanFileName(.Subject, RegExp)
If sFileName = "" Then
sFileName = "ohne Betreff - " & Format(.ReceivedTime, "dd-mm-yy hh-MM-ss")
Else
sFileName = sFileName & " - " & Format(.ReceivedTime, "dd-mm-yy hh-MM-ss")
End If
.SaveAs SavePath & sFileName & conExtention, conItemTyp
nCounter = nCounter + 1
End Select
End With
Next objMsg
MsgBox "Es wurden '" & nCounter & "' Mails gespeichert!", vbInformation
End Sub
Function CleanFileName(ByVal strFileName As String, ByRef RegExp As Object) As String
If RegExp Is Nothing Then
Set RegExp = CreateObject("Vbscript.Regexp")
With RegExp
.IgnoreCase = True
.Pattern = "[<>?"":|\/*]"
.Global = True
End With
End If
strFileName = RegExp.Replace(strFileName, " ")
Do While InStr(strFileName, " ") > 0
strFileName = Replace(strFileName, " ", " ")
Loop
CleanFileName = Trim$(strFileName)
End Function
Sub CheckFolderMails(ByRef strPath$, ByVal sExt$)
Dim FSO As Object, oFolder As Object, oFile As Object
Dim booMsg As Boolean
strPath = strPath & IIf(Right$(strPath, 1) <> "\", "\", "")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strPath)
booMsg = True
For Each oFile In oFolder.Files
If oFile.Name Like "*" & sExt Then
If booMsg Then
If MsgBox("Ordner enthält bereits E-Mails!" & vbCr & _
"Diese jetzt löschen?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
booMsg = False
End If
oFile.Delete
End If
Next
End Sub
Gruß Tino