循环浏览 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()
    ' 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

Answer 2

编辑- 测试/修复

非递归方法：

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