parsing电子邮件正文最后find的权利
我有以下types的电子邮件：
我正在提取名称和城市，但我也想提取每个领域的问题：名称因为是错误和城市因为它不能被读取
到现在为止，我可以提取每个电子邮件的总体问题 – 第一次遭遇。
Sub Problems() Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim myInbox As Outlook.MAPIFolder Dim myitems As Outlook.items Dim myitem As Object Dim Found As Boolean Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myitems = GetFolderPatharchive("aaa\bbb").items Found = False Dim olkMsg As Object, _ olkFld As Object, _ excApp As Object, _ excWkb As Object, _ excWks As Object, _ intRow As Integer, _ intCnt As Integer, _ data_email As String, _ strFilename As String, _ arrCells As Variant, _ varb As Variant, varD As Variant, varF As Variant strFilename = "C:\OVERVIEW\EXTRACT EMAIL1" If strFilename <> vbNullString Then Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add() Set excWks = excWkb.ActiveSheet excApp.DisplayAlerts = False With excWks .Cells(1, 1) = "SENDER" .Cells(1, 2) = "SUBJECT" .Cells(1, 3) = "CITY" .Cells(1, 4) = "DATE" .Cells(1, 5) = "HOUR" .Cells(1, 6) = "FIELD" .Cells(1, 7) = "PROBLEM" End With intRow = 2 For Each olkMsg In myitems If olkMsg.Class <> olMail Then Else arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255)) For intCnt = LBound(arrCells) To UBound(arrCells) Step 1 On Error GoTo Handler varb = arrCells(intCnt) Dim line As Integer line = InStr(olkMsg.Subject, "-") excWks.Cells(intRow, 1) = olkMsg.SenderName excWks.Cells(intRow, 2) = Left(olkMsg.Subject, line - 1) excWks.Cells(intRow, 3) = Left(olkMsg.Subject, 4) excWks.Cells(intRow, 4) = Format(olkMsg.ReceivedTime, "dd.mm.yyyy") excWks.Cells(intRow, 5) = Format(olkMsg.ReceivedTime, "Hh:Nn:Ss") excWks.Cells(intRow, 6) = varb Dim strAddr As String strAddr = ParseTextLinePair(olkMsg.Body, "WRONG") If strAddr <> vbNullString Then excWks.Cells(intRow, 7) = "WRONG" intRow = intRow + 1 Next intCnt End If Label1: Next olkMsg Set olkMsg = Nothing excWkb.SaveAs strFilename, 52 excWkb.Close End If Set olkFld = Nothing Set excWks = Nothing Set excWkb = Nothing Set excApp = Nothing MsgBox "TA DAM! EMAILS EXPORTED", vbInformation + vbOKOnly Call opexlN Exit Sub Handler: Resume Label1 End Sub Function ParseTextLinePair _ (strSource As String, strLabel As String) Dim intLocLabel As Integer Dim intLocCRLF As Integer Dim intLenLabel As Integer Dim strText As String intLocLabel = InStr(strSource, strLabel) intLenLabel = Len(strLabel) If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, strSource, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel strText = Mid(strSource, _ intLocLabel, _ intLocCRLF - intLocLabel) Else intLocLabel = _ Mid(strSource, intLocLabel + intLenLabel) End If End If ParseTextLinePair = Trim(strText) End Function Function GetFolderPatharchive(ByVal FolderPath As String) As Outlook.Folder Dim oFolder As Outlook.Folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPatharchive_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPatharchive = Nothing End If Next End If 'Return the oFolder Set GetFolderPatharchive = oFolder Exit Function GetFolderPatharchive_Error: Set GetFolderPatharchive = Nothing Exit Function End Function Private Function GetCells(strHTML As String) As String Const READYSTATE_COMPLETE = 4 Dim objIE As Object, objDoc As Object, colCells As Object, objCell As Object Set objIE = CreateObject("InternetExplorer.Application") objIE.Navigate "about:blank" Do Until objIE.ReadyState = READYSTATE_COMPLETE DoEvents Loop objIE.Document.body.innerHTML = strHTML Set objDoc = objIE.Document Set colCells = objDoc.getElementsByTagName("td") If colCells.Length > 0 Then For Each objCell In colCells GetCells = GetCells & objCell.innerText & Chr(255) Next GetCells = Left(GetCells, Len(GetCells) - 1) Else GetCells = "" End If Set objCell = Nothing Set colCells = Nothing Set objDoc = Nothing objIE.Quit Set objIE = Nothing End Function 我会这样做：
Sub Problems() Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim myInbox As Outlook.MAPIFolder Dim myitems As Outlook.items Dim myitem As Object Dim Found As Boolean Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myitems = GetFolderPatharchive("aaa\bbb").items Found = False Dim olkMsg As Object, _ olkFld As Object, _ excApp As Object, _ excWkb As Object, _ excWks As Object, _ intRow As Integer, _ intCnt As Integer, _ data_email As String, _ strFilename As String, _ arrCells As Variant, _ varB As Variant, varD As Variant, varF As Variant strFilename = "C:\OVERVIEW\EXTRACT EMAIL1" If strFilename <> vbNullString Then Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add() Set excWks = excWkb.ActiveSheet excApp.DisplayAlerts = False With excWks .Cells(1, 1) = "SENDER" .Cells(1, 2) = "SUBJECT" .Cells(1, 3) = "CITY" .Cells(1, 4) = "DATE" .Cells(1, 5) = "HOUR" .Cells(1, 6) = "FIELD" .Cells(1, 7) = "PROBLEM" End With 'excWks intRow = 2 For Each olkMsg In myitems If olkMsg.Class <> olMail Then Else arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255)) For intCnt = LBound(arrCells) To UBound(arrCells) Step 1 On Error GoTo Handler varB = arrCells(intCnt) Dim LgLocCell As Long LgLocCell = InStr(1, olkMsg.Body, varB) Dim LgLocReason As Long LgLocReason = InStr(LgLocCell + Len(varB), olkMsg.Body, "because", vbTextCompare) + 6 Dim line As Integer line = InStr(olkMsg.Subject, "-") With excWks .Cells(intRow, 1) = olkMsg.SenderName .Cells(intRow, 2) = Left(olkMsg.Subject, line - 1) .Cells(intRow, 3) = Left(olkMsg.Subject, 4) .Cells(intRow, 4) = Format(olkMsg.ReceivedTime, "dd.mm.yyyy") .Cells(intRow, 5) = Format(olkMsg.ReceivedTime, "Hh:Nn:Ss") .Cells(intRow, 6) = varB .Cells(intRow, 7) = Trim(Mid(olkMsg.Body, LgLocReason, InStr(LgLocReason + 1, olkMsg.Body, ".") - LgLocReason)) End With 'excWks intRow = intRow + 1 Next intCnt End If Label1: Next olkMsg Set olkMsg = Nothing excWkb.SaveAs strFilename, 52 excWkb.Close End If Set olkFld = Nothing Set excWks = Nothing Set excWkb = Nothing Set excApp = Nothing MsgBox "TA DAM! EMAILS EXPORTED", vbInformation + vbOKOnly Call opexlN Exit Sub Handler: Resume Label1 End Sub
你的函数是不正确的，如果你没有findvbCrLf你把一个string整数intLocLabel这将导致types不匹配错误！
我不确定你想要做什么，当你没有find线返回，因为你的Mid()在这种情况下只返回1个字符后，你正在寻找！
我把它设置为返回一个空string！ ;）
Function ParseTextLinePair _ (strSource As String, strLabel As String) Dim intLocLabel As Integer Dim intLocCRLF As Integer Dim intLenLabel As Integer Dim strText As String intLocLabel = InStr(strSource, strLabel) intLenLabel = Len(strLabel) If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, strSource, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel strText = Mid(strSource, _ intLocLabel, _ intLocCRLF - intLocLabel) Else 'strText = _ Mid(strSource, intLocLabel + intLenLabel) strText = vbNullString End If End If ParseTextLinePair = Trim(strText) End Function