介绍
在这个答案的第一个版本中，我曾引用另一个问题的链接，但现在我知道您无法阅读那个问题。
所有你需要的代码都在这里，但它并不是一个立即可行的解决方案。这是一个教程，将向你介绍Outlook对象模型的使用，并将数据从Outlook数据库提取到Excel工作簿中。不要担心自己不是“专业人士或技术人员”；我们都曾经是新手。按部就班地学习各个部分。如果你不理解所有内容也不要担心，只需挑选出你需要的部分。当你想要增强你的解决方案时，回到这个教程和你已经复制到你的磁盘上的代码。
在以下各节中，AnswerA()和AnswerB()旨在帮助你了解文件夹结构。 AnswerC1()也是一种短期的培训辅助工具。然而，AnswerC2()和AnswerC3()是你可能需要永久保留的子例程。如果你要保留它们，建议你重命名它们；例如：FindFolder() 和 FindFolderSub()。
AnswerD()也是一种培训辅助工具，但你应该保留它。这向你展示了如何访问一些邮件属性，但你可能需要访问比我展示的更多的邮件属性。在VB编辑器中，点击F2显示对象浏览器。滚动到MailItem类列表下面。你会看到一个包含100多个方法和属性的清单。有些很明显，但你将不得不使用VB帮助来发现许多属性的用途。扩展AnswerD()以使用你认为可能有用的方法或显示属性。
AnswerE()是一种开发辅助工具，但也提供了你的宏的结构。目前它将文件夹中的邮件项的文本和html正文输出到磁盘上。你现在不想这样做，但以后可能需要。我将所有的电子邮件存档到Excel中。对于每封邮件，我创建一行，其中包括发件人、收件人、主题、日期等列。我保存文本正文、html正文和任何附件到磁盘，并创建指向它们的超链接。我从多个Outlook安装中保留了多年的电子邮件。
AnswerF1()向你展示了如何创建新的Excel工作簿，而AnswerF2()向你展示了如何打开现有的Excel工作簿。我假设AnswerF2()是你需要的。
这里有很多内容，但如果你稳步地学习，你将逐渐了解Outlook对象模型以及如何实现你的目标。
健康警告
这个答案中的所有内容都是通过试验发现的。我从VB帮助开始，使用F2访问对象模型，并进行试验，直到找到可行的方法。我确实买了一本广受推荐的参考书，但它并没有包含我未发现的重要内容，而省略了我已经发现的部分。
我怀疑我所获得的知识的一个关键特点是它基于许多不同的安装。遇到的一些问题可能是安装错误的结果，这也可以解释为什么参考书作者不知道
以下代码已在Excel 2003和Outlook Exchange 2003、2007中进行了测试。
如果您不熟悉Outlook VBA
打开“Outlook”或“Outlook Exchange”。 这些宏不适用于“Outlook Express”。
从工具栏中选择“工具”，“宏”，“安全性”。 如果安全级别不是“中”，请将其更改为“中”。 这意味着可以运行宏，但仅经过您的明确批准。
启动Outlook VB编辑器：
1）从工具栏中选择“工具”，“宏”，“宏”或单击Alt + F11 2）选择启用宏。
从工具栏中选择“插入”，“模块”。
您可以看到一个、两个或三个窗口。 左侧应该是项目资源管理器。 今天您不需要它，但如果丢失了，请单击Ctrl + R以显示它。 右侧顶部是您将放置代码的区域。 底部应该看到即时窗口。 如果即时窗口丢失，请单击Ctrl + G以显示它。 以下宏都使用即时窗口进行输出，因此必须能够看到它。
光标将位于代码区域。
输入：Option Explicit。
这将指示VB编辑器检查所有变量是否已定义。 下面的代码已经过测试，但是这可以避免您输入的任何代码中的一种错误。
逐一将下面的宏复制并粘贴到代码区域中。
在运行宏之前，AnswerC()、AnswerD()、Answer(E)、AnswerF1()和AnswerF2()需要进行某些修改。 宏内有说明。
要运行宏，请将光标放置在其中并按F5。
访问顶部两个文件夹级别
顶层文件夹的类型为Folders。 所有子文件夹的类型为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()存在的问题是子文件夹可以无限嵌套子文件夹。您需要能够找到特定深度的文件夹。
查找指定文件夹
如果您想搜索默认文件夹，比如"Inbox"或"Sent Items"，则不需要此代码。如果您将包含表格的邮件复制到其他文件夹中，则需要此代码。即使您现在决定不需要此代码，我建议您保留它以防将来需要。
下面的代码使用了两个子例程。调用者组装一个文件夹名称，例如"Personal Folders|MailBox|Inbox"。子例程沿着层次结构向下工作，并返回所需文件夹作为对象（如果找到）。
注意：查找默认文件夹（例如"Inbox"或"Sent Items"）的特殊情况稍后会讨论。
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订阅”），我的代码会崩溃。我从未对这些崩溃感到足够感兴趣，只是修改了我的树搜索以忽略选择名称的分支。
当您运行此宏时，您将收到一个警告：“某个程序正在尝试访问您在Outlook中存储的电子邮件地址。您是否要允许此操作？”选中“允许访问”，选择一个时间间隔，然后单击“Yes”。
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。