分析Outlook电子邮件和导出到Excel VBA
我目前正在编写一个在Microsoft Outlook中运行的VBAmacros脚本，它应该parsing来自电子邮件的关键信息并将它们存储到Excel电子表格中。
现在，我被困在parsing和提取我想要的逻辑。
这是一个电子邮件的简短例子，需要提取的信息，并保存到Excel中，以黄色（X是大写或小写字母，＃是数字）
这里是Excel布局和我当前的代码发生了什么，没有什么是除了标题popup！
这是我目前的代码：
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编码，所以任何帮助/build议将是伟大的！
未经testing：
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
这里是一些可能让你开始的代码
电子邮件被拆分成行
那么每一行都以冒号字符分隔…“：”
（在进行分割之前，冒号被添加到每一行的末尾，以便空行不会产生错误）
然后采取行动，取决于每行的前几个字符
把这个post末尾的代码放到一个excel工作簿中
确保在运行Outlook时打开Outlook
因为在收到的电子邮件中可能存在的安全问题，在outlook中启用vba（macros）不是一个好主意
一些你可能已经知道的指针：
您可以通过将光标放在代码中的任何位置并按F8重复地单步执行代码
黄色突出显示下一个指令将执行
将鼠标hover在variables名上将指示该variables的值（在任何断点处停止时）
单击指令旁边的左侧灰色栏中的单击将设置一个断点（并非所有指令都是“可断点的”）（再次单击以清除）
按F5将运行程序直到下一个断点或程序结束（如果没有断点的话）
使用“观察窗口”仔细检查对象（variables）
调出观看窗口进入“菜单栏”…“查看”…“观看窗口”
拖动任何对象名称或variables名称到观察窗口，或右键单击它并select“添加观察”
那么您可以在断点处停止时监视variables值
例如。 从第三个Dim语句（或从程序中的其他任何位置）拖动“topOlFolder”
利用“即时窗口”
按ctrl-G调出“立即窗口”…任何“Debug.print”命令将打印到“立即窗口”…这是用来显示任何你需要的debugging信息，而不必停在断点
编写vba代码的一个很好的开始，就是“loggingmacros”，然后进入编辑器，编辑生成的macros代码以满足您的需求
录制macros中的很多代码是不必要的，可以缩短
例如，您可能在工作表“Sheet5”上，您需要从“Sheet2”中删除所有内容，并继续在“Sheet5”上工作：
您将logging一个macros以进行以下操作：
“单击Sheet2选项卡…select所有单元格（ctrl-a）…按删除…单击Sheet5选项卡”
产生下面的macros
Sub Macro1() Sheets("Sheet2").Select Cells.Select Selection.ClearContents Sheets("Sheet5").Select End Sub
它可以被重写为：
Sub Macro1() Sheets("Sheet2").Cells.ClearContents End Sub
这会清除名为“Sheet2”的工作表而不“select”它，因此它永远不会在屏幕上短暂闪烁
如果某些代码对不同的工作表进行了大量更新，并且每次更新都会在屏幕上闪烁一会儿，
这是你的代码
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