使用 vba 遍历收件箱中的每个子文件夹

Question

我在使用以下代码遍历 Outlook 电子邮件的每个子文件夹时遇到问题：

Sub HowManyEmails()

Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

    On Error Resume Next
    'Set objFolder = ActiveExplorer.CurrentFolder
    Set objFolder =       Session.GetFolderFromID  (Application.ActiveExplorer.CurrentFolder.EntryID)     

    If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
    End If

EmailCount = objFolder.Items.Count

' MsgBox "Number of emails in the folder: " & EmailCount, , "email count"

Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oStartDate As String
Dim oEndDate As String


Set dict = CreateObject("Scripting.Dictionary")

oStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
oEndDate = InputBox("Type the end date (format MM/DD/YYYY)")

Set myItems = objFolder.Items.Restrict("[Received] >= '" & oStartDate & "' And [Received] <= '" & oEndDate & "'")
myItems.SetColumns ("Categories")
' date for mssg:
For Each myItem In myItems
    dateStr = myItem.Categories
    If Not dict.Exists(dateStr) Then
        dict(dateStr) = 0
    End If
    dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem

' Output for days
msg = ""
For Each o In dict.Keys
    msg = msg & o & ":   " & dict(o) & vbCrLf
Next
MsgBox msg

Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

 End Sub

代码在收件箱本身上运行，但不会深入到子文件夹中。 我一直在尝试正确循环它，但我一直失败。 感谢您的帮助！

Answer 1

ProcessFolder 中的代码将为父文件夹中的每个子文件夹调用自身。

Option Explicit
Private MessageText As String

Public Sub ListAllFolders()

    'Dim oOutlook As Object 'Outlook.Application
    Dim nNameSpace As Object 'Outlook.Namespace
    Dim mFolderSelected As Object 'Outlook.MAPIFolder

    '''''''''''''''''''''''''''''''''''''''''
    'No need to reference the Outlook application as the code
    'is running from within the application itself.
    ''''''''''''''''''''''''''''''''''''''''
    'Set oOutlook = GetObject(, "Outlook.Application")
    'Set nNameSpace = oOutlook.GetNamespace("MAPI")
    Set nNameSpace = GetNamespace("MAPI")

    Set mFolderSelected = nNameSpace.PickFolder

    ProcessFolder mFolderSelected

    MsgBox MessageText

End Sub

Private Sub ProcessFolder(oParent As Object)

    Dim oFolder As Object 'Outlook.MAPIFolder
    Dim oMail As Object
    Dim sName As String

    'Get the folder name and count of items.
    MessageText = MessageText & oParent.Name & ": " & oParent.Items.Count & vbCr

    'If there are subfolders then process them as well.
    If (oParent.Folders.Count > 0) Then
        For Each oFolder In oParent.Folders
            ProcessFolder oFolder
        Next oFolder
    End If

End Sub

编辑：
这是我用来计算所选文件夹和子文件夹中不同类别电子邮件的代码。
它按日期和类别拆分计数：

Public Sub CreateReport()

    Dim oOutlook As Object 'Outlook.Application
    Dim nNameSpace As Object 'Outlook.Namespace
    Dim mFolderSelected As Object 'Outlook.MAPIFolder
    Dim oItem As Object
    Dim rLastCell As Range
    Dim x As Long

    Set oOutlook = GetObject(, "Outlook.Application")
    Set nNameSpace = oOutlook.GetNamespace("MAPI")

    Set mFolderSelected = nNameSpace.PickFolder

    ''''''''''''''''''''''''''''''''
    'Clear Sheet of existing data. '
    ''''''''''''''''''''''''''''''''
    shtAnalysis.Cells.Delete Shift:=xlUp

    ProcessFolder mFolderSelected

    ''''''''''''''''''''''''''
    'Tidy up and add totals. '
    ''''''''''''''''''''''''''
    Set rLastCell = LastCell(shtAnalysis)

    ThisWorkbook.Activate
    MsgBox "Complete", vbOKOnly

End Sub

Private Sub ProcessFolder(oParent As Object)

    Dim oFolder As Object 'Outlook.MAPIFolder
    Dim oMail As Object
    Dim sName As String
    Dim PropertyAccessor As Object
    Dim v As Variant

    On Error Resume Next
    For Each oMail In oParent.Items
        PlaceDetails oMail
    Next oMail

    If (oParent.Folders.Count > 0) Then
        For Each oFolder In oParent.Folders
            ProcessFolder oFolder
        Next oFolder
    End If
    On Error GoTo 0

End Sub

Sub PlaceDetails(oMailItem As Object)

    Dim rFoundCell As Range
    Dim lColumn As Long
    Dim lRow As Long

    '''''''''''''''''''''''''''''''''''''''''''''
    'Only process emails containing a category. '
    '''''''''''''''''''''''''''''''''''''''''''''
    If oMailItem.categories <> "" Then
        With shtAnalysis

            ''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Does the category already exist on the spreadsheet? '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set rFoundCell = .Rows("1:1").Cells.Find(What:=oMailItem.categories, After:=.Cells(1, 1), _
                LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not rFoundCell Is Nothing Then
                lColumn = rFoundCell.Column
            Else
                lColumn = LastCell(shtAnalysis).Column + 1
            End If
            Set rFoundCell = Nothing

            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Next find the row by looking for sent on date in column A. '
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set rFoundCell = .Columns("A:A").Cells.Find(What:=Int(oMailItem.senton), After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            If Not rFoundCell Is Nothing Then
                lRow = rFoundCell.Row
            Else
                lRow = LastCell(shtAnalysis).Row + 1
            End If
            Set rFoundCell = Nothing

            '''''''''''''''''''''''''''''''''''''''''''''''
            'Place category, date and count on the sheet. '
            '''''''''''''''''''''''''''''''''''''''''''''''
            .Cells(lRow, 1).Value = Int(oMailItem.senton)
            .Cells(1, lColumn).Value = oMailItem.categories
            If .Cells(lRow, lColumn) = "" Then
                .Cells(lRow, lColumn).NumberFormat = "General"
                .Cells(lRow, lColumn) = 1
            Else
                .Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
            End If

        End With
    End If

End Sub

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function