Цикл по почтовым элементам Outlook

Question

Я ломаю голову над этим, я довольно плохо знаком с VBA (и программированием в целом) и хотел бы улучшить этот код. Любые идеи о том, как покрыть все почтовые элементы в главных папках, подпапках, подпапках улучшенным или упрощенным кодом?

1 уровень ниже:

• Входящие
• Удалено

На 2 уровня ниже:

• Входящие -> Ожидание
• Входящие -> папка пользователя

3 уровни вниз:

• Входящие -> Ожидание -> Важные
• Входящие -> Папка пользователя -> Пользовательская подпапка

Мой код так далеко:

Sub GetEmailsDetailsMINE()

Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace

Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")

Dim account_folder As Outlook.MAPIFolder
Dim main_folder As Outlook.MAPIFolder
Dim sub_folder1 As Outlook.MAPIFolder
Dim sub_folder2 As Outlook.MAPIFolder

On Error Resume Next

Dim obj_mail As Outlook.MailItem
Dim rowNumber As Integer
rowNumber = 2

For Each account_folder In namespace.Folders
    ' main account, eg someone@company.com
    For Each main_folder In account_folder.Folders
        ' 1 level down, find emails here
        For Each obj_item In main_folder.Items
            If obj_item.Class = olMail Then
                Set obj_mail = obj_item
                Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
                Cells(rowNumber, 2) = obj_mail.To
                Cells(rowNumber, 3) = obj_mail.Subject
                Cells(rowNumber, 4) = obj_mail.ReceivedTime
                Cells(rowNumber, 5) = obj_mail.EntryID
                Cells(rowNumber, 6) = main_folder.Name
                rowNumber = rowNumber + 1
            End If
        Next obj_item
        For Each sub_folder1 In main_folder.Folders
            ' two levels down, find emails here
            For Each obj_item In sub_folder1.Items
                        If obj_item.Class = olMail Then
                            Set obj_mail = obj_item
                            Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
                            Cells(rowNumber, 2) = obj_mail.To
                            Cells(rowNumber, 3) = obj_mail.Subject
                            Cells(rowNumber, 4) = obj_mail.ReceivedTime
                            Cells(rowNumber, 5) = obj_mail.EntryID
                            Cells(rowNumber, 6) = sub_folder1.Name
                            rowNumber = rowNumber + 1
                        End If
            Next obj_item

            ' three levels down
            For Each sub_folder2 In sub_folder1.Folders
                    For Each obj_item In sub_folder2.Items
                        If obj_item.Class = olMail Then
                            Set obj_mail = obj_item
                            Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
                            Cells(rowNumber, 2) = obj_mail.To
                            Cells(rowNumber, 3) = obj_mail.Subject
                            Cells(rowNumber, 4) = obj_mail.ReceivedTime
                            Cells(rowNumber, 5) = obj_mail.EntryID
                            Cells(rowNumber, 6) = sub_folder1.Name & " || " & sub_folder2.Name
                            rowNumber = rowNumber + 1
                        End If
                    Next obj_item
            Next sub_folder2

        Next sub_folder1
    Next main_folder
Next account_folder

On Error GoTo 0

End Sub

Это прекрасно работает, я могу получить все предметы, которые хочу, но почему-то я нахожу это повторяющимся. Любые идеи о том, как улучшить мой код?

Answer 1

РЕДАКТИРОВАТЬ - проверено / исправлено

Нерекурсивный подход:

Sub GetEmailsDetails()
    Dim outlook_app As Outlook.Application
    Dim namespace As Outlook.namespace
    Dim colFolders As New Collection
    Dim fldr As Outlook.MAPIFolder, subfldr As Outlook.MAPIFolder
    Dim obj_mail As Outlook.MailItem, obj_item
    Dim rowNumber As Long

    Set outlook_app = New Outlook.Application
    Set namespace = outlook_app.GetNamespace("MAPI")

    For Each fldr In namespace.Folders
        For Each subfldr In fldr.Folders
            colFolders.Add subfldr
        Next subfldr
    Next

    rowNumber = 2

    Do While colFolders.Count > 0

        Set fldr = colFolders(1) 'get next folder to process
        colFolders.Remove 1      'remove that item

        Application.StatusBar = fldr.FolderPath

        'process the folder
        For Each obj_item In fldr.Items
            If obj_item.Class = olMail Then
                Set obj_mail = obj_item
                Application.StatusBar = rowNumber & " - " & fldr.FolderPath

                On Error Resume Next
                Cells(rowNumber, 1).Resize(1, 6).Value = _
                  Array(obj_mail.SenderEmailAddress, obj_mail.To, _
                        obj_mail.Subject, obj_mail.ReceivedTime, _
                        obj_mail.EntryID, fldr.FolderPath)
                On Error GoTo 0

                rowNumber = rowNumber + 1
            End If
        Next obj_item

        'store all subfolders for processing
        For Each subfldr In fldr.Folders
            colFolders.Add subfldr, before:=1
        Next
    Loop
    Application.StatusBar = False
End Sub

Answer 2

Как насчет использования рекурсии? Как то так ...

Sub GetEmailsDetails()
    ' Loop through all folders
    Dim outlook_app As Outlook.Application
    Dim namespace As Outlook.namespace
    Set outlook_app = New Outlook.Application
    Set namespace = outlook_app.GetNamespace("MAPI")
    Dim main_folder As Outlook.MAPIFolder
    '
    On Error Resume Next
    Dim obj_mail As Outlook.MailItem
    Dim rowNumber As Integer
    rowNumber = 1
    For Each main_folder In namespace.Folders
        EmailDetailsForSubfolder main_folder, rowNumber
    Next main_folder
    On Error GoTo 0
End Sub

Sub EmailDetailsForSubfolder(ThisFolder as Outlook.MAPIFolder, ByRef rowNumber as Integer)
    Dim obj_mail As Outlook.MailItem
    Dim sub_folder As Outlook.MAPIFolder
    For Each obj_mail In ThisFolder.Items
        If obj_item.Class = olMail Then
            rowNumber = rowNumber + 1
            Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
            Cells(rowNumber, 2) = obj_mail.To
            Cells(rowNumber, 3) = obj_mail.Subject
            Cells(rowNumber, 4) = obj_mail.ReceivedTime
            Cells(rowNumber, 5) = obj_mail.EntryID
            Cells(rowNumber, 6) = ThisFolder.Name
        End If
    Next obj_mail
    For Each sub_folder In ThisFolder.Folders
        EmailDetailsForSubfolder sub_folder, rowNumber
    Next
End Sub