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文件夹结构的入口点，可能还有一个日期参数（后面的项目） D ...）在Outlook VBA中。然后问题有三个主要部分

从选定的起点开始浏览MAPI文件夹树
识别相关对象（邮件项目......文件夹中可能还有其他项目）
捕获相关对象的一些项目数据并将其写入Excel

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

这是一个代码块，您可以使用它来填充用户表单中的treeview对象，该表单要求递归的根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 ：这很容易......

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

希望有助于让你前进

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

1 个答案: