解析Outlook电子邮件并将其导出到Excel VBA [英] Parsing Outlook Emails and Exporting to Excel VBA
问题描述
我目前正在编写在Microsoft Outlook中运行的VBA宏脚本,该脚本应解析电子邮件中的关键信息并将其存储到Excel电子表格中.
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.
现在,我陷入了解析和提取所需内容的逻辑中.
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
这是我第一次使用VB进行编码,因此任何帮助/建议都很棒!
This is my first time ever coding in VB so any help/suggestions would be great!
推荐答案
下面是一些可以帮助您入门的代码
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代码时,一个很好的起点是记录宏",然后进入vide并编辑生成的宏代码以适合您的需求
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 VBA的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!