如何將多個word檔案（包括子檔案夾）從.doc轉換為.docx？

有沒有辦法編輯以下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

uj5u.com熱心網友回復：

請使用下一個解決方案：

1. 在模塊頂部添加下一個 API 函式（在宣告區域中）：

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

2. 使用下一個適應的 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

3. 該函式也進行了調整，以處理發現擴展名為“.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

uj5u.com熱心網友回復：

也許這能讓你走上正軌？（未經測驗）

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

標籤：vba ms-word

上一篇：更新/修改公式VBA

下一篇：從VBIDE呼叫的ExcelVBA宏作業正常，但從按鈕呼叫時失敗，直到多次保存檔案