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

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

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.

LVL 1

Michelle GilbankMarketzone Database SpecialistCommented: 2016-01-13

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: 2016-01-14

I've tested your code on several workstations and it appears to do the trick. Thanks!

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

Who is Participating?