在 VBA 中将选定文件夹及其子文件夹中的 .rtf 转换为 .docx [英] Convert .rtf to .docx from selected folder and its subfolders in VBA

问题描述

我设法修改了这个 VBA 脚本，以便它能够选择一个文件夹，将 .RTF 转换为 .DOCX，并在转换后删除 .RTF 文件.我想不通的是；如何让脚本也转换该文件夹内的子文件夹.我在网上查看过，但无法找到解决方案.请指教.

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

推荐答案

这是一个如何检查子文件夹的示例 - 您可以通过循环从 GetFileMatches<返回的集合将其合并到现有代码中/p>

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

这篇关于在 VBA 中将选定文件夹及其子文件夹中的 .rtf 转换为 .docx的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！