Option Explicit

Sub ProcessFolder()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim i As Long
Dim sPath As String
Dim ofrm As New frmProgress
Dim PortionDone As Double

    On Error GoTo err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder

    sPath = InputBox("Enter the path to save the messages." & vbCr & _
                     "The path will be created if it doesn't exist.", _
                     "Save Message", "C:\Path\")
    Do Until Right(sPath, 1) = Chr(92)
        sPath = sPath & Chr(92)
    Loop
    CreateFolders sPath

    Set olItems = olMailFolder.Items
    ofrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        PortionDone = i / olItems.Count
        ofrm.Caption = "Processing " & i & " of " & olItems.Count
        ofrm.lblProgress.Width = ofrm.fmeProgress.Width * PortionDone
        SaveMessage olMailItem, sPath
        DoEvents
    Next olMailItem
    Unload ofrm
lbl_Exit:
    Set ofrm = Nothing
    Set olNS = Nothing
    Set olMailFolder = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Private Sub SaveMessage(olItem As MailItem, sPath As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String

    fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, sPath, fname
lbl_Exit:
    Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    lngF = 1
    lngName = Len(strFileName)
    Do While oFSO.FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function