Блог

У меня проблема с перебором всех вложенных папок электронной почты 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: " amp; 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] >= '" amp; oStartDate amp; "' And [Received] <= '" amp; oEndDate amp; "'")
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 amp; o amp; ":   " amp; dict(o) amp; vbCrLf
Next
MsgBox msg

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

 End Sub
  

Код выполняется в самой папке «Входящие», но не проникает во вложенные папки.
Я пытался правильно выполнить цикл, но у меня ничего не получается.
Спасибо за помощь!

Код в 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 amp; oParent.Name amp; ": " amp; oParent.Items.Count amp; 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