How to scan all message in all Outlook folders with VB macro

I have the Outlook VB macro shown below. It works fine for scanning mail in the currently selected folder. How do I modify it to scan for all messages in all folders?
Public Sub scanFolder()
Dim src As Folder
Dim oItem As Object
Dim propertyAccessor As Outlook.propertyAccessor
Set src = Application.ActiveExplorer.CurrentFolder
Dim strHeader As String

For Each oItem In src.Items
    If TypeOf oItem Is Outlook.MailItem And oItem.Categories <> "" Then
'        Debug.Print "Cat: " + oItem.Categories
        Set propertyAccessor = oItem.propertyAccessor
        header = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
        Dim headerLines() As String
        headerLines() = Split(header, vbCrLf)

        Dim thisHeader As Variant

        For Each thisHeader In headerLines
            If InStr(thisHeader, "Message-ID:") > 0 Then
               Debug.Print thisHeader + "~" + oItem.Categories
               Exit For
           End If
        Next
    End If
Next
End Sub

Open in new window

LVL 1
MarkAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Michelle GilbankMarketzone Database SpecialistCommented:
I am not able to run this at the moment, so there may be typos.
This will work using the MAPI folder list.  

Hope this helps!

-teslasmom

 ' Reference to Outlook library
 '
Public Sub ListOutlookFolders() 
     
    Dim olApp As Outlook.Application 
    Dim olNamespace As Outlook.Namespace 
    Dim olFolder As Outlook.MAPIFolder 
     
    Set olApp = New Outlook.Application 
    Set olNamespace = olApp.GetNamespace("MAPI") 
     
    For Each olFolder In olNamespace.Folders 
        Debug.Print olFolder.Name; ":", olFolder.Description 
        ListFolders olFolder, 1 
    Next 
     
    Set olFolder = Nothing 
    Set olNamespace = Nothing 
    Set olApp = Nothing 
     
End Sub 

Sub ListFolders(myFolder As Outlook.MAPIFolder, Level As Integer) 
    Dim olFolder As Outlook.MAPIFolder 
'  go through each email
    scanFolder myFolder

'  Now we'll check for subfolders
    For Each olFolder In myFolder.Folders 
'        Debug.Print ":"; String(Level * 2, "-"); olFolder.Name 

'        go through each email
        scanFolder olFolder

        If olFolder.Folders.Count > 0 Then 
            ListFolders olFolder, Level + 1 
        End If 
    Next 
End Sub 


Sub scanFolder(sFolder As Outlook.MAPIFolder)
Dim src As Folder
Dim oItem As Object
Dim propertyAccessor As Outlook.propertyAccessor
Set src = sFolder

Dim strHeader As String

For Each oItem In src.Items
    If TypeOf oItem Is Outlook.MailItem And oItem.Categories <> "" Then
'        Debug.Print "Cat: " + oItem.Categories
        Set propertyAccessor = oItem.propertyAccessor
        header = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
        Dim headerLines() As String
        headerLines() = Split(header, vbCrLf)

        Dim thisHeader As Variant

        For Each thisHeader In headerLines
            If InStr(thisHeader, "Message-ID:") > 0 Then
               Debug.Print thisHeader + "~" + oItem.Categories
               Exit For
           End If
        Next
    End If
Next
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
MarkAuthor Commented:
I've tested your code on several workstations and it appears to do the trick. Thanks!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.