Я пытаюсь импортировать детали каждого электронного письма (отправитель, полученное время, тема и т. Д.) Из папки «Входящие» в файл Excel. У меня есть код, который отлично работает для определенной папки в папке «Входящие», но в папке «Входящие» есть несколько подпапок, и эти подпапки также имеют подпапки.

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

Например, у меня есть Входящие с подпапками Отчеты, Ценообразование и Проекты. В подпапке «Отчет» есть подпапки «Ежедневно», «Еженедельно» и «Ежемесячно». Я могу импортировать электронные письма в отчетах, но не в ежедневных, еженедельных и ежемесячных.

Мой код, как он есть ниже:

Sub SubFolders()

Dim olMail As Variant
Dim aOutput() As Variant
Dim lCnt As Long
Dim xlSh As Excel.Worksheet
Dim olApp As Outlook.Application
Dim olNs As Folder
Dim olParentFolder As Outlook.MAPIFolder
Dim olFolderA As Outlook.MAPIFolder
Dim olFolderB As Outlook.MAPIFolder

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

Set olParentFolder = olNs
ReDim aOutput(1 To 100000, 1 To 5)

For Each olFolderA In olParentFolder.Folders
    For Each olMail In olFolderA.Items
    If TypeName(olMail) = "MailItem" Then
    On Error Resume Next
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = olMail.SenderEmailAddress
        aOutput(lCnt, 2) = olMail.ReceivedTime
        aOutput(lCnt, 3) = olMail.Subject
        aOutput(lCnt, 4) = olMail.Sender
        aOutput(lCnt, 5) = olMail.To

    End If
    Next
Next

Set xlApp = New Excel.Application
Set xlSh = xlApp.Workbooks.Add.Sheets(1)

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True

End Sub