How to revise this VBA code to function correctly for sub-folders as well

The Following code has been written in VBA for MS Outlook to save all emails in a specific folder on Outlook (for example inbox, sent items, etc.) as .msg files in a directory on the user's desktop. However, it does not function correctly for sub-folders on Outlook. For example, if the user has already created a sub-folder within the inbox folder or any other default folders in Outlook, the code will not run correctly. Could anyone help me revise the code so that it can function well for any folder on MS Outlook? Any help would be appreciated.

Option Explicit
       Dim StrSavePath     As String

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
      
    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
            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 = Format(mItem.ReceivedTime, "YYYY-MM-DD_hh.mm")
            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
  

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(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder '  As Folder

Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Desktop\")
StrSavePath = objFolder.self.Path

    On Error Resume Next
    On Error GoTo 0
      
ExitFunction:
    Set objShell = Nothing
      
End Function