'Loop through three specific Outlook folders

I have Excel VBA code that imports Outlook mail data from one folder into Excel.
I change this for three folders all at the same level (not subfolders).

Is there a way I can specify and run the code on all three folders at once?

Dim mailFolderItemsB As Object
objOwner.Resolve
If objOwner.Resolved Then
    Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
      .Parent.folders("Folder A") 'change this to B and then C once code has run.
      '.Parent.folders("Folder B")
      '.Parent.folders("Folder C")
    Set mailFolderItems = mailFolderItemsB.Items

This might be a second question if so ignore and apologies.
Is it possible to track changes?
Users often open mail, change the subject header and then close. Thinking of a old.value event.

My code.

Sub GetEmail()
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim results() As String
    
    ' call function
    results = ExportEmails(True)
    
    ' paste onto worksheet
    Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
    Exit Sub

ErrorHandler:
    MsgBox Err.Description & " " & Err.Number, vbOKOnly + vbCritical, "Database Error"
End Sub


Function ExportEmails(Optional headerRow As Boolean = False) As String()
    Dim objOutlook As Object ' Outlook.Application
    Dim objNamespace As Object ' Outlook.Namespace
    Dim strFolderName As Object
    Dim objMailbox As Object
    Dim objFolder As Object
    'Dim mailFolderItems As Object ' Outlook.items
    Dim folderItem As Object
    Dim msg As Object ' Outlook.MailItem
    Dim tempString() As String
    Dim i As Long
    Dim numRows As Long
    Dim startRow As Long
    Dim jAttach As Long ' counter for attachments
    Dim debugMsg As Integer
    
    ' select output results worksheet and clear previous results
    Sheets("Outlook Results").Select
    Sheets("Outlook Results").Cells.ClearContents
    Range("A1").Select
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Dim OutApp As outlook.Application
    Dim objOwner As outlook.Recipient
    
    Set OutApp = New outlook.Application
    Set objOwner = objNamespace.CreateRecipient("[email protected]")
    
    Dim mailFolderItemsB As Object, f, mailFolderItems
    
    objOwner.Resolve
    If objOwner.Resolved Then
    
        For Each f In Array("Folder A", "Folder B", "Folder C")
            Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
              .Parent.folders(f) 'change this to B and then C once code has run.
            Set mailFolderItems = mailFolderItemsB.Items
    
            ' if calling procedure wants header row
            If headerRow Then
                startRow = 1
            Else
                startRow = 0
            End If
    
            numRows = mailFolderItems.Count
    
            ReDim tempString(1 To (numRows + startRow), 1 To 100)
    
            ' loop through folder items
            For i = 1 To numRows
    
                Set folderItem = mailFolderItems.Item(i)
    
                If IsMail(folderItem) Then
                    Set msg = folderItem
                End If
                
                With msg
                    tempString(i + startRow, 1) = .subject
                    tempString(i + startRow, 2) = Replace(.body, vbLf, "")
                    tempString(i + startRow, 3) = .Categories
                    tempString(i + startRow, 4) = .cc
                    tempString(i + startRow, 5) = .entryid
                    tempString(i + startRow, 6) = .ConversationID ' .ConversationTopic 'conversationID  or conversationindex.propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E") '.ConversationIndex
                    tempString(i + startRow, 7) = .LastModificationTime 'sent
                    tempString(i + startRow, 8) = .ReceivedByName
                    tempString(i + startRow, 9) = .ReceivedOnBehalfOfName
                    tempString(i + startRow, 10) = .ReceivedTime
                    tempString(i + startRow, 11) = .SenderEmailAddress
                    tempString(i + startRow, 12) = .SenderName
                    tempString(i + startRow, 13) = .SentOn
                    tempString(i + startRow, 14) = .To
                    tempString(i + startRow, 15) = .propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E")
                End With
                
                ' adding file attachment names where they exist
                If msg.Attachments.Count > 0 Then
                    For jAttach = 1 To msg.Attachments.Count
                        'get pdf and xlsx files
                        Dim sAttachment As String
                        sAttachment = msg.Attachments.Item(jAttach).DisplayName
                        If Right(sAttachment, 4) = ".pdf" Or Right(sAttachment, 5) = ".xlsx" Then
                            tempString(i + startRow, 21 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
                        End If
                    Next jAttach
                End If
            
            Next i
    
            ' first row of array should be header values
            If headerRow Then
                tempString(1, 1) = "Subject"
                tempString(1, 2) = "Body"
                tempString(1, 3) = "Categories"
                tempString(1, 4) = "CC"
                tempString(1, 5) = "CreationTime"
                tempString(1, 6) = "ConversationID"
                tempString(1, 7) = "LastModificationTime"
                tempString(1, 8) = "ReceivedByName"
                tempString(1, 9) = "ReceivedOnBehalfOfName"
                tempString(1, 10) = "ReceivedTime"
                tempString(1, 11) = "SenderEmailAddress"
                tempString(1, 12) = "SenderName"
                tempString(1, 13) = "SentOn"
                tempString(1, 14) = "To"
                tempString(1, 15) = "ID"
                tempString(1, 16) = "Number of Attachments"
                tempString(1, 17) = "Attachment 1 Filename"
                tempString(1, 18) = "Attachment 2 Filename"
                tempString(1, 19) = "Attachment 3 Filename"
                tempString(1, 20) = "Attachment 4 Filename"
                tempString(1, 21) = "Attachment 5 Filename"
                tempString(1, 22) = "Attachment 6 Filename"
                tempString(1, 23) = "Attachment 7 Filename"
                tempString(1, 24) = "Attachment 8 Filename"
                tempString(1, 25) = "Attachment 9 Filename"
                tempString(1, 26) = "Attachment 10 Filename"
                tempString(1, 27) = "Attachment 11 Filename"
                tempString(1, 28) = "Attachment 12 Filename"
                tempString(1, 29) = "Attachment 13 Filename"
                tempString(1, 30) = "Attachment 14 Filename"
                tempString(1, 31) = "Attachment 15 Filename"
                tempString(1, 32) = "Attachment 16 Filename"
                tempString(1, 33) = "Attachment 17 Filename"
                tempString(1, 34) = "Attachment 18 Filename"
                tempString(1, 35) = "Attachment 19 Filename"
                tempString(1, 36) = "Attachment 20 Filename"
            End If
        Next f
    End If
    
    ExportEmails = tempString
    
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Rows("1:1").Select
    
End Function

excel vba outlook

Solution 1:^[1]

First, you need to retrieve the shared default folder for the user - this is a common operation which should be repeated three times in a row:

Dim mailFolderItemsB As Object
objOwner.Resolve
If objOwner.Resolved Then
    Set mailSharedInboxFolder = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)

Then you can grab the parent folder for your three folders:

Set mailSharedParentInboxFolder = mailSharedInboxFolder.Parent

And finally you can get three folders:

Set mailFolderItemsA = mailSharedParentInboxFolder.folders("Folder A")
Set mailFolderItemsB = mailSharedParentInboxFolder.folders("Folder B")
Set mailFolderItemsC = mailSharedParentInboxFolder.folders("Folder C")
'
Set mailFolderItems = mailFolderItemsB.Items

I'd recommend avoiding multiple dots in the single line of code. So, you will be able to troubleshoot easily and optimize the overall performance.

For tracking item changes I'd suggest creating an inspector wrapper, see Implement a wrapper for inspectors and track item-level events in each inspector for more information.

Solution 2:^[2]

Something like this:

Dim mailFolderItemsB As Object, f, mailFolderItems 

'...
objOwner.Resolve
If objOwner.Resolved Then

    For Each f in Array("Folder A","Folder B","Folder C")
        Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
                 .Parent.folders(f) 'change this to B and then C once code has run.
        Set mailFolderItems = mailFolderItemsB.Items

        'something happens here...

    Next f
End If

EDIT: you have one huge function which does too much. Try this re-worked example

Sub ProcessEmails()

    Dim OutApp As Outlook.Application
    Dim objOwner As Outlook.Recipient
    Dim objOutlook As Object ' Outlook.Application
    Dim objNamespace As Object ' Outlook.Namespace
    Dim strFolderName As Object
    Dim objMailbox As Object
    Dim objFolder As Object, data
    Dim wsResults As Worksheet
    Dim mailFolderInbox As Object, f, dataRow As Long
    
    ' select output results worksheet and clear previous results
    Set wsResults = ThisWorkbook.Sheets("Outlook Results")
    wsResults.Cells.ClearContents
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Set OutApp = New Outlook.Application
    Set objOwner = objNamespace.CreateRecipient("[email protected]")
    
    objOwner.Resolve
    If objOwner.Resolved Then
    
        Set mailFolderInbox = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
        dataRow = 1 'start putting data on this row
        For Each f In Array("Folder A", "Folder B", "Folder C")
            data = MailData(mailFolderInbox.Parent.Folders(f), True)
            If Not IsEmpty(data) Then
                wsResults.Cells(dataRow, 1).Resize(UBound(data, 1), UBound(data, 2)).Value = data
                dataRow = dataRow + UBound(data, 1) 'next data dump position
            End If
        Next f 'next folder
    End If
End Sub

'Given an Outlook folder object, return an array of data about the contained
'  mail items.  Optionally add a header row to the array.
Function MailData(objFolder As Object, Optional headerRow As Boolean = False)
    
    Dim colMail As New Collection, itm As Object, data(), dataRow As Long, i As Long
    Dim arrHdr, dn, attNum As Long
    
    'only want mail items, so collect them in a Collection
    For Each itm In objFolder.Items
        If TypeName(itm) = "MailItem" Then colMail.Add itm
    Next itm
    If colMail.Count = 0 Then
        MailData = Empty 'nothing to report
        Exit Function
    End If
    
    dataRow = IIf(headerRow, 2, 1) 'data "row" for mail#1
    ReDim data(1 To colMail.Count + (dataRow - 1), 1 To 36)
    
    If headerRow Then 'adding a header "row"?
        arrHdr = Array("Subject", "Body", "Categories", "CC", "EntryId", _
                   "ConversationID", "LastModificationTime", "ReceivedByName", _
                   "ReceivedOnBehalfOfName", "ReceivedTime", "SenderEmailAddress", _
                   "SenderName", "SentOn", "To", "ID", "Number of Attachments")
        For i = 0 To UBound(arrHdr)
            data(1, i + 1) = arrHdr(i)
        Next i
        For i = 1 To 20
            data(1, 16 + i) = "Attachment " & i & " Filename"
        Next i
    End If
    
    For Each itm In colMail 'process all the mailitems found
        With itm
            data(dataRow, 1) = .Subject
            data(dataRow, 2) = Replace(.body, vbLf, "")
            data(dataRow, 3) = .Categories
            data(dataRow, 4) = .cc
            data(dataRow, 5) = .entryid
            data(dataRow, 6) = .ConversationID ' .ConversationTopic 'conversationID  or conversationindex.propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E") '.ConversationIndex
            data(dataRow, 7) = .LastModificationTime 'sent
            data(dataRow, 8) = .ReceivedByName
            data(dataRow, 9) = .ReceivedOnBehalfOfName
            data(dataRow, 10) = .ReceivedTime
            data(dataRow, 11) = .SenderEmailAddress
            data(dataRow, 12) = .SenderName
            data(dataRow, 13) = .SentOn
            data(dataRow, 14) = .to
            data(dataRow, 15) = .propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E")
            data(dataRow, 16) = .attachments.Count
            attNum = 0
            For i = 1 To .attachments.Count
                dn = .attachments(i).DisplayName
                If dn Like "*.xlsx" Or dn Like "*.pdf" Then
                    attNum = attNum + 1
                    If attNum > 20 Then Exit For 'too many attachments...
                    data(dataRow, 16 + attNum) = dn
                End If
            Next i
            dataRow = dataRow + 1
        End With
    Next itm
    MailData = data
End Function

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution	Source
Solution 1	Eugene Astafiev
Solution 2

'Loop through three specific Outlook folders

Solution 1:[1]

Solution 2:[2]

Sources

Related Questions

Solution 1:^[1]

Solution 2:^[2]