我的目标是在收到带有特定主题的邮件时更新 Excel 表格（我设置了将相关邮件移动到文件夹的规则）。
我在这个网站上看到过类似的帖子，但给出的代码不完整。不是“专业人士”或“技术人员”，编写代码非常困难。
邮件包含：
文件名： 业主姓名： 最后更新日期： 文件位置（这将是共享驱动器路径）：
我每天都会收到这封邮件，需要在 Excel 表格中更新此信息。 （我会一直营业到月底）
请帮助我。提前致谢
【问题讨论】：
简介
在此答案的第一个版本中，我向您介绍了另一个我现在知道您将无法阅读的问题。
您需要的所有代码都在这里，但这并不是作为即时解决方案编写的。这是一个向您介绍 Outlook 对象模型、将数据从 Outlook 数据库中获取到 Excel 工作簿的教程。不要担心你不是“专业人士”或“技术人员”；曾经我们都是新手。完成这些部分。如果您不完全理解，请不要担心。只需挑选您现在需要的位。如果您想增强您的解决方案，请返回本教程以及您将复制到光盘的代码。
在以下部分中，AnswerA() 和 AnswerB() 旨在帮助您了解文件夹结构。 AnswerC1() 也是一个短期训练辅助工具。但是，AnswerC2() 和 AnswerC3() 是您可能永远需要的子例程。如果您确实保留它们，我建议您重命名它们；例如：FindFolder() 和 FindFolderSub()。
AnswerD() 也是一种培训辅助工具，但您应该保留它。这向您展示了如何访问一些邮件项目属性，但您可能需要访问比我展示的更多的邮件项目属性。在 VB 编辑器中，单击 F2 以显示对象资源管理器。向下滚动类列表到 MailItem。您将看到超过 100 种方法和属性的列表。有些是显而易见的，但您必须使用 VB Help 来发现许多的目的。展开 AnswerD() 以使用您认为可能有用的方法或显示属性。
AnswerE() 是一种开发辅助工具，但也为您的宏提供了结构。目前它输出到光盘文件夹中邮件项目的文本和 html 正文。您目前不想这样做，但您可能会这样做。我将所有电子邮件归档到 Excel。我为每封电子邮件创建一行，其中包含发件人、收件人、主题、日期等列。我将文本正文、html 正文和任何附件保存到光盘并创建指向它们的超链接。我有多个 Outlook 安装多年前的电子邮件。
AnswerF1() 向您展示如何创建新的 Excel 工作簿，而 AnswerF2() 向您展示如何打开现有的 Excel 工作簿。我认为 AnswerF2() 是您所需要的。
这里有很多内容，但如果您稳步完成它，您将了解 Outlook 对象模型以及如何实现您的目标。
健康警告
此答案中的所有内容都是通过实验发现的。我从 VB Help 开始，使用 F2 访问对象模型并进行试验，直到找到可行的方法。我确实买了一本强烈推荐的参考书，但它没有包含我没有发现的重要内容，并且遗漏了很多我发现的东西。
我怀疑我所获得的知识的一个关键特征是它基于许多不同的安装。遇到的一些问题可能是安装错误导致的，这可以解释为什么参考书作者不知道这些问题。
下面的代码已经过 Excel 2003 和 Outlook Exchange 2003 和 2007 测试。
如果您不熟悉 Outlook VBA，请开始使用
打开“Outlook”或“Outlook Exchange”。这些宏不适用于“Outlook Express”。
从工具栏中，选择工具、宏、安全。如果安全级别尚未达到该级别，请将其更改为“中”。这意味着可以运行宏，但必须得到您的明确批准。
要启动 Outlook VB 编辑器：
1) 从工具栏中，选择工具、宏、宏 或单击 Alt+F11 2) 选择启用宏。
从工具栏中，选择插入、模块。
您可以看到一个、两个或三个窗口。左边应该是 Project Explorer。您今天不需要它，但如果它丢失，请单击 Ctrl+R 以显示它。右侧顶部是放置代码的区域。在底部，您应该看到立即窗口。如果缺少即时窗口，请单击 Ctrl+G 以显示它。下面的宏都使用即时窗口进行输出，所以你必须能够看到它。
光标将位于代码区域。
输入：选项显式。
这会指示 VB 编辑器检查是否定义了所有变量。下面的代码已经过测试，但这避免了您可能输入的任何代码中的一种错误。
将下面的宏一一复制粘贴到代码区。
宏 AnswerC()、AnswerD()、Answer(E)、AnswerF1() 和 AnswerF2() 需要在运行前进行一些修改。宏内的指令。
要运行宏，请将光标放在其中并按 F5。
访问前两个文件夹级别
文件夹的顶层是文件夹类型。所有子文件夹的类型均为 MAPIFolder。除了作为访问子文件夹的一种方式之外，我从未尝试过访问顶层。
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() 的问题是孩子可以有孩子可以有任何深度的孩子。无论深度如何，您都需要能够找到特定的文件夹。
查找命名文件夹
如果您想搜索“收件箱”或“已发送邮件”等默认文件夹，则不需要此代码。如果您将包含表格的消息复制到不同的文件夹，您将需要此代码。即使您决定现在不需要此代码，我也建议您保留它以备将来需要。
下面的代码使用了两个子程序。调用者组合一个文件夹名称，例如“个人文件夹|邮箱|收件箱”。子例程沿层次结构向下工作，如果找到所需的文件夹，则将其作为对象返回。
注意：定位默认文件夹（例如“收件箱”或“已发送邮件”）的特殊情况将在后面讨论。
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() 输出邮件项属性的选择。
在选择的文件夹上尝试过 AnswerD() 后，按 F2 或从工具栏中选择查看、对象浏览器。向下滚动项目列表，直到到达 MailItem。成员区会显示其所有超过100个的属性和方法。大多数你必须在 VB 帮助中查找。修改此例程以探索更多属性和方法，或许还有其他类型的项目。
警告。此代码旨在查看邮件项目的命名文件夹。如果您修改代码以探索整个文件夹层次结构，您可能会遇到问题。这可能是我的错误，也可能是安装错误，但我发现如果我尝试访问某些文件夹（例如“RSS Feeds”），我的代码会崩溃。我从来没有足够的兴趣去探索这些崩溃，只是简单地修改了我的树搜索以忽略具有选定名称的分支。
当您运行此宏时，您将收到一条警告：“程序正在尝试访问您存储在 Outlook 中的电子邮件地址。您要允许这样做吗？”勾选“允许访问”，选择时间间隔，然后单击“是”。
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() 找到您选择的文件夹并保存其中每个邮件项目的文本和 html 正文的副本。我建议您将选择的包含表格的消息复制到一个新文件夹并运行 AnswerE()。这与您的问题没有直接关系，但我相信这将有助于理解。
当您运行此宏时，您将收到一条警告：“程序正在尝试访问您存储在 Outlook 中的电子邮件地址。您要允许这样做吗？”勾选“允许访问”，选择时间间隔，然后单击“是”。
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 a a 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 a a 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
创建或更新 Excel 工作簿
您没有说是要创建新的 Excel 工作簿还是更新现有的工作簿。 AnswerF1() 创建一个工作簿。 AnswerF2() 打开一个现有的工作簿。
在尝试这些宏之前，您必须：
.
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 工作簿
此代码在您的工作簿中找到下一个空闲行并将其写入。我解释了为什么常量很有用，并警告您将 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
总结
我希望我提供了适当的详细信息。请以任何方式回复评论。
不要跳到最后的宏。如果出现任何问题，您将无法理解原因。花点时间玩一下前面的每个答案。修改它们以做一些稍微不同的事情。
祝你好运。您会惊讶地发现自己很快就会适应 Outlook 和 VBA。
【讨论】：