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

Parsing Outlook Emails and Exporting to Excel VBA

提问by jezhuz

I'm currently writing a VBA macros script run in Microsoft Outlook which should parse key information from emails and store them into an Excel spreadsheet.

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

Right now, I am stuck on the logic of parsing and extracting what I want.

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

Here is a short example of an email with the info that needs to be extracted and saved into Excel circled in yellow (Xs being capital or lowercase letters and # being numbers)

这是一封电子邮件的简短示例，其中包含需要提取并保存到 Excel 中的黄色圆圈信息（X 是大写或小写字母，# 是数字）

Here is the Excel layout and what is happening with my current code, nothing is popping up except the headers!

这是 Excel 布局以及我当前代码发生的情况，除了标题之外什么都没有弹出！

Here is my current code:

这是我当前的代码：

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

This is my first time ever coding in VB so any help/suggestions would be great!

这是我第一次用 VB 编码，所以任何帮助/建议都会很棒！

回答by Tim Williams

Untested:

未经测试：

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

回答by jsotola

here is some code that may get you started

这是一些可以帮助您入门的代码

the email message is split into lines

电子邮件被分成几行

then each line is split at the colon character ... ":"

然后每一行都在冒号字符处分割......“：”

(the colon is added to end of every line before doing the split, so that blank lines do not produce an error)

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

then actions are taken, depending on the first few characters of each line

然后根据每行的前几个字符采取行动

---

---

put the code at the end of this post into an excel workbook

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

make sure that outlook is open when you run it

运行时确保 Outlook 已打开

it is not a good idea to enable vba (macros) in outlook because of security issues that may be present inside the received emails

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

---

---

some pointers that you may already know:

您可能已经知道的一些提示：

you can single-step through the code by placing the cursor anywhere within the code and pressing F8 repeatably

您可以通过将光标放在代码中的任意位置并重复按 F8 来单步执行代码

the yellow highlight indicates which instruction will execute next

黄色高亮表示接下来将执行哪条指令

hovering mouse pointer over a variable name will indicate the value of that variable (when stopped at any breakpoint)

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

clicking inside the left side grey bar next to an instruction will set a breakpoint (not all instructions are 'breakpoint-able')(click again to clear)

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

pressing F5 will run the program up to the next breakpoint or to end of program if there is no breakpoint

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

use "watch window" to closely examine objects (variables)

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

to bring up watch window go to "menu bar" ... "view" ... "watch window"

调出监视窗口 转到“菜单栏”...“视图”...“监视窗口”

drag any object name or variable name into the watch window, or right click on it and choose"add watch"

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

then you can monitor the variable value while stopped at a breakpoint

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

eg. drag "topOlFolder" from the third Dim statement (or from anywhere else in program)

例如。从第三个 Dim 语句（或从程序中的任何其他地方）拖动“topOlFolder”

make use of "immediate window"

利用“即时窗口”

press ctrl-G to bring up the "immediate window" ... any "Debug.print" command will print to the "immediate window" ... this is used for displaying any debugging info that you need without having to stop at a breakpoint

按 ctrl-G 调出“立即窗口”……任何“Debug.print”命令都将打印到“立即窗口”……这用于显示您需要的任何调试信息，而不必停在断点

---

---

a good starting point when writing vba code, is to "record macro", then go into vbe ide and edit the resulting macro code to fit your needs

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

lot of the code in a recorded macro is unnecessary and can be shortenned

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

for instance, you may be on worksheet "Sheet5" and you need to delete everything from "Sheet2" and continue working on "Sheet5":

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

you would record a macro for following actions:

您将为以下操作录制一个宏：

"click Sheet2 tab ... select all cells(ctrl-a) ... press delete ... click Sheet5 tab"

“单击 Sheet2 选项卡...选择所有单元格（ctrl-a）...按删除 ...单击 Sheet5 选项卡”

produces the following macro

产生以下宏

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

it can be rewritten as:

可以改写为：

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

this clears worksheet named "Sheet2" without "selecting" it, therefore it never flashes briefly on the screen

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

it can be annoying if some code does a lot of updates to different worksheets and each update flashes up on the screen for a brief moment

如果某些代码对不同的工作表进行大量更新并且每个更新在屏幕上闪烁片刻，这可能会很烦人

---

---

here is your code

这是你的代码

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