根据Outlook邮件更新Excel表格

我的目标是更新Excel表，每当我收到一个特定主题的邮件（我build立了一个规则，将相关的邮件移动到一个文件夹）。

我在这个网站看到了类似的post，但是给出的代码并不完整。 不是“专家”或“技术人员”，很难编码。

邮件包含：

文件名：所有者名称：上次更新date：文件位置（这将是共享驱动器path）：

我会每天收到这封邮件，需要在Excel表格中更新这些信息。 （我将继续开放到月底）

请帮帮我。 提前致谢

Answer 1

介绍

在这个答案的第一个版本中，我提到你另一个我现在知道你将无法阅读的问题。

所有你需要的代码在这里，但这不是立即解决scheme。 这是一个教程，向您介绍Outlook对象模型，从Outlook数据库中获取数据并将其导入Excel工作簿。 不要担心，你不是一个“亲”或“技术人员”。 一旦我们都是新手。 通过部分工作。 不要担心，如果你不明白这一切。 只要拿出你现在需要的零件。 当您想要增强您的解决scheme时，请回到本教程以及您将复制到光盘的代码。

在以下各节中，AnswerA（）和AnswerB（）旨在帮助您了解文件夹结构。 AnswerC1（）也是一个短期的培训援助。 但是，AnswerC2（）和AnswerC3（）是可能需要透明的子例程。 如果你确实保留它们，我build议你重命名它们; 例如：FindFolder（）和FindFolderSub（）。

AnswerD（）也是一个培训帮助，但你应该保留。 这将向您显示如何访问一些邮件项目属性，但我可能需要访问比我所示的更多的邮件项目属性。 在VB编辑器中，单击F2显示对象资源pipe理器。 向下滚动到MailItem类的列表。 您将显示超过100种方法和属性的列表。 有些是显而易见的，但你将不得不使用VB帮助发现许多的目的。 展开AnswerD（）以使用您认为可能有用的方法或显示属性。

AnswerE（）是一个发展援助，但也提供了macros的结构。 目前它输出到一个文件夹内的邮件项目的文本和HTML正文。 你现在不想这样做，但你可能会这样做。 我将所有的电子邮件存档到Excel。 我为每个电子邮件创build一个行，包括发件人，收件人，主题，date等。我将文本正文，html正文和任何附件保存到光盘，并创build超链接。 我有从多个Outlook安装回来的电子邮件。

AnswerF1（）显示如何创build一个新的Excel工作簿和AnswerF2（）显示如何打开一个现有的Excel工作簿。 我认为AnswerF2（）是你所需要的。

这里有很多，但如果你稳步的工作，你将会了解Outlook对象模型以及如何实现你的目标。

健康警告

这个答案中的一切都是通过实验发现的。 我从VB帮助开始，使用F2来访问对象模型并进行实验，直到find工作为止。 我确实买了一本极力推荐的参考书，但是它没有包含我没有发现的重要内容，并且省略了我发现的很多内容。

我怀疑，我所获得的知识的一个关键特征是它基于许多不同的安装。 遇到的一些问题可能是安装错误的结果，这将解释为什么参考书作者不知道它们。

下面的代码已经过Excel 2003和Outlook Exchange 2003和2007的testing。

如果您不熟悉Outlook VBA，请开始使用

打开“Outlook”或“Outlook Exchange”。 这些macros不适用于“Outlook Express”。

从工具栏中select工具，macros，安全。 如果安全级别尚未处于该级别，请将安全级别更改为“中”。 这意味着macros可以运行，但只有您明确的批准。

要启动Outlook VB编辑器：

1）从工具栏中select工具，macros，macros，或者点击Alt + F11 2）select启用macros。

从工具栏中select插入，模块。

你可以看到一个，两个或三个窗口。 在左边应该是项目浏览器。 今天你不需要它，但是如果缺失，请点击Ctrl + R来显示它。 在右上angular，是您将要放置代码的区域。 在底部，你应该看到立即窗口。 如果立即窗口丢失，请单击Ctrl + G以显示它。 下面的macros都使用立即窗口输出，所以你必须能够看到它。

光标将在代码区域。

input：Option Explicit。

这指示VB编辑器检查是否定义了所有variables。 下面的代码已经过testing，但是这可以避免您input的任何代码中的一种types的错误。

将下面的macros复制并粘贴到代码区中。

macros在运行之前，AnswerC（），AnswerD（），Answer（E），AnswerF1（）和AnswerF2（）将需要一些修改。 macros内的指令。

要运行macros，请将光标放在其中，然后按F5键。

访问前两个文件夹级别

顶级文件夹是文件夹types。 所有子文件夹都是MAPIFoldertypes。 我从来没有尝试访问顶层，而不是作为获取子文件夹的手段。

AnswerA（）获取对Outlook Exchange数据库的访问权限，并将顶级文件夹的名称输出到即时窗口。

Sub AnswerA() Dim InxIFLCrnt As Integer Dim TopLvlFolderList As Folders Set TopLvlFolderList = _ CreateObject("Outlook.Application").GetNamespace("MAPI").Folders For InxIFLCrnt = 1 To TopLvlFolderList.Count Debug.Print TopLvlFolderList(InxIFLCrnt).Name Next End Sub 

AnswerB（）输出顶级文件夹及其直接子项的名称。

 Sub AnswerB() Dim InxIFLCrnt As Integer Dim InxISLCrnt As Integer Dim SndLvlFolderList As MAPIFolder Dim TopLvlFolderList As Folders Set TopLvlFolderList = _ CreateObject("Outlook.Application").GetNamespace("MAPI").Folders For InxIFLCrnt = 1 To TopLvlFolderList.Count Debug.Print TopLvlFolderList(InxIFLCrnt).Name Set SndLvlFolderList = TopLvlFolderList.Item(InxIFLCrnt) For InxISLCrnt = 1 To SndLvlFolderList.Folders.Count Debug.Print " " & SndLvlFolderList.Folders(InxISLCrnt).Name Next Next End Sub 

AnswerB（）的问题是孩子可以有孩子可以有任何深度的孩子。 无论深度如何，您都需要能够find特定的文件夹。

find命名文件夹

如果您要search“收件箱”或“已发送邮件”等默认文件夹，则不需要此代码。 如果您将包含表格的邮件复制到不同的文件夹，您将需要此代码。 即使你决定现在不需要这个代码，我build议你保留它，以防将来需要它。

下面的代码使用两个子例程。 调用者组装一个文件夹名称，如“个人文件夹|邮箱|收件箱”。 子例程处理层次结构，如果find，则将所需的文件夹作为对象返回。

注意：稍后将讨论查找默认文件夹（如“收件箱”或“已发送邮件”）的特殊情况。

 Sub AnswerC1() ' This routine wants a folder. It does nothing but display its name. Dim FolderNameTgt As String Dim FolderTgt As MAPIFolder ' The names of each folder down to the one required separated ' by a character not used in folder names. ' ############################################################## ' Replace "Personal Folders|MailBox|Inbox" with the name ' of one of your folders. If you use "|" in your folder names, ' pick a different separator and change the call of AnswerC2(). ' ############################################################## FolderNameTgt = "Personal Folders|MailBox|Inbox" Call AnswerC2(FolderTgt, FolderNameTgt, "|") If FolderTgt Is Nothing Then Debug.Print FolderNameTgt & " not found" Else Debug.Print FolderNameTgt & " found: " & FolderTgt.Name End If End Sub Sub AnswerC2(ByRef FolderTgt As MAPIFolder, NameTgt As String, NameSep As String) ' This routine initialises the search and finds the top level folder Dim InxFolderCrnt As Integer Dim NameChild As String Dim NameCrnt As String Dim Pos As Integer 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 AnswerC3() to look for its children Call AnswerC3(TopLvlFolderList.Item(InxFolderCrnt), _ FolderTgt, NameChild, NameSep) Exit For End If Next End Sub Sub AnswerC3(FolderCrnt As MAPIFolder, ByRef FolderTgt As MAPIFolder, _ NameTgt As String, NameSep As String) ' This routine finds all folders below the top level Dim InxFolderCrnt As Integer Dim NameChild As String Dim NameCrnt As String Dim Pos As Integer ' 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 AnswerC3(FolderCrnt.Folders(InxFolderCrnt), _ FolderTgt, NameChild, NameSep) End If Exit For End If Next End Sub 

检查目标文件夹

AnswerC2（）和AnswerC3（）提供了查找目标文件夹的代码。 文件夹包含项目：邮件项目，会议请求，联系人，日历条目等等。 只有邮件项目由此代码检查。 访问会议请求基本上是相同的，但它们具有不同的属性。

AnswerD（）输出一个邮件项目属性的select。

在选定的文件夹上尝试了AnswerD（）后，按F2或从工具栏中select查看，对象浏览器。 向下滚动项目列表，直到到达MailItem。 会员区将显示超过100个的所有属性和方法。有些是非常明显的; 大多数你将不得不在VB帮助中查找。 修改这个例程以探索更多的属性和方法，或许还有其他types的项目。

警告。 此代码旨在查看邮件项目的命名文件夹。 如果修改代码以浏览整个文件夹层次结构，则可能会遇到问题。 这可能是我的错误，或者它可能是安装过程中的错误，但是我发现如果我试图访问某些文件夹，如“RSS源”，我的代码崩溃。 我从来没有兴趣去探索这些崩溃，并简单地修改我的树search，忽略具有选定名称的分支。

当您运行此macros时，您将收到一条警告：“程序正尝试访问您存储在Outlook中的电子邮件地址，您是否允许这么做？ 勾选“允许访问”，select时间间隔，然后单击是。

 Sub AnswerD() Dim FolderItem As Object Dim FolderItemClass As Integer Dim FolderNameTgt As String Dim FolderTgt As MAPIFolder Dim InxAttach As Integer Dim InxItemCrnt As Integer ' ############################################################## ' Replace "Personal Folders|MailBox|Inbox" with the name ' of one of your folders. If you use "|" in your folder names, ' pick a different separator and change the call of AnswerC2(). ' ############################################################## FolderNameTgt = "Personal Folders|MailBox|Inbox" Call AnswerC2(FolderTgt, FolderNameTgt, "|") If FolderTgt Is Nothing Then Debug.Print FolderNameTgt & " not found" Else ' Display mail items, if any, within folder Debug.Print "Mail items within " & FolderNameTgt For InxItemCrnt = 1 To FolderTgt.Items.Count Set FolderItem = FolderTgt.Items.Item(InxItemCrnt) With FolderItem ' This code seems to avoid syncronisation errors FolderItemClass = 0 On Error Resume Next FolderItemClass = .Class On Error GoTo 0 If FolderItemClass = olMail Then ' Display Received date, Attachment count and Subject Debug.Print " Mail item: " & InxItemCrnt Debug.Print " Received=" & Format(.ReceivedTime, _ "ddmmmyy hh:mm:ss") & " " & _ .Attachments.Count & _ " attachments Subject = " & .Subject Debug.Print " Sender: " & .SenderName With .Attachments ' If the are attachments display their types and names If .Count > 0 Then Debug.Print " Attachments:" For InxAttach = 1 To .Count With .Item(InxAttach) Debug.Print " Type="; Select Case .Type Case olByReference Debug.Print "ByRef"; Case olByValue Debug.Print "ByVal"; Case olEmbeddeditem Debug.Print "Embed"; Case olOLE Debug.Print " OLE"; End Select Debug.Print " DisplayName=" & .DisplayName End With Next End If End With End If End With Next InxItemCrnt End If End Sub 

将机构保存到光盘

AnswerE（）find您select的文件夹，并保存其中的每个邮件项目的文本和HTML正文的副本。 我build议你复制一个包含表的邮件select到一个新的文件夹并运行AnswerE（）。 这与你的问题没有直接关系，但我相信这将有助于理解。

当您运行此macros时，您将收到一条警告：“程序正尝试访问您存储在Outlook中的电子邮件地址，您是否允许这么做？ 勾选“允许访问”，select时间间隔，然后单击是。

 Sub AnswerE() ' Output any Text or HTML bodies found within specified folder Dim FolderItem As Object Dim FolderItemClass As Integer Dim FolderNameTgt As String Dim FolderTgt As MAPIFolder Dim FileSystem As Object Dim FileSystemFile As Object Dim HTMLBody As String Dim InxAttach As Integer Dim InxItemCrnt As Integer Dim PathName As String Dim TextBody As String ' ############################################################## ' Replace "Personal Folders|MailBox|Inbox" with the name ' of one of your folders. If you use "|" in your folder names, ' pick a different separator and change the call of AnswerC2(). ' The folder you pick must have at least one mail item with an ' HTML body for this macro to do anything. ' ############################################################## FolderNameTgt = "Personal Folders|MailBox|Inbox" Call AnswerC2(FolderTgt, FolderNameTgt, "|") If FolderTgt Is Nothing Then Debug.Print FolderNameTgt & " not found" Exit Sub End If ' #################################################################### ' The following is an alternative method of accessing a default folder ' such as Inbox. This statement would replace the code above. ' Set FolderTgt = CreateObject("Outlook.Application"). _ ' GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' #################################################################### ' Extract bodies if found Set FileSystem = CreateObject("Scripting.FileSystemObject") ' ############################################################## ' Replace "C:\Email\" with the name of one of your folders ' ############################################################## PathName = "C:\Email\" For InxItemCrnt = 1 To FolderTgt.Items.Count Set FolderItem = FolderTgt.Items.Item(InxItemCrnt) With FolderItem ' This code seems to avoid syncronisation errors FolderItemClass = 0 On Error Resume Next FolderItemClass = .Class On Error GoTo 0 If FolderItemClass = olMail Then HTMLBody = Trim(.HTMLBody) If HTMLBody <> "" Then ' Save HTML body to disc. The file name is of the form ' BodyNNN.html where NNN is aa sequence number. ' First True in CreateTextFile => overwrite existing file. ' Second True => Unicode format Set FileSystemFile = FileSystem.CreateTextFile(PathName & _ "Body" & Right("00" & InxItemCrnt, 3) & _ ".html", True, True) FileSystemFile.Write HTMLBody FileSystemFile.Close End If TextBody = Trim(.Body) If HTMLBody <> "" Then ' Save text body to disc. The file name is of the form ' BodyNNN.txt where NNN is aa sequence number. Set FileSystemFile = FileSystem.CreateTextFile(PathName & _ "Body" & Right("00" & InxItemCrnt, 3) & _ ".txt", True, True) FileSystemFile.Write TextBody FileSystemFile.Close End If End If End With Next InxItemCrnt End Sub 

创build或更新Excel工作簿

您不会说如果您将创build一个新的Excel工作簿或更新现有的工作簿。 AnswerF1（）创build一个工作簿。 AnswerF2（）打开一个现有的工作簿。

在尝试使用这些macros之前，您必须：

• 在Outlook VBA编辑器中，从工具栏中select工具。
• select参考。
• 向下滚动到Microsoft Excel 11.0对象库，并勾选对应的框。

。

  Sub AnswerF1() Dim xlApp As Excel.Application Dim ExcelWkBk As Excel.Workbook Dim FileName As String Dim PathName As String ' ############################################################## ' Replace "C:\Email\" with the name of one of your folders ' Replace "MyWorkbook.xls" with the your name for the workbook ' ############################################################## PathName = "C:\Email\" FileName = "MyWorkbook.xls" Set xlApp = Application.CreateObject("Excel.Application") With xlApp .Visible = True ' This slows your macro but helps during debugging Set ExcelWkBk = xlApp.Workbooks.Add With ExcelWkBk ' Add Excel VBA code to update workbook here .SaveAs FileName:=PathName & FileName .Close End With .Quit End With End Sub Sub AnswerF2() Dim xlApp As Excel.Application Dim ExcelWkBk As Excel.Workbook Dim FileName As String Dim PathName As String ' ############################################################## ' Replace "C:\Email\" with the name of one of your folders ' Replace "MyWorkbook.xls" with the your name for the workbook ' ############################################################## PathName = "C:\Email\" FileName = "MyWorkbook.xls" Set xlApp = Application.CreateObject("Excel.Application") With xlApp .Visible = True ' This slows your macro but helps during debugging Set ExcelWkBk = xlApp.Workbooks.Open(PathName & FileName) With ExcelWkBk ' Add Excel VBA code to update workbook here .Save .Close End With End With End Sub 

写入Excel工作簿

这段代码find工作簿中的下一个空闲行并写入它。 我解释了为什么常量是有用的，并警告你保持你的Outlook和Excel代码分开。

 ' Constants allow you alter the sequence of columns in your workbook without ' having to change your code. Replace the 1, 2 and 3 in these statements ' and the job is done. ' !!! Constants must be above any subroutines and functions. Public Const ColFrom As Integer = 1 Public Const ColSubject As Integer = 2 Public Const ColSentDate As Integer = 3 Sub AnswerG() Dim RowNext As Integer ' This code goes at the top of your macro With Sheets("Sheet1") ' Replace with the name of your worksheet ' This finds the bottom row with a value in column A. It then adds 1 to get ' the number of the first unused row. RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1 End With ' You will have to separate your Outlook and Excel code. ' With Outlook ' Var1 = .Body ' Var2 = .ReceivedTime ' Var3 = .SenderName ' End With ' With Excel ' .Cell(R, C).Value = Var1 ' End With With Sheets("Sheet1") ' Replace with the name of your worksheet .Cells(RowNext, ColFrom).Value = "John Smith" .Cells(RowNext, ColSubject).Value = "Our meeting" With .Cells(RowNext, ColSentDate) .Value = Now() ' This format means the time is stored and I can access it but it 'is not displayed. Change to "mm/dd/yy" or whatever you like. .NumberFormat = "d mmm yy" End With RowNext = RowNext + 1 ' Ready for next loop End With End Sub 

概要

我希望我已经提供了适当的细节水平。 请以任何方式回应评论。

不要跳到最后的macros。 如果出现任何问题，您将无法理解原因。 花时间玩每个早期的答案。 修改他们做一些稍微不同的事情。

祝你好运。 您将惊讶于您将如何快速适应Outlook和VBA。