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

Question

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

现在，我陷入了解析和提取我想要的逻辑。

下面是需要被提取并保存到Excel中的黄色圆圈的信息电子邮件的一个简单的例子（XS是大写或小写字母和＃为数字）

这里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

这里是一些代码，可能让你开始

的电子邮件消息被分成行

则每行以冒号分割...“：”

（结肠被添加到每一行的结束操作的方式分裂之前，使空行不产生错误）

然后采取动作，根据各行的前几个字符

---

把代码在这篇文章的末尾到Excel工作簿

确保前景是开放的，当你运行它

它是不是一个好主意，使在因安全问题的前景VBA（宏）可能存在的接收到的电子邮件

---

一些指针，你可能已经知道里面：

您可以通过单步通过将光标的任意位置的代码内并按下F8代码重复

黄色高亮指示哪个指令将执行下一个

悬停鼠标指针的变量名称将指示理论值的值在变量（当在任何断点处停止）

点击旁边的一个指令将设置一个断点（不是所有的指令都是“断点能力”）左侧灰色条中（再次单击以清除）

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

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

弹出监视窗口进入“菜单栏“...”查看“...”观看窗口“

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

，那么你可以监测变量值，而在断点

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

化妆使用“立即窗口”的

按ctrl-G，弹出“立即窗口” ...... 任何“ Debug.print“命令将打印到”立即窗口“中... 这是用来显示你需要，而无需编写VBA代码时，在断点处停止

---

一个很好的起点任何调试信息，就是“录制宏”，然后进入VBE IDE和编辑导致宏代码，以满足您的需求

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

例如，你可能在工作表“Sheet5”，你需要从“Sheet2的”删除一切并继续在“Sheet5”上工作：

你会录制宏以下操作：

“单击Sheet2的标签...选择所有细胞（CTRL-A）...按删除...点击Sheet5选项卡”

产生下面的宏

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

它可以改写为：

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

这将清除名为 “Sheet2的” 没有 “选择” 工作吧，所以从未闪烁BR iefly在屏幕上

它可以是恼人，如果一些代码，做了很多的更新不同的工作表的每个更新在屏幕上闪烁了短暂的片刻

---

这里是你的代码

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