如何将多个单词文档（包括子文件夹）从 .doc 转换为 .docx？

Question

有没有办法编辑下面的 VBA 代码，使其还可以转换子文件夹中的所有 .doc 文档并删除原始 .doc？

我有很多，我对 VBA 代码不太熟悉。任何帮助将不胜感激！

Sub ConvertBatchToDOCX()
    Dim sSourcePath As String
    Dim sTargetPath As String
    Dim sDocName As String
    Dim docCurDoc As Document
    Dim sNewDocName As String

    ' Looking in this path
    sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
    sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"

   ' Look for first DOC file
    sDocName = Dir(sSourcePath & "*.doc")
    Do While sDocName <> ""
        ' Repeat as long as there are source files
        
        'Only work on files where right-most characters are ".doc"
        If Right(sDocName, 4) = ".doc" Then
            ' Open file
            Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)

            sNewDocName = Replace(sDocName, ".doc", ".docx")

            With docCurDoc
                .SaveAs FileName:=sTargetPath & sNewDocName, _
                  FileFormat:=wdFormatDocumentDefault
                .Close SaveChanges:=wdDoNotSaveChanges
            End With
        End If
        ' Get next source file name
        sDocName = Dir
    Loop
    MsgBox "Finished"
End Sub

Answer 1

请使用下一个解决方案：

1. 在模块顶部添加下一个 API 函数（在声明区域中）：

Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As LongPtr)

1. 使用下一个改编的 Sub：

Sub ConvertBatchToDOCX()
    Dim mainFolderPath As String, sDoc, arrDocs, boolProblematic As Boolean
    Dim docCurDoc As Document, sNewDocName As String, strMsg As String

    ' Looking in this path
   mainFolderPath =  "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
   
   strMsg = "Problematic files: " & vbCrLf
   
   arrDocs = getAllDocs(mainFolderPath & "*.doc")
   If arrDocs(0) = "" Then MsgBox "No appropriate documents have been found...": Exit Sub
        
   For Each sDoc In arrDocs
        sNewDocName = Left(sDoc, InStrRev(sDoc, ".") - 1) & ".docx": ' Stop
        boolProblematic = False
        On Error Resume Next
         Set docCurDoc = Documents.Open(FileName:=sDoc)
         If Err.Number = 5174 Then
            Err.Clear: boolProblematic = True
            strMsg = strMsg & sDoc & vbCrLf
         End If
         If Not boolProblematic Then
            docCurDoc.SaveAs FileName:=sNewDocName, FileFormat:=wdFormatDocumentDefault
            docCurDoc.Close False
            Kill sDoc
            Sleep 1000
        End If
   Next
   If strMsg <> "Problematic files: " & vbCrLf Then MsgBox strMsg
   
  MsgBox "Finished"
End Sub

1. 该功能也进行了调整，以处理扩展名为“.doc”的非文档的情况：

Private Function getAllDocs(strFold As String, Optional strExt As String = "*.*") As Variant
      Dim arrD, arrExt, arrFin, sDoc, i As Long
      arrD = Filter(Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strFold & strExt & """ /b /s").StdOut.ReadAll, vbCrLf), "\")
      ReDim arrFin(UBound(arrD))
      For Each sDoc In arrD
            arrExt = Split(sDoc, ".")
            If LCase(arrExt(UBound(arrExt))) = "doc" Then
                arrFin(i) = sDoc: i = i + 1
            End If
      Next
      If i > 0 Then
        ReDim Preserve arrFin(i - 1)
      Else
        ReDim arrFin(0)
      End If
      getAllDocs = arrFin
End Function

Answer 2

也许这能让你走上正轨？ （未经测试）

Sub saveDOCsAsDOCXs()
  ChDir "C:\myFolderName\"
  Dim fIn As String, fOut As String, doc As Document
  fIn = Dir("*.doc")   'list first `doc` files in current folder (includes `docx`)
  Do
    If Right(fIn, 4) = ".doc" Then 'only process `doc` files
      Debug.Print "Opening " & fIn
      Set doc = Documents.Open(fIn) 'open the `doc`
      fOut = fIn & "x" 'output filename
      If Dir(fOut) <> "" Then
        Debug.Print fOut & " already exists."  'could instead delete existing like `Kill fOut`
      Else
        doc.SaveAs fOut, wdFormatXMLDocument 'save as `docx`
        Debug.Print "Saved " & fOut
      End If
      doc.Close 'close the file
    End If
    fIn = Dir() 'get next `doc` file
  Loop While fIn <> ""
End Sub

文档：Open、SaveAs2、Dir