解析从电子邮件正文中找到的最后一个权限

Question

我收到了以下类型的电子邮件：

我正在提取NAME和CITY但我想提取每个字段的问题：NAME因为错误和城市因为它无法读取

到目前为止，我可以为每封电子邮件提取一个问题 - 第一次遇到。

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

Answer 1

我会这样做：

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

你的功能不对，如果你没有找到vbCrLf你在整数intLocLabel中放入一个字符串会导致类型不匹配错误！
我不确定当你找不到换行符时你想做什么，因为在这种情况下你的Mid()只在你要找的文本后面返回1个字符！
我把它设置为返回一个空字符串！ ;）

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