vba - 如何将大量文件转换为 docx？

Question

我有大量想要转换为 docx 文件的 doc 文件。

我发现没有一种非常好的方法可以自动进行这种转换。

我已经提交了我用来执行此操作的方法，但也许现在还有其他方法。

Answer 1

我发现了一些可能有帮助的东西：

微软批量转换器

简单的 Microsoft Word 宏

但是我对提供的宏不满意。我需要一些递归的东西来转换嵌套文件。所以我扩展它来做到这一点。

Sub SaveAllAsDOCX()

    'Search #EXT to change the extensions to save to docx

    Dim strDocName As String
    Dim strPath As String
    Dim oDoc As Document
    Dim fDialog As FileDialog
    Dim intPos As Integer

    'Create a folder dialog
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select root folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If

    'Select root folder
    strPath = fDialog.SelectedItems.Item(1)

    'Ensure the Folder Name ends with a "\"
    If Right(strPath, 1) <> "\" Then strPath = strPath + "\"

End With

'Close any open documents
If Documents.Count > 0 Then
    Documents.Close SaveChanges:=wdPromptToSaveChanges
End If

'remove any quotes from the folder string
If Left(strPath, 1) = Chr(34) Then
    strPath = Mid(strPath, 2, Len(strPath) - 2)
End If

'begin recusion
recurse (strPath)

End Sub

'This method controls the recusion
Function recurse(folder As String)

    'save all the files in the current folder
    SaveFilesInFolder (folder)

    'get all the subfolders of the current folder
    Dim folderArray
    folderArray = GetSubFolders(folder)

    'Loop through all the non-empty elements for folders
    For j = 1 To UBound(folderArray)
        If folderArray(j) <> "" Then
            'begin recusion on subfolder
            recurse (folder & folderArray(j) & "\")
        End If
    Next
End Function

'Saves all files with listed extensions
Function SaveFilesInFolder(folder As String)

    'List of extensions to look for #EXT
    Dim strFilename As String
    extsArray = Array("*.rtf", "*.doc")

    'Loop through extensions
    For i = 0 To (UBound(extsArray))

        'select the 1st file with the current extension
        strFilename = Dir(folder & extsArray(i), vbNormal)

        'double check the current extension (don't to resave docx files)
        Dim ext As String
        ext = ""
        On Error Resume Next
        ext = Right(strFilename, 5)

        If ext = ".docx" Or ext = "" Then
            'Don't need to resave files in docx format
    Else
        'Save the current file in docx format
        While Len(strFilename) <> 0
            Set oDoc = Documents.Open(folder & strFilename)
            strDocName = ActiveDocument.FullName
            intPos = InStrRev(strDocName, ".")
            strDocName = Left(strDocName, intPos - 1)
            strDocName = strDocName & ".docx"
            oDoc.SaveAs FileName:=strDocName, _
                FileFormat:=wdFormatDocumentDefault
            oDoc.Close SaveChanges:=wdDoNotSaveChanges

            strFilename = Dir
        Wend
    End If
    Next

    strFilename = ""
End Function

'List all the subfolders in the current folder
Function GetSubFolders(RootPath As String)
    Dim FS As New FileSystemObject
    Dim FSfolder As folder
    Dim subfolder As Variant


    Set FSfolder = FS.GetFolder(RootPath)

    'subfolders is variable length
    Dim subfolders() As String
    ReDim subfolders(1 To 10)

    Dim i As Integer
    i = LBound(subfolders)
    For Each subfolder In FSfolder.subfolders
        subfolders(i) = subfolder.Name

        'increase the size of subfolders if it's needed
        i = i + 1
        If (i >= UBound(subfolders)) Then
            ReDim subfolders(1 To (i + 10))
        End If

    Next subfolder

    Set FSfolder = Nothing

    GetSubFolders = subfolders

End Function

是的，我知道这是很多代码。:)