Convert .rtf to .docx from selected folder and its subfolders in VBA

问题

I managed to modify this VBA script so that it would be able to choose a folder, convert .RTF to .DOCX, and delete the .RTF files after conversion. What I cant figure out, is; How do I get the script to also convert the subfolders in-within that folder. I have looked online and was not able to find a solution. Please advise.

Sub ChangeRTFTODOCXOrTxtOrRTFOrHTML()

    Dim fs As Object
    Dim oFolder As Object
    Dim tFolder As Object
    Dim oFile As Object
    Dim strDocName As String
    Dim intPos As Integer
    Dim folderDialog As FileDialog
    Dim fileType As String
    Dim locFolderKill As String

    Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)
    folderDialog.AllowMultiSelect = False
    folderDialog.Show

    Debug.Print folderDialog.SelectedItems(1)

    Select Case Application.Version
        Case Is < 12
            Do
                fileType = UCase(InputBox("Change rtf to TXT, RTF, HTML, DOCX", "File Conversion", "DOCX"))
            Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "DOCX")
        Case Is >= 12
            Do
                fileType = UCase(InputBox("Change rtf to TXT, RTF, HTML, DOCX or PDF(2007+ only)", "File Conversion", "DOCX"))
            Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "PDF" Or fileType = "DOCX")
    End Select
    Application.ScreenUpdating = False
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fs.GetFolder(folderDialog.SelectedItems(1))
        For Each oFile In oFolder.Files
        Dim d As Document
        Set d = Application.Documents.Open(oFile.Path)
        strDocName = ActiveDocument.Name
        intPos = InStrRev(strDocName, ".")
        strDocName = Left(strDocName, intPos - 1)
        ChangeFileOpenDirectory oFolder
        Select Case fileType
        Case Is = "DOCX"
            strDocName = strDocName & ".DOCX"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatXMLDocument
        Case Is = "TXT"
            strDocName = strDocName & ".txt"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatText
        Case Is = "RTF"
            strDocName = strDocName & ".rtf"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatRTF
        Case Is = "HTML"
            strDocName = strDocName & ".html"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatFilteredHTML
        Case Is = "PDF"
            strDocName = strDocName & ".pdf"

        End Select
        d.Close
        ChangeFileOpenDirectory oFolder
    Next oFile
    Application.ScreenUpdating = True

'This will delete the .RFT files in the same folder.
    Kill "*.rtf"

End Sub

回答1:

Here's an example of how you check subfolders - you can incorporate this into your existing code by looping over the collection returned from GetFileMatches

Sub Tester()

    Dim col As Collection, f

    Set col = GetFileMatches("C:\_Stuff\test\", "*.TXT")

    For Each f In col
        Debug.Print f.Path
    Next f

End Sub

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder

    Do While colSub.Count > 0

        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1

        For Each f In fldr.Files
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f

        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If

    Loop

    Set GetFileMatches = colFiles

End Function

来源：https://stackoverflow.com/questions/43284289/convert-rtf-to-docx-from-selected-folder-and-its-subfolders-in-vba