通过VBA将Outlook收件箱和个人子文件夹中的电子邮件中的数据复制到Excel中

Question

我需要将Outlook 2007/2010收件箱、子文件夹和公用共享文件夹中收到的电子邮件中的名称、主题和接收日期字段复制到Excel 2007/2010中。

当我导出到Excel时，它应该在每次运行宏时附加数据。

这段代码，我在网上得到的，允许我选择一个文件夹，但不是多个选择。有没有办法选择多个文件夹

源代码链接:https://web.archive.org/web/1/http://i.techrepublic%2ecom%2ecom/downlo...k_to_excel.zip

Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "OutlookItems.xls"
strPath = "C:Examples"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = intRowCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.To
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SenderEmailAddress
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.Subject
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SentOn
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.ReceivedTime
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
      "Error"
Else
    MsgBox Err.Number & "; Description: ", vbOKOnly, _
      "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

Answer 1

让我们稍微分解一下您的任务....据我所知，您需要编写一些代码，也许还需要一个用户表单来捕获您的MAPI文件夹结构的入口点，并可能在Outlook VBA中添加日期参数(D…之后的项目)。那么问题有三个主要部分

1. 从选定的起始点
遍历MAPI文件夹树
2. 标识相关对象(邮件项目…文件夹中可能还有其他项目)
3. 抓取相关对象的部分项目数据，写入Excel

ad 1:这很可能是一个递归任务，从某个起始点(根目录或用户选择的任何文件夹)向下到达文件夹结构的底部。因此，我个人会小心使用公共共享文件夹，因为它们可以隐藏大量的文件夹/项目，并打开各种各样的问题(超时运行时间，访问限制等)。另外，您可能不想捕获"已删除项目"文件夹及其子文件夹中的邮件项目。此外，您可能希望将DATE参数传递给这样的递归过程(由用户输入)，以捕获在特定日期之后创建/发送的项目。

这里有一个代码块，可以用来在用户表单中填充一个树视图对象，该对象请求递归的根MAPI文件夹，并对EXPORT按钮做出反应(见下文)

Private Sub UserForm_Initialize()
Dim N As NameSpace, F As MAPIFolder
    Set N = Application.GetNamespace("MAPI")
    ' load all main folders (and their subfolders) into TreeView_Source
    For Each F In N.Folders
        ' in my own app I don't do the Public folder, this would be too massive
        If F.Name <> "Public Folders" Then
            LoadFolder TreeView_Source, F
        End If
    Next F
    Set F = Nothing
    Set N = Nothing
End Sub
Private Sub LoadFolder(TreeViewObj As MSComctlLib.TreeView, F As MAPIFolder, Optional Base As String = "")
Dim G As MAPIFolder
    With TreeViewObj
        If Base = "" Then
            ' add as a root folder
            .Nodes.Add , tvwChild, F.EntryID, F.Name
        Else
            ' add as a child folder connected to Base
            .Nodes.Add Base, tvwChild, F.EntryID, F.Name
        End If
    End With
    ' recursive call to process subfolders of current folder
    For Each G In F.Folders
        LoadFolder TreeViewObj, G, F.EntryID
    Next G
    Set G = Nothing
End Sub

ad 2: this is easy…

If TypeName(MyItem) = "MailItem" Then

ad 3:您需要选择是否在内存结构(数组，无论什么)中捕获项目数据并在过程结束时将其播放到Excel中，或者如果您想要不断更新您在开始时打开的Excel工作表(具有全局模糊对象，行计数器等所有问题)。我暂时不考虑这个问题。

这是我从自己做过的类似任务中提取的一些东西。我重新安排了它，好像它会对一个小用户对话框的"导出"按钮起作用:

注意: BeforeDate在本例中实际上是AfterDate

Private Sub CommandButton_Export_Click()
Dim N As NameSpace, D As Date, S As MAPIFolder
    D = CDate("01-Jän-2011") ' or from a field of your user form
                             ' mind the Umlaut .... 
                             ' yeep I'm from Austria and we speak German ;-)
    ' initialize objects
    Set N = Application.GetNamespace("MAPI")
    Set S = N.GetFolderFromID(TreeView_Source.SelectedItem.Key) ' this refers to a control named TreeView_Source in the current User Dialog form
    ProcessFolder S, D
End Sub
Private Sub ProcessFolder(Source As MAPIFolder, BeforeDate As Date)
' process MailItems of folder Source
' recurse for all subfolders of Source
Dim G As MAPIFolder, Idx As Long, Icnt As Long, ObjDate As Date
    ' process mail items of current folder
    If Source.Items.Count <> 0 Then
        For Idx = 1 To Source.Items.Count
            ' now this is what I mentioned in "ad 2:"
            If TypeName(Source.Items(Idx)) = "MailItem" Then
                If BeforeDate = 0 Or Source.Items(Idx).ReceivedTime >= BeforeDate Then
                    ProcessItem Source.Items(Idx)
                End If
            End If
        Next Idx
    End If
    ' go down into sub folders
    If Source.Folders.Count <> 0 Then
        For Idx = 1 To Source.Folders.Count
            ' here a folder named "Deleted Items" could be trapped
            ProcessFolder Source.Folders(Idx), BeforeDate
        Next Idx
    End If
End Sub
Sub ProcessItem(SrcItem As MailItem)
' here the capturing and eventually the writeout to Excel would occur
' for now I just have key fields printed in the debug screen
    With SrcItem
        Debug.Print .ReceivedTime, .ReceivedByName, .Subject, .Parent.FolderPath
    End With
End Sub

希望这对你有帮助