AW: E-Mail Betreff auslesen und in einem Ordner ablege
19.01.2019 19:25:14
Sepp
Hallo Henrik,
probier mal.
Modul Modul1
Option Explicit
Sub saveMail()
Dim olApp As Object, objFolder As Object, objItem As Object
Dim strSubject As String, strFileName As String, strFullname As String
Const conSAVE_PATH As String = "F:/scanner/in" 'Speicherpfad -Anpassen!
Const conMAIL_PATTERN As String = "*###/##*"
On Error GoTo ErrorHandler
If IsFolder(conSAVE_PATH) Then
Set olApp = CreateObject("outlook.application")
Set objFolder = olApp.GetNameSpace("MAPI").GetDefaultFolder(6)
For Each objItem In objFolder.Items
strSubject = objItem.Subject
If InStr(1, strSubject, ":") Then strSubject = Split(strSubject, ":")(1)
If strSubject Like conMAIL_PATTERN Then
strFileName = Trim(validateFileName(strSubject, "_"))
If Len(strFileName) Then
strFullname = conSAVE_PATH & IIf(Right(conSAVE_PATH, 1) = "\", "", "\") & strFileName & ".msg"
If Not IsFile(strFullname) Then
objItem.SaveAs strFullname, 3
End If
End If
End If
Next
Else
MsgBox "Das Verzeichnis '" & conSAVE_PATH & "' existiert nicht!"
Err.Clear
End If
ErrorHandler:
If Err.Number <> 0 Then
MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "saveMail" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
Set objFolder = Nothing
Set olApp = Nothing
End Sub
Private Function validateFileName(ByVal FileName, Optional ByVal ReplaceChar As String = "") As String
Dim objRegExp As Object
On Error GoTo ErrorHandler
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
.IgnoreCase = True
.Global = True
validateFileName = .Replace(FileName, ReplaceChar)
End With
ErrorHandler:
Set objRegExp = Nothing
End Function
Private Function IsFolder(ByVal FolderName As String) As Boolean
On Error Resume Next
IsFolder = ((GetAttr(FolderName) And vbDirectory) = vbDirectory)
End Function
Private Function IsFile(ByVal FileName As String) As Boolean
On Error Resume Next
IsFile = ((GetAttr(FileName) And vbDirectory) <> vbDirectory)
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0