Email Text in Excel einlesen
03.08.2016 13:30:59
Gonzer
ich möchte aus einem bestimmten Ordner den Inhalt von Emails nach Schlagworten durchsuchen und die Werte hierzu in Excel auslesen.
Ich habe hierzu auch einen Code gefunden der nahezu pefekt klappt - jedoch gibt einige "Felder" die über mehrere Zeilen gehen, also nicht nur der Text direkt dahinter übernommen werden soll, sondern auch der Text der nächsten 3 Zeilen. Hat hierzu jemand eine Lösung?
Und gibt es im Code unten eine elegantere Lösung um als Pattern = und : auszuwählen ohne die Schleife doppelt laufen zu lassen?
Sub ReadOutlookMails()
Dim olApp As Object ' das Outlook-Objekt
Dim objFolder As Object ' der Standard-Posteingangsordner
Dim objItem As Object ' ein Objekt in objFolder
Dim i As Long ' Zeilennummer
Dim objRe As Object ' ein Regular-Expression Objekt
Dim objRe2 As Object ' ein Regular-Expression Objekt
Dim objMc As Object ' eine MatchCollection, das Ergebnis von objRe.Execute
Dim objMatch As Object ' ein Match, d.h. ein Eintrag der Form "irgendwas:sonstwas"
Dim objDic As Object ' ein Dictionary-Objekt, Key sind die möglichen Werte vor dem _
Doppelpunkt, Item ist die Spaltenummer wo das hinsoll
Dim varKey As Variant ' ein Key im Dictionary
Dim strKey As String ' dito
Set objDic = CreateObject("scripting.dictionary")
i = 1
Cells(1, 1).Value = "Betreff"
For Each varKey In Array("Feld1", "Feld2", "Feld3", "Feld4", "Feld5")
i = i + 1
objDic(varKey) = i
Cells(1, i).Value = varKey
Next
Rows(1).Font.Bold = True
Set objRe = CreateObject("vbscript.regexp")
objRe.Global = True
objRe.MultiLine = True
objRe.Pattern = "^(.*?)=[ \t]*(.*?)[\r\n]?$"
Set objRe2 = CreateObject("vbscript.regexp")
objRe2.Global = True
objRe2.MultiLine = True
objRe2.Pattern = "^(.*?):[ \t]*(.*?)[\r\n]?$"
Set olApp = CreateObject("outlook.application")
Set objFolder = olApp.GetNamespace("MAPI").pickfolder ' Ordnerauswahl
i = 1
For Each objItem In objFolder.Items
If TypeName(objItem) = "MailItem" Then
Set objMc = objRe.Execute(objItem.Body)
If objMc.Count > 0 Then
Cells(i + 1, 1).Value = objItem.Subject
i = i + 1
For Each objMatch In objMc
strKey = objMatch.Submatches(0)
If objDic.Exists(strKey) Then Cells(i, objDic(strKey)) = objMatch.Submatches(1)
Next
End If
End If
Next
i = 1
For Each objItem In objFolder.Items
If TypeName(objItem) = "MailItem" Then
Set objMc = objRe2.Execute(objItem.Body)
If objMc.Count > 0 Then
Cells(i + 1, 1).Value = objItem.Subject
i = i + 1
For Each objMatch In objMc
strKey = objMatch.Submatches(0)
If objDic.Exists(strKey) Then Cells(i, objDic(strKey)) = objMatch.Submatches(1)
Next
End If
End If
Next
objDic.RemoveAll
Set objDic = Nothing
Set objMc = Nothing
Set objRe = Nothing
Set objFolder = Nothing
Set olApp = Nothing
End Sub
Vielen Dank vorab!