如何使用VBA或macros将Outlook邮件复制到Excel中

这是我的第一篇文章。 我是VBA和macros的新手。 如果有人帮助我使用VBA代码和macros，这将是有益的。

每天我会收到约50-60邮件与一个标准科目：“任务已完成”。 我已经为所有这些邮件创build了一个规则来移动到一个特定的文件夹：“任务已完成”。

每天阅读所有50-60封邮件并更新所有邮件非常耗时。 收到的所有50-60封邮件都会有相同的主题，但来自不同的用户。 邮件的身体会有所不同。

我正在使用Outlook 2010和Excel 2010

谢谢，所有的帮助将不胜感激。

Answer 1

由于您没有提及需要复制的内容，因此我在下面的代码中将该部分留空。

另外，您不需要先将电子邮件移动到文件夹，然后在该文件夹中运行macros。 您可以运行传入的邮件上的macros，然后将其同时移动到该文件夹​​。

这会让你开始。 我已经评论了这个代码，这样你就不会有任何理解它的问题了。

首先将下面提到的代码粘贴到outlook模块中。

然后

1. 点击工具~~>规则和警报
2. 点击“新规则”
3. 点击“从一条空白规则开始”
4. select“检查邮件到达时”
5. 在条件下，点击“用主题中的特定词语”
6. 点击规则描述下的“特定单词”。
7. 在popup的对话框中input要检查的单词，然后单击“添加”。
8. 点击“确定”，然后点击下一步
9. select“将其移动到指定的文件夹”， 并在同一个框中select“运行脚本”
10. 在下面的框中，指定特定的文件夹以及脚本（您在模块中具有的macros）来运行。
11. 点击完成，你就完成了。

新电子邮件到达时，不仅电子邮件将移动到您指定的文件夹，但其中的数据也将导出到Excel。

UNTESTED

Const xlUp As Long = -4162 Sub ExportToExcel(MyMail As MailItem) Dim strID As String, olNS As Outlook.Namespace Dim olMail As Outlook.MailItem Dim strFileName As String '~~> Excel Variables Dim oXLApp As Object, oXLwb As Object, oXLws As Object Dim lRow As Long strID = MyMail.EntryID Set olNS = Application.GetNamespace("MAPI") Set olMail = olNS.GetItemFromID(strID) '~~> Establish an EXCEL application object On Error Resume Next Set oXLApp = GetObject(, "Excel.Application") '~~> If not found then create new instance If Err.Number <> 0 Then Set oXLApp = CreateObject("Excel.Application") End If Err.Clear On Error GoTo 0 '~~> Show Excel oXLApp.Visible = True '~~> Open the relevant file Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls") '~~> Set the relevant output sheet. Change as applicable Set oXLws = oXLwb.Sheets("Sheet1") lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1 '~~> Write to outlook With oXLws ' '~~> Code here to output data from email to Excel File '~~> For example ' .Range("A" & lRow).Value = olMail.Subject .Range("B" & lRow).Value = olMail.SenderName ' End With '~~> Close and Clean up Excel oXLwb.Close (True) oXLApp.Quit Set oXLws = Nothing Set oXLwb = Nothing Set oXLApp = Nothing Set olMail = Nothing Set olNS = Nothing End Sub 

跟进

要从电子邮件正文中提取内容，可以使用SPLIT（）将其拆分，然后从中parsing出相关信息。 看到这个例子

 Dim MyAr() As String MyAr = Split(olMail.body, vbCrLf) For i = LBound(MyAr) To UBound(MyAr) '~~> This will give you the contents of your email '~~> on separate lines Debug.Print MyAr(i) Next i 

Answer 2

新介绍2

在macros“SaveEmailDetails”的前一个版本中，我使用这个语句来查找收件箱：

 Set FolderTgt = CreateObject("Outlook.Application"). _ GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 

自从安装了更新版本的Outlook后，我发现它不使用默认的收件箱。 对于我的每个电子邮件帐户，它都创build了一个单独的商店（以电子邮件地址命名），每个商店都有自己的收件箱。 这些收件箱都不是默认设置。

该macros将保存默认收件箱的商店名称输出到即时窗口：

 Sub DsplUsernameOfDefaultStore() Dim NS As Outlook.NameSpace Dim DefaultInboxFldr As MAPIFolder Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI") Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox) Debug.Print DefaultInboxFldr.Parent.Name End Sub 

在我的安装，这输出：“Outlook数据文件”。

我已经向macros“SaveEmailDetails”添加了额外的语句，显示了如何访问任何商店的收件箱。

新介绍1

一些人拿起了下面的macros，发现它有用，并直接与我联系，以获得进一步的build议。 在这些联系人之后，我对macros进行了一些改进，所以我已经发布了下面的修改版本。 我还添加了一对macros，这些macros一起将返回具有Outlook层次结构的任何文件夹的MAPIFolder对象。 如果您希望访问非默认文件夹，这些很有用。

原文引用了一个按date链接到一个早期问题的问题。 第一个问题已被删除，所以链接已经丢失。 该链接是基于Outlook邮件更新Excel表（closures）

原文

这个问题出现了令人惊讶的变化：“我如何从Outlook电子邮件中提取数据到Excel工作簿？” 例如，8月13日向同一个问题提出了两个关于[outlook-vba]的问题。 这个问题引用了我试图回答的12月份的变化。

对于十二月份的问题，我回答了两个部分的问题。 第一部分是探索Outlook文件夹结构并将数据写入文本文件或Excel工作簿的一系列教学macros。 第二部分讨论了如何devise提取过程。 对于这个问题，Siddarth提供了一个很好的，简洁的答案，然后在下一个阶段提供帮助。

每个变体的提问者似乎都无法理解的是，向我们展示数据在屏幕上的样子并不能告诉我们文本或html身体是什么样的。 这个答案是试图解决这个问题。

下面的macros比Siddarth更复杂，但是我在12月份的答案中包含的更简单得多。 还有更多可以添加，但我认为这是足够的开始。

该macros创build一个新的Excel工作簿并输出收件箱中每个电子邮件的选定属性以创build此工作表：

macros的顶部附近有一个包含8个散列（＃）的注释。 该注释下面的语句必须更改，因为它标识了将在其中创buildExcel工作簿的文件夹。

所有其他包含哈希的注释都提出了修改以使macros适应您的要求。

如何识别从中提取数据的电子邮件？ 它是发送者，主体，身体内的一串还是所有这些？ 评论提供了一些帮助消除无趣的电子邮件。 如果我正确地理解这个问题，一个有趣的电子邮件将有Subject = "Task Completed" 。

这些注释对从有趣的电子邮件中提取数据没有任何帮助，但工作表显示了电子邮件正文的文本和html版本。 我的想法是，你可以看到macros将看到什么，并开始devise提取过程。

这不是在上面的屏幕图像中显示的，但macros在文本正文上输出两个版本。 第一个版本是不变的，这意味着制表符，回车符，换行符和任何非空格空格看起来像空格。 在第二个版本中，我用string[TB]，[CR]，[LF]和[NBSP]replace了这些代码，以便它们可见。 如果我的理解是正确的，我希望在第二个文本体内看到以下内容：

活动[TAB]计数[CR] [LF]打开[TAB] 35 [CR] [LF] HCQA [TAB] 42 [CR] [LF] HCQC [TAB] 60 [CR] [LF] HAbst [TAB] 5 2 2 1 [CR] [LF]等等

从这个string的原始值中提取值不应该很难。

我会尝试修改我的macros来输出除了电子邮件的属性提取的值。 只有当我成功实现这个改变时，我才会尝试将提取的数据写入现有的工作簿。 我也会把处理过的电子邮件移动到不同的文件夹。 我已经表明了必须做出这些改变的地方，但不要再提供任何帮助。 如果你到了需要这些信息的地步，我会回答一个补充问题。

祝你好运。

原始文本中包含的最新版本的macros

 Option Explicit Public Sub SaveEmailDetails() ' This macro creates a new Excel workbook and writes to it details ' of every email in the Inbox. ' Lines starting with hashes either MUST be changed before running the ' macro or suggest changes you might consider appropriate. Dim AttachCount As Long Dim AttachDtl() As String Dim ExcelWkBk As Excel.Workbook Dim FileName As String Dim FolderTgt As MAPIFolder Dim HtmlBody As String Dim InterestingItem As Boolean Dim InxAttach As Long Dim InxItemCrnt As Long Dim PathName As String Dim ReceivedTime As Date Dim RowCrnt As Long Dim SenderEmailAddress As String Dim SenderName As String Dim Subject As String Dim TextBody As String Dim xlApp As Excel.Application ' The Excel workbook will be created in this folder. ' ######## Replace "C:\DataArea\SO" with the name of a folder on your disc. PathName = "C:\DataArea\SO" ' This creates a unique filename. ' #### If you use a version of Excel 2003, change the extension to "xls". FileName = Format(Now(), "yymmdd hhmmss") & ".xlsx" ' Open own copy of Excel Set xlApp = Application.CreateObject("Excel.Application") With xlApp ' .Visible = True ' This slows your macro but helps during debugging .ScreenUpdating = False ' Reduces flash and increases speed ' Create a new workbook ' #### If updating an existing workbook, replace with an ' #### Open workbook statement. Set ExcelWkBk = xlApp.Workbooks.Add With ExcelWkBk ' #### None of this code will be useful if you are adding ' #### to an existing workbook. However, it demonstrates a ' #### variety of useful statements. .Worksheets("Sheet1").Name = "Inbox" ' Rename first worksheet With .Worksheets("Inbox") ' Create header line With .Cells(1, "A") .Value = "Field" .Font.Bold = True End With With .Cells(1, "B") .Value = "Value" .Font.Bold = True End With .Columns("A").ColumnWidth = 18 .Columns("B").ColumnWidth = 150 End With End With RowCrnt = 2 End With ' FolderTgt is the folder I am going to search. This statement says ' I want to seach the Inbox. The value "olFolderInbox" can be replaced ' to allow any of the standard folders to be searched. ' See FindSelectedFolder() for a routine that will search for any folder. Set FolderTgt = CreateObject("Outlook.Application"). _ GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' #### Use the following the access a non-default Inbox. ' #### Change "Xxxx" to name of one of your store you want to access. Set FolderTgt = Session.Folders("Xxxx").Folders("Inbox") ' This examines the emails in reverse order. I will explain why later. For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1 With FolderTgt.Items.Item(InxItemCrnt) ' A folder can contain several types of item: mail items, meeting items, ' contacts, etc. I am only interested in mail items. If .Class = olMail Then ' Save selected properties to variables ReceivedTime = .ReceivedTime Subject = .Subject SenderName = .SenderName SenderEmailAddress = .SenderEmailAddress TextBody = .Body HtmlBody = .HtmlBody AttachCount = .Attachments.Count If AttachCount > 0 Then ReDim AttachDtl(1 To 7, 1 To AttachCount) For InxAttach = 1 To AttachCount ' There are four types of attachment: ' * olByValue 1 ' * olByReference 4 ' * olEmbeddedItem 5 ' * olOLE 6 Select Case .Attachments(InxAttach).Type Case olByValue AttachDtl(1, InxAttach) = "Val" Case olEmbeddeditem AttachDtl(1, InxAttach) = "Ebd" Case olByReference AttachDtl(1, InxAttach) = "Ref" Case olOLE AttachDtl(1, InxAttach) = "OLE" Case Else AttachDtl(1, InxAttach) = "Unk" End Select ' Not all types have all properties. This code handles ' those missing properties of which I am aware. However, ' I have never found an attachment of type Reference or OLE. ' Additional code may be required for them. Select Case .Attachments(InxAttach).Type Case olEmbeddeditem AttachDtl(2, InxAttach) = "" Case Else AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName End Select AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName AttachDtl(5, InxAttach) = "--" ' I suspect Attachment had a parent property in early versions ' of Outlook. It is missing from Outlook 2016. On Error Resume Next AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent On Error GoTo 0 AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position ' Class 5 is attachment. I have never seen an attachment with ' a different class and do not see the purpose of this property. ' The code will stop here if a different class is found. Debug.Assert .Attachments(InxAttach).Class = 5 AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class Next End If InterestingItem = True Else InterestingItem = False End If End With ' The most used properties of the email have been loaded to variables but ' there are many more properies. Press F2. Scroll down classes until ' you find MailItem. Look through the members and note the name of ' any properties that look useful. Look them up using VB Help. ' #### You need to add code here to eliminate uninteresting items. ' #### For example: 'If SenderEmailAddress <> "[e-mail]" Then ' InterestingItem = False 'End If 'If InStr(Subject, "Accounts payable") = 0 Then ' InterestingItem = False 'End If 'If AttachCount = 0 Then ' InterestingItem = False 'End If ' #### If the item is still thought to be interesting I ' #### suggest extracting the required data to variables here. ' #### You should consider moving processed emails to another ' #### folder. The emails are being processed in reverse order ' #### to allow this removal of an email from the Inbox without ' #### effecting the index numbers of unprocessed emails. If InterestingItem Then With ExcelWkBk With .Worksheets("Inbox") ' #### This code creates a dividing row and then ' #### outputs a property per row. Again it demonstrates ' #### statements that are likely to be useful in the final ' #### version ' Create dividing row between emails .Rows(RowCrnt).RowHeight = 5 .Range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "B")) _ .Interior.Color = RGB(0, 255, 0) RowCrnt = RowCrnt + 1 .Cells(RowCrnt, "A").Value = "Sender name" .Cells(RowCrnt, "B").Value = SenderName RowCrnt = RowCrnt + 1 .Cells(RowCrnt, "A").Value = "Sender email address" .Cells(RowCrnt, "B").Value = SenderEmailAddress RowCrnt = RowCrnt + 1 .Cells(RowCrnt, "A").Value = "Received time" With .Cells(RowCrnt, "B") .NumberFormat = "@" .Value = Format(ReceivedTime, "mmmm d, yyyy h:mm") End With RowCrnt = RowCrnt + 1 .Cells(RowCrnt, "A").Value = "Subject" .Cells(RowCrnt, "B").Value = Subject RowCrnt = RowCrnt + 1 If AttachCount > 0 Then .Cells(RowCrnt, "A").Value = "Attachments" .Cells(RowCrnt, "B").Value = "Inx|Type|Path name|File name|Display name|Parent|Position|Class" RowCrnt = RowCrnt + 1 For InxAttach = 1 To AttachCount .Cells(RowCrnt, "B").Value = InxAttach & "|" & _ AttachDtl(1, InxAttach) & "|" & _ AttachDtl(2, InxAttach) & "|" & _ AttachDtl(3, InxAttach) & "|" & _ AttachDtl(4, InxAttach) & "|" & _ AttachDtl(5, InxAttach) & "|" & _ AttachDtl(6, InxAttach) & "|" & _ AttachDtl(7, InxAttach) RowCrnt = RowCrnt + 1 Next End If If TextBody <> "" Then ' ##### This code was in the original version of the macro ' ##### but I did not find it as useful as the other version of ' ##### the text body. See below ' This outputs the text body with CR, LF and TB obeyed 'With .Cells(RowCrnt, "A") ' .Value = "text body" ' .VerticalAlignment = xlTop 'End With 'With .Cells(RowCrnt, "B") ' ' The maximum size of a cell 32,767 ' .Value = Mid(TextBody, 1, 32700) ' .WrapText = True 'End With 'RowCrnt = RowCrnt + 1 ' This outputs the text body with NBSP, CR, LF and TB ' replaced by strings. With .Cells(RowCrnt, "A") .Value = "text body" .VerticalAlignment = xlTop End With TextBody = Replace(TextBody, Chr(160), "[NBSP]") TextBody = Replace(TextBody, vbCr, "[CR]") TextBody = Replace(TextBody, vbLf, "[LF]") TextBody = Replace(TextBody, vbTab, "[TB]") With .Cells(RowCrnt, "B") ' The maximum size of a cell 32,767 .Value = Mid(TextBody, 1, 32700) .WrapText = True End With RowCrnt = RowCrnt + 1 End If If HtmlBody <> "" Then ' ##### This code was in the original version of the macro ' ##### but I did not find it as useful as the other version of ' ##### the html body. See below ' This outputs the html body with CR, LF and TB obeyed 'With .Cells(RowCrnt, "A") ' .Value = "Html body" ' .VerticalAlignment = xlTop 'End With 'With .Cells(RowCrnt, "B") ' .Value = Mid(HtmlBody, 1, 32700) ' .WrapText = True 'End With 'RowCrnt = RowCrnt + 1 ' This outputs the html body with NBSP, CR, LF and TB ' replaced by strings. With .Cells(RowCrnt, "A") .Value = "Html body" .VerticalAlignment = xlTop End With HtmlBody = Replace(HtmlBody, Chr(160), "[NBSP]") HtmlBody = Replace(HtmlBody, vbCr, "[CR]") HtmlBody = Replace(HtmlBody, vbLf, "[LF]") HtmlBody = Replace(HtmlBody, vbTab, "[TB]") With .Cells(RowCrnt, "B") .Value = Mid(HtmlBody, 1, 32700) .WrapText = True End With RowCrnt = RowCrnt + 1 End If End With End With End If Next With xlApp With ExcelWkBk ' Write new workbook to disc If Right(PathName, 1) <> "\" Then PathName = PathName & "\" End If .SaveAs FileName:=PathName & FileName .Close End With .Quit ' Close our copy of Excel End With Set xlApp = Nothing ' Clear reference to Excel End Sub 

macros未包含在原始文章中，但有些以上macros的用户已经发现有用。

 Public Sub FindSelectedFolder(ByRef FolderTgt As MAPIFolder, _ ByVal NameTgt As String, ByVal NameSep As String) ' This routine (and its sub-routine) locate a folder within the hierarchy and ' returns it as an object of type MAPIFolder ' NameTgt The name of the required folder in the format: ' FolderName1 NameSep FolderName2 [ NameSep FolderName3 ] ... ' If NameSep is "|", an example value is "Personal Folders|Inbox" ' FolderName1 must be an outer folder name such as ' "Personal Folders". The outer folder names are typically the names ' of PST files. FolderName2 must be the name of a folder within ' Folder1; in the example "Inbox". FolderName2 is compulsory. This ' routine cannot return a PST file; only a folder within a PST file. ' FolderName3, FolderName4 and so on are optional and allow a folder ' at any depth with the hierarchy to be specified. ' NameSep A character or string used to separate the folder names within ' NameTgt. ' FolderTgt On exit, the required folder. Set to Nothing if not found. ' This routine initialises the search and finds the top level folder. ' FindSelectedSubFolder() is used to find the target folder within the ' top level folder. Dim InxFolderCrnt As Long Dim NameChild As String Dim NameCrnt As String Dim Pos As Long Dim TopLvlFolderList As Folders Set FolderTgt = Nothing ' Target folder not found Set TopLvlFolderList = _ CreateObject("Outlook.Application").GetNamespace("MAPI").Folders ' Split NameTgt into the name of folder at current level ' and the name of its children Pos = InStr(NameTgt, NameSep) If Pos = 0 Then ' I need at least a level 2 name Exit Sub End If NameCrnt = Mid(NameTgt, 1, Pos - 1) NameChild = Mid(NameTgt, Pos + 1) ' Look for current name. Drop through and return nothing if name not found. For InxFolderCrnt = 1 To TopLvlFolderList.Count If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then ' Have found current name. Call FindSelectedSubFolder() to ' look for its children Call FindSelectedSubFolder(TopLvlFolderList.Item(InxFolderCrnt), _ FolderTgt, NameChild, NameSep) Exit For End If Next End Sub Public Sub FindSelectedSubFolder(FolderCrnt As MAPIFolder, _ ByRef FolderTgt As MAPIFolder, _ ByVal NameTgt As String, ByVal NameSep As String) ' See FindSelectedFolder() for an introduction to the purpose of this routine. ' This routine finds all folders below the top level ' FolderCrnt The folder to be seached for the target folder. ' NameTgt The NameTgt passed to FindSelectedFolder will be of the form: ' A|B|C|D|E ' A is the name of outer folder which represents a PST file. ' FindSelectedFolder() removes "A|" from NameTgt and calls this ' routine with FolderCrnt set to folder A to search for B. ' When this routine finds B, it calls itself with FolderCrnt set to ' folder B to search for C. Calls are nested to whatever depth are ' necessary. ' NameSep As for FindSelectedSubFolder ' FolderTgt As for FindSelectedSubFolder Dim InxFolderCrnt As Long Dim NameChild As String Dim NameCrnt As String Dim Pos As Long ' Split NameTgt into the name of folder at current level ' and the name of its children Pos = InStr(NameTgt, NameSep) If Pos = 0 Then NameCrnt = NameTgt NameChild = "" Else NameCrnt = Mid(NameTgt, 1, Pos - 1) NameChild = Mid(NameTgt, Pos + 1) End If ' Look for current name. Drop through and return nothing if name not found. For InxFolderCrnt = 1 To FolderCrnt.Folders.Count If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then ' Have found current name. If NameChild = "" Then ' Have found target folder Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt) Else 'Recurse to look for children Call FindSelectedSubFolder(FolderCrnt.Folders(InxFolderCrnt), _ FolderTgt, NameChild, NameSep) End If Exit For End If Next ' If NameCrnt not found, FolderTgt will be returned unchanged. Since it is ' initialised to Nothing at the beginning, that will be the returned value. End Sub