循环浏览 Outlook 邮件项目

Question

I am scratching my head on this one, I am fairly new to VBA (and programming in general) and would like this code improved. Any ideas on how to cover all mail items in main folders, sub folders, sub sub folders with an improved or simplified code?

1 level down:

• Inbox
• Deleted

2 levels down:

• Inbox -> Pending
• Inbox -> user folder

3 levels down:

• Inbox -> Pending -> Important
• Inbox -> user folder -> user sub folder

My code so far is:

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

This works fine, I can get all the items I want but somehow I find it repetitive. Any ideas on how to improve my code?

Answer 1

How about using recursion? Something like this ...

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

EDIT - tested/fixed

A non-recursive approach:

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