Option Explicit

Sub SaveMessages()
'Graham Mayor - http://www.gmayor.com
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Outlook.Folder
Dim olNS As Outlook.NameSpace
Dim strPath As String
Dim sSubPath As String
Dim sStore As String

    strPath = InputBox("Enter the path to save the messages." & vbCr & _
                       "The path will be created if it doesn't exist.", _
                       "Save Message", "C:\Outlook Message Backup\")

    Do Until Right(strPath, 1) = Chr(92)
        strPath = strPath & Chr(92)
    Loop

    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        sStore = olFolder.Store
        sSubPath = Replace(olFolder.FolderPath, "\\" & sStore & "\", strPath)
        CreateFolders sSubPath
        ProcessFolder olFolder, sSubPath
        If olFolder.folders.Count > 0 Then
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        End If
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Exit Sub
End Sub

Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String)
'Graham Mayor - http://www.gmayor.com
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim i As Long
Dim ofrm As New frmProgress
Dim PortionDone As Double

    On Error GoTo err_Handler

    Set olItems = olMailFolder.Items
    ofrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        'If Not olMailItem.categories = "Backed-up To File" Then
            PortionDone = i / olItems.Count
            ofrm.Caption = olMailFolder.Name & " - Processing " & i & " of " & olItems.Count
            ofrm.lblProgress.Width = ofrm.fmeProgress.Width * PortionDone
            SaveMessage olMailItem, sPath
            'olMailItem.categories = "Backed-up To File"
            'olMailItem.Save
            DoEvents
        'End If
    Next olMailItem
    Unload ofrm
lbl_Exit:
    Set ofrm = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub