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

Question

我目前正在编写在Microsoft 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

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

Answer 1

未测试：

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

Answer 2

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

电子邮件分为行

然后每一行都以冒号字符分割......＆＃34;：＆＃34;

（在进行拆分之前，冒号被添加到每一行的末尾，因此空白行不会产生错误）

然后采取行动，取决于每行的前几个字符

将此帖子末尾的代码放入excel工作簿

确保在运行时打开Outlook

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

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

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

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

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

在指令旁边的左侧灰色栏内单击将设置断点（并非所有说明都是＆＃39;断点能够＆＃39;）（再次单击以清除）

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

使用＆＃34;观看窗口＆＃34;仔细检查对象（变量）

打开观察窗口进入＆＃34;菜单栏＆＃34; ......＆＃34;查看＆＃34; ......＆＃34;观察窗口＆＃34;

将任何对象名称或变量名称拖到监视窗口中，或者右键单击它并选择＆＃34;添加监视＆＃34;

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

例如。拖动＆＃34; topOlFolder＆＃34;从第三个Dim声明（或程序中的任何其他地方）

使用＆＃34;立即窗口＆＃34;

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

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

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

例如，你可能在工作表＆＃34; Sheet5＆＃34;你需要删除＆＃34; Sheet2＆＃34;并继续工作＆＃34; Sheet5＆＃34;：

您将为以下操作录制宏：

＆＃34;单击Sheet2选项卡...选择所有单元格（ctrl-a）...按删除...单击Sheet5选项卡＆＃34;

生成以下宏

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

可以改写为：

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

这清除了名为＆＃34; Sheet2＆＃34;的工作表。没有＆＃34;选择＆＃34;它，因此它永远不会在屏幕上短暂闪烁

如果某些代码对不同的工作表进行了大量更新，并且每次更新都会在屏幕上闪烁一小段时间，那就太烦人了

这是你的代码

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