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

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

excel vba outlook

Excel 解析从电子邮件正文中最后找到的权限,excel,vba,outlook,Excel,Vba,Outlook,我有以下类型的电子邮件：我正在提取名称和城市，但我还想提取每个字段的问题：名称因为错误，城市因为无法读取到目前为止，我可以为每封电子邮件提取一个问题-第一次遇到 Sub Problems() Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim myInbox As Outlook.MAPIFolder Dim myitems As Outlook.it

我有以下类型的电子邮件：

我正在提取名称和城市，但我还想提取每个字段的问题：名称因为错误，城市因为无法读取

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

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

子问题（）
将MyOLAP设置为新的Outlook.Application
将myNameSpace设置为Outlook.NameSpace
将myInbox暗显为Outlook.Mapi文件夹
将myitems暗显为Outlook.items
将myitem设置为对象
Dim被发现为布尔值
设置myNameSpace=myOlApp.GetNamespace（“MAPI”）
设置myInbox=myNameSpace.GetDefaultFolder（olFolderInbox）
设置myitems=GetFolderPatharchive（“aaa\bbb”）.items
发现=错误
作为对象的Dim olkMsg_
作为对象的olkFld_
excApp作为对象_
excWkb作为对象_
以挖掘为对象_
intRow为整数_
intCnt作为整数_
数据\u电子邮件作为字符串_
strFilename作为字符串_
作为变异细胞_
varb作为变体，varD作为变体，varF作为变体
strFilename=“C:\OVERVIEW\EXTRACT EMAIL1”
如果strFilename vbNullString，则
设置excApp=CreateObject（“Excel.Application”）
Set excWkb=excApp.Workbooks.Add（）
设置excWks=excWkb.ActiveSheet
excApp.DisplayAlerts=False
用excWks
.单元格（1，1）=“发件人”
.单元格（1,2）=“受试者”
.单元格（1,3）=“城市”
.单元格（1,4）=“日期”
.单元格（1,5）=“小时”
.单元格（1,6）=“字段”
.单元格（1,7）=“问题”
以
intRow=2
对于myitems中的每个olkMsg
如果是olkMsg.Class olMail，则
其他的
arrcell=Split（GetCells（olkMsg.HTMLBody），Chr（255））
对于intCnt=LBound（arrcell）到UBound（arrcell）步骤1
关于错误转到处理程序
varb=arrCells（intCnt）
将线变暗为整数
行=仪表（olkMsg.Subject，“-”）
excWks.Cells（intRow，1）=olkMsg.SenderName
excWks.Cells（intRow，2）=左侧（olkMsg.Subject，第1行）
excWks.单元格（简介，3）=左侧（olkMsg.Subject，4）
excWks.Cells（intRow，4）=格式（olkMsg.ReceivedTime，“dd.mm.yyyy”）
excWks.Cells（intRow，5）=格式（olkMsg.ReceivedTime，“Hh:Nn:Ss”）
excWks.Cells（intRow，6）=varb
像绳子一样变暗
strAddr=ParseTextLinePair（olkMsg.Body，“错误”）
如果是strAddr vbNullString，则excWks.Cells（intRow，7）=“错误”
intRow=intRow+1
下一个intCnt
如果结束
标签1：
下一个olkMsg
设置olkMsg=Nothing
excWkb.SaveAs strFilename，52
excWkb.关闭
如果结束
设置olkFld=Nothing
设置excWks=无
Set excWkb=无
设置excApp=Nothing
MsgBox“TA DAM！已导出电子邮件”，vbInformation+vbOKOnly
呼叫opexlN
出口接头
处理程序：
恢复标签1
端接头
函数ParseTextLinePair_
（strSource作为字符串，strLabel作为字符串）
Dim intLocLabel为整数
Dim intLocCRLF为整数
Dim intLenLabel为整数
将strText设置为字符串
intLocLabel=InStr（strSource，strLabel）
intLenLabel=Len（strLabel）
如果intLocLabel>0，则
intLocCRLF=InStr（intLocLabel、strSource、vbCrLf）
如果intLocCRLF>0，则
intLocLabel=intLocLabel+intLenLabel
strText=Mid（strSource_
intLocLabel_
intLocCRLF-intLocLabel）
其他的
intLocLabel=_
Mid（strSource、intLocLabel+intLenLabel）
如果结束
如果结束
ParseTextLinePair=修剪（strText）
端函数
函数GetFolderPatharchive（ByVal FolderPath作为字符串）作为Outlook.Folder
文件夹作为Outlook.Folder的Dim
作为变体的Dim FoldersArray
作为整数的Dim i
错误转到GetFolderPatharchive\u错误
如果左（FolderPath，2）=“\\”则
FolderPath=Right（FolderPath，Len（FolderPath）-2）
如果结束
'将folderpath转换为数组
FoldersArray=Split（FolderPath，“\”）
文件夹集=Application.Session.Folders.Item（FoldersArray（0））
若并没有，那个么older什么都不是
对于i=1到UBound（FoldersArray，1）
将子文件夹暗显为Outlook.Folders
Set SubFolders=oFolder.Folders
文件夹集=子文件夹项（文件夹数组（i））
如果oFolder不算什么，那么
设置GetFolderPatharchive=Nothing
如果结束
下一个
如果结束
'返回文件夹
设置GetFolderPatharchive=oFolder
退出功能
GetFolderPatharchive\u错误：
设置GetFolderPatharchive=Nothing
退出功能
端函数
私有函数GetCells（strHTML作为字符串）作为字符串
常数READYSTATE_COMPLETE=4
Dim objIE作为对象，objDoc作为对象，colCells作为对象，objCell作为对象
Set objIE=CreateObject（“InternetExplorer.Application”）
objIE.导航“关于：空白”
直到objIE.ReadyState=ReadyState\u完成为止
多芬特
环
objIE.Document.body.innerHTML=strHTML
设置objDoc=objIE.Document
Set colCells=objDoc.getElementsByTagName（“td”）
如果colCells.Length>0，则
对于ColCell中的每个objCell
GetCells=GetCells&objCell.innerText&Chr（255）
下一个
GetCells=左（GetCells，Len（GetCells）-1）
其他的
GetCells=“”
如果结束
Set objCell=Nothing
设置colCells=Nothing
设置objDoc=Nothing
objIE，退出
设置对象=无
端函数

我会这样做：

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

我已经编辑了您的代码以正确地缩进它（它几乎不可读），还养成了在

Next

语句中指定变量的习惯（例如，

中的每个olkMsg

Next olkMsg

）。而我们将无法

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