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

Mark
Mark used Ask the Experts™
on
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

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Marketzone Database Specialist
Commented:
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

Author

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

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial