Outlookのフォルダ構成ごとメールを取り出す方法

Dim objFSO As Scripting.FileSystemObject

Sub ExportOutlookFolders()
    Dim objFolder As Outlook.Folder
    Dim strFolderPath As String
    strFolderPath = SelectAnExportFolder()
    If strFolderPath = "" Then
        MsgBox "出力するフォルダを選択してください。", vbInformation + vbOKOnly, "フォルダ選択"
    Else
        Set objFSO = New Scripting.FileSystemObject
        Set objFolder = Outlook.Application.ActiveExplorer.CurrentFolder
        ExportAnOutlookFolder objFolder, strFolderPath
    End If
    Set objFolder = Nothing
    Set objFSO = Nothing
End Sub

Sub ExportAnOutlookFolder(ByVal OutlookFolder As Outlook.Folder, strFolderPath As String)
    Dim objSubFld As Outlook.Folder
    Dim objItem As Object
    Dim strPath As String
    Dim strFilePath As String
    Dim strSubject As String
    Dim strFilename As String
    Dim strRecievedTime As String
    Dim nCount As Long
    On Error Resume Next
    strPath = strFolderPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)
    If Dir(strPath, 16) = Empty Then MkDir strPath

    nCount = 0

    For Each objItem In OutlookFolder.Items
        strSubject = ReplaceInvalidCharacters(objItem.Subject)
        If strSubject = "" Then
            strSubject = "notitle"
        End If
        strRecievedTime = Format(objItem.ReceivedTime, "yyyymmddhhnnss")
        strFilename = strRecievedTime & "_" & strSubject & ".msg"
        strFilePath = strPath & "\" & strFilename
        If objFSO.FileExists(strFilePath) Then
            nCount = nCount + 1
            strFilename = strRecievedTime & "_" & strSubject & " (" & nCount & ").msg"
            strFilePath = strPath & "\" & strFilename
        End If
        objItem.SaveAs strFilePath, olMSG
        
        DoEvents
    Next

    For Each objSubFld In OutlookFolder.Folders
        ExportAnOutlookFolder objSubFld, strPath
    Next
    Set OutlookFolder = Nothing
    Set objItem = Nothing
End Sub

Function SelectAnExportFolder() As String
    Dim objSelFolder As Object
    Dim objShell As Object
    Set objShell = CreateObject("Shell.Application")
    Set objSelFolder = objShell.BrowseForFolder(0, "Select a folder", 0, 0)
    If Not TypeName(objSelFolder) = "Nothing" Then
        SelectAnExportFolder = objSelFolder.self.Path
    End If
    Set objSelFolder = Nothing
    Set objShell = Nothing
End Function

Function ReplaceInvalidCharacters(Str As String) As String
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")
    objRegEx.Global = True
    objRegEx.IgnoreCase = False
    objRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
    ReplaceInvalidCharacters = objRegEx.Replace(Str, "_")
    Set objRegEx = Nothing
End Function