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 StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   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
    Dim TotalMail       As Single
    
    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
       
BrowseForFolder StrSavePath
          
    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
        
            Dim n2 As Single, MidStr2 As String, DoneFolder As Boolean, midStr3 As String, midstr4 As String, midSavepath2 As String
            midSavepath2 = StrSavePath
            DoneFolder = False
                midstr4 = StrFolder
            Do While DoneFolder = False
                n2 = InStr(1, midstr4, "\")
                If n2 > 0 Then MidStr2 = Mid(midstr4, 1, n2 - 1) Else MidStr2 = midstr4
                
                midStr3 = midSavepath2 & "\" & MidStr2 & "\"
                If Not FSO.FolderExists(midStr3) Then FSO.CreateFolder (midStr3)
                
                If Not FSO.FolderExists(StrFolderPath) Then DoneFolder = False Else DoneFolder = True
                midstr4 = Mid(midstr4, n2 + 1, 256)
                midSavepath2 = Mid(midStr3, 1, Len(midStr3) - 1)
            Loop
            
        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 = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
            TotalMail = TotalMail + 1
        Next j
        On Error GoTo 0
    Next i
       
MsgBox TotalMail & " DONE"
ExitSub:
       
End Sub