解析 Outlook 电子邮件并导出到 Excel [英] Parsing Outlook Emails and Exporting to Excel

问题描述

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

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

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

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

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

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 布局以及我当前代码发生的情况，除了标题之外什么都没有弹出！

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

这是我当前的代码:

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

推荐答案

这里有一些代码可以帮助您入门

here is some code that may get you started

电子邮件被分成几行

然后每一行在冒号字符处被分割......:"

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

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

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

运行时确保 Outlook 处于打开状态

make sure that outlook is open when you run it

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

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

一些你可能已经知道的提示:

some pointers that you may already know:

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

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

黄色高亮表示下一条指令将执行

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)

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

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

使用观察窗口"仔细检查对象(变量)

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

例如.从第三个 Dim 语句(或程序中的任何其他地方)拖拽topOlFolder"

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

利用立即窗口"

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

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

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

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

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

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

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

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

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

you would record a macro for following actions:

单击Sheet2选项卡...选择所有单元格(ctrl-a)...按删除...单击Sheet5选项卡"

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

产生以下宏

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

可以改写为:

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

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

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

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

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

这是你的代码

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

这篇关于解析 Outlook 电子邮件并导出到 Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！