解析Outlook电子邮件并导出到Excel

我目前正在Outlook中编写一个VBA脚本，它应该解析电子邮件中的关键信息，并将它们存储到Excel电子表格中

现在，我被困在解析和提取我想要的东西的逻辑上

下面是一个简短的电子邮件示例，其中的信息需要提取并保存到Excel中，并用黄色圈起来（X是大写或小写字母，#是数字）

这是Excel布局和我当前的代码发生了什么，除了标题外，没有任何东西弹出

这是我目前的代码：

Sub Extract()

 On Error Resume Next
    Dim messageArray(3) As String
    Set myOlApp = Outlook.Application
    Dim OlMail As Variant
    Set mynamespace = myOlApp.GetNamespace("mapi")
 
    'Open the current folder, I want to be able to name a specific folder if possible…
 
    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
    Set xlobj = CreateObject("excel.application.14")
    xlobj.Visible = True
    xlobj.Workbooks.Add
 
    'Set headings
    xlobj.Range("a" & 1).Value = "Priority"
    xlobj.Range("b" & 1).Value = "Summary"
    xlobj.Range("c" & 1).Value = "Description of Trouble"
    xlobj.Range("d" & 1).Value = "Device"
    'xlobj.Range("e" & 1).Value = "Sender"
 
   
    For i = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(i)
    msgtext = myitem.Body
 
    'Search for specific text
    delimtedMessage = Replace(msgtext, "Priority:", "###")
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###")
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###")
    delimtedMessage = Replace(delimtedMessage, "Device:", "###")
    messageArray(i) = Split(delimtedMessage, "###")
 
    'Write to Excel
    xlobj.Range("a" & i + 1).Value = messageArray(0)
    xlobj.Range("b" & i + 1).Value = messageArray(1)
    xlobj.Range("c" & i + 1).Value = messageArray(2)
    xlobj.Range("d" & i + 1).Value = messageArray(3)
    'xlobj.Range("e" & i + 1).Value = myitem.To
 
 Next
 
End Sub

未经测试：

Sub Extract()

    'On Error Resume Next '<< don't use this!
    Dim messageArray '<< use a variant here
    Set myOlApp = Outlook.Application
    Dim OlMail As Variant
    Set mynamespace = myOlApp.GetNamespace("mapi")

    'Open the current folder, I want to be able to name a specific folder if possible…

    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
    Set xlobj = CreateObject("excel.application.14")
    xlobj.Visible = True
    xlobj.Workbooks.Add

    'Set headings
    xlobj.Range("a" & 1).Value = "Priority"
    xlobj.Range("b" & 1).Value = "Summary"
    xlobj.Range("c" & 1).Value = "Description of Trouble"
    xlobj.Range("d" & 1).Value = "Device"
    'xlobj.Range("e" & 1).Value = "Sender"


    For i = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(i)
    msgtext = myitem.Body

    'Search for specific text
    delimtedMessage = Replace(msgtext, "Priority:", "###")
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###")
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###")
    delimtedMessage = Replace(delimtedMessage, "Device:", "###")
    messageArray = Split(delimtedMessage, "###")'<<edit

    'Write to Excel
    If ubound(messageArray) = 3 then
        xlobj.Range("a" & i + 1).Value = Trim(messageArray(0))
        xlobj.Range("b" & i + 1).Value = Trim(messageArray(1))
        xlobj.Range("c" & i + 1).Value = Trim(messageArray(2))
        xlobj.Range("d" & i + 1).Value = Trim(messageArray(3))
        'xlobj.Range("e" & i + 1).Value = myitem.To
    Else
        Msgbox "Message format? - " & myitem.Subject 
    End If

 Next

End Sub

Sub-Extract（）
“错误时继续下一步”以下是一些代码，可以帮助您开始

电子邮件分成几行

然后每行在冒号字符处拆分。。。“：”

（在进行拆分之前，将冒号添加到每行的末尾，以便空行不会产生错误）

然后根据每行的前几个字符执行操作


将本文末尾的代码放入excel工作簿

确保outlook在运行时处于打开状态

在outlook中启用vba（宏）不是一个好主意，因为收到的电子邮件中可能存在安全问题


您可能已经知道的一些指针：

通过将光标放在代码中的任意位置并重复按F8键，可以单步浏览代码

黄色突出显示指示下一步将执行的指令

将鼠标指针悬停在变量名称上将指示该变量的值（在任何断点处停止时）

在指令旁边的左侧灰色条内单击将设置断点（并非所有指令都是“可断点的”）（再次单击可清除）

按F5将使程序运行到下一个断点，如果没有断点，则运行到程序结束

使用“观察窗口”仔细检查对象（变量）

要打开观察窗口，请转到“菜单栏”。。。“视图”。。。“观察窗”

将任何对象名称或变量名称拖动到“监视”窗口中，或右键单击它并选择“添加监视”

然后，您可以在断点处停止时监视变量值

例如，从第三条Dim语句中拖动“topOlFolder”（或从程序中的任何其他位置拖动）

利用“即时窗口”

按ctrl-G键以打开“即时窗口”。。。
任何“Debug.print”命令都将打印到“即时窗口”。。。
这用于显示所需的任何调试信息，而无需在断点处停止


编写vba代码时，一个很好的起点是“录制宏”，然后进入vbe ide并编辑生成的宏代码以满足您的需要

录制的宏中的许多代码是不必要的，可以缩短

例如，您可能在工作表“Sheet5”上，您需要删除“Sheet2”中的所有内容并继续处理“Sheet5”：

您将录制以下操作的宏：

“单击“工作表2”选项卡…选择所有单元格（ctrl-a）…按delete键…单击“工作表5”选项卡”

生成以下宏

Sub Macro1()
    Sheets("Sheet2").Select
    Cells.Select
    Selection.ClearContents
    Sheets("Sheet5").Select
End Sub

它可以重写为：

Sub Macro1()
    Sheets("Sheet2").Cells.ClearContents
End Sub

这会清除名为“Sheet2”的工作表，而无需“选择”它，因此它不会在屏幕上短暂闪烁

如果一些代码对不同的工作表进行了大量更新，并且每次更新都会在屏幕上闪烁一小会儿，这可能会很烦人


这是你的密码

Sub Extract()

'   On Error Resume Next                ' do not use .... masks errors

    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim topOlFolder As Outlook.MAPIFolder
    Dim myOlFolder As Outlook.Folder
    Dim myOlMailItem As Outlook.mailItem

    Set myOlApp = Outlook.Application                                     ' roll these two into one command line
    Set myNameSpace = myOlApp.GetNamespace("MAPI")                        ' as noted on next line

'   Set myNameSpace = Outlook.Application.GetNamespace("mapi")            ' can do this instead (then no need to do "dim myOlApp" above)

    Set topOlFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Parent  ' top folder ... contains all other folders


'   Set myOlFolder = myNameSpace.Folders(2).Folders("Test")               ' this one is unreliable ... Folders(2) seems to change
    Set myOlFolder = topOlFolder.Folders("Test")                          ' this one seems to always work

'   Set myOlFolder = topOlFolder.Folders(myNameSpace.PickFolder.Name)     ' pick folder name in a dialog

'   Debug.Print myOlFolder.Items.Count

'   For Each myOlMailItem In myOlFolder.Items                             ' print subject lines for all emails in "Test" folder
'       Debug.Print myOlMailItem.Subject
'   Next

    Dim xlObj As Worksheet
    Set xlObj = Sheets("Sheet1")                     ' refer to a specific worksheet
'   Set xlObj = ActiveSheet                          ' whichever worksheet is being worked on

    Dim anchor As Range
    Set anchor = xlObj.Range("b2")                   ' this is where the resulting table is placed ... can be anywhere
'   Set anchor = Sheets("Sheet1").Range("b2")        ' "xlObj" object does not have to be created if you use this form

    ' Set headings
    '      Offset(row,col)
    anchor.Offset(0, 0).Value = "Priority"          ' technically the line should be "anchor.Value = ...", but it lines up this way
    anchor.Offset(0, 1).Value = "Summary"           ' used "offset". that way all the cells are relative to "anchor"
    anchor.Offset(0, 2).Value = "Description of Trouble"
    anchor.Offset(0, 3).Value = "Device"
    anchor.Offset(0, 4).Value = "Sender"


    Dim msgText As String
    Dim msgLine() As String
    Dim messageArray() As String

    i = 0                                            ' adjust excel starting row here, if desired
    For Each myOlMailItem In myOlFolder.Items
        i = i + 1                                    ' first parsed message ends up on worksheet one row below headings

'       msgText = testText                           ' use test message that is defined above
        msgText = myOlMailItem.Body                  ' or use actual email body

        messageArray = Split(msgText, vbCrLf)        ' split into lines

        For j = 0 To UBound(messageArray)
'           Debug.Print messageArray(j)

            msgLine = Split(messageArray(j) & ":", ":")  ' split up line ( add ':' so that blank lines do not error out)

            Select Case Left(msgLine(0), 6)              ' check only first six characters

                Case "Priori"
                    anchor.Offset(i, 0).Value = msgLine(1)             ' text after "Priority:"

                Case "Summar"
                    anchor.Offset(i, 1).Value = messageArray(j + 1)    ' text on next line

                Case "Descri"
                    anchor.Offset(i, 2).Value = messageArray(j + 1)    ' text on next line

                Case "Device"
                    anchor.Offset(i, 3).Value = msgLine(1)             ' text after "Device:"

            End Select
            anchor.Offset(i, 4).Value = myOlMailItem.SenderName
            anchor.Offset(i, -1).Value = i                             ' add row number on left of "Priority" column (make sure that "anchor" is not in first worksheet column)

        Next
    Next
End Sub

你试过调试吗？在循环中设置一个中断，检查
delimtedMessage
的值，看看它是否符合您的期望……然后开始注释您的“错误恢复下一步”为我提供了我想要从中提取信息的每封电子邮件的“消息格式？”错误try:
if ubound（messageArray）>=3然后
如果这不起作用，则需要进行一些调试。