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

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

Select all Open in new window