Option Explicit 
 
Sub SaveAllEmails_ProcessAllSubFolders() 
     
    Dim i               As Long 
    Dim j               As Long 
    Dim n               As Long 
    Dim StrSubject      As String 
    Dim StrName         As String 
    Dim StrFile         As String 
    Dim StrReceived     As String 
    Dim StrSavePath     As String 
    Dim StrFolder       As String 
    Dim StrFolderPath   As String 
    Dim StrSaveFolder   As String 
    Dim Prompt          As String 
    Dim Title           As String 
    Dim iNameSpace      As NameSpace 
    Dim myOlApp         As Outlook.Application 
    Dim SubFolder       As MAPIFolder 
    Dim mItem           As MailItem 
    Dim FSO             As Object 
    Dim ChosenFolder    As Object 
    Dim Folders         As New Collection 
    Dim EntryID         As New Collection 
    Dim StoreID         As New Collection 
     
    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set myOlApp = Outlook.Application 
    Set iNameSpace = myOlApp.GetNamespace("MAPI") 
    Set ChosenFolder = iNameSpace.PickFolder 
    If ChosenFolder Is Nothing Then 
GoTo ExitSub: 
    End If 
     
    Prompt = "Please enter the path to save all the emails to." 
    Title = "Folder Specification" 
    StrSavePath = BrowseForFolder 
    If StrSavePath = "" Then 
GoTo ExitSub: 
    End If 
    If Not Right(StrSavePath, 1) = "\" Then 
        StrSavePath = StrSavePath & "\" 
    End If 
     
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) 
     
    For i = 1 To Folders.Count 
        StrFolder = StripIllegalChar(Folders(i)) 
        n = InStr(3, StrFolder, "\") + 1 
        StrFolder = Mid(StrFolder, n, 256) 
        StrFolderPath = StrSavePath & StrFolder & "\" 
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\" 
        If Not FSO.FolderExists(StrFolderPath) Then 
            FSO.CreateFolder (StrFolderPath) 
        End If 
         
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i)) 
        On Error Resume Next 
        For j = 1 To SubFolder.Items.Count 
            Set mItem = SubFolder.Items(j) 
            StrReceived = ArrangedDate(mItem.ReceivedTime) 
            StrSubject = mItem.Subject 
            StrName = StripIllegalChar(StrSubject) 
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg" 
            StrFile = Left(StrFile, 256) 
            mItem.SaveAs StrFile, 3 
        Next j 
        On Error GoTo 0 
    Next i 
     
ExitSub: 
     
End Sub 
 
Function StripIllegalChar(StrInput) 
     
    Dim RegX            As Object 
     
    Set RegX = CreateObject("vbscript.regexp") 
     
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 
    RegX.IgnoreCase = True 
    RegX.Global = True 
     
    StripIllegalChar = RegX.Replace(StrInput, "") 
     
ExitFunction: 
     
    Set RegX = Nothing 
     
End Function 
 
 
Function ArrangedDate(StrDateInput) 
     
    Dim StrFullDate     As String 
    Dim StrFullTime     As String 
    Dim StrAMPM         As String 
    Dim StrTime         As String 
    Dim StrYear         As String 
    Dim StrMonthDay     As String 
    Dim StrMonth        As String 
    Dim StrDay          As String 
    Dim StrDate         As String 
    Dim StrDateTime     As String 
    Dim RegX            As Object 
     
    Set RegX = CreateObject("vbscript.regexp") 
     
    If Not Left(StrDateInput, 2) = "10" And _ 
    Not Left(StrDateInput, 2) = "11" And _ 
    Not Left(StrDateInput, 2) = "12" Then 
        StrDateInput = "0" & StrDateInput 
    End If 
     
    StrFullDate = Left(StrDateInput, 10) 
     
    If Right(StrFullDate, 1) = " " Then 
        StrFullDate = Left(StrDateInput, 9) 
    End If 
     
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "") 
     
    If Len(StrFullTime) = 10 Then 
        StrFullTime = "0" & StrFullTime 
    End If 
     
    StrAMPM = Right(StrFullTime, 2) 
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8) 
    StrYear = Right(StrFullDate, 4) 
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "") 
    StrMonth = Left(StrMonthDay, 2) 
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3) 
    If Len(StrDay) = 1 Then 
        StrDay = "0" & StrDay 
    End If 
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay 
    StrDateTime = StrDate & "_" & StrTime 
    RegX.Pattern = "[\:\/\ ]" 
    RegX.IgnoreCase = True 
    RegX.Global = True 
     
    ArrangedDate = RegX.Replace(StrDateTime, "-") 
     
ExitFunction: 
     
    Set RegX = Nothing 
     
End Function 
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder) 
     
    Dim SubFolder       As MAPIFolder 
     
    Folders.Add Fld.FolderPath 
    EntryID.Add Fld.EntryID 
    StoreID.Add Fld.StoreID 
    For Each SubFolder In Fld.Folders 
        GetFolder Folders, EntryID, StoreID, SubFolder 
    Next SubFolder 
     
ExitSub: 
     
    Set SubFolder = Nothing 
     
End Sub 
 
 
Function BrowseForFolder(Optional OpenAt As String) As String 
     
    Dim ShellApp As Object 
     
    Set ShellApp = CreateObject("Shell.Application"). _ 
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 
     
    On Error Resume Next 
    BrowseForFolder = ShellApp.self.Path 
    On Error GoTo 0 
     
    Select Case Mid(BrowseForFolder, 2, 1) 
    Case Is = ":" 
        If Left(BrowseForFolder, 1) = ":" Then 
            BrowseForFolder = "" 
        End If 
    Case Is = "\" 
        If Not Left(BrowseForFolder, 1) = "\" Then 
            BrowseForFolder = "" 
        End If 
    Case Else 
        BrowseForFolder = "" 
    End Select 
     
ExitFunction: 
     
    Set ShellApp = Nothing 
     
End Function