How to convert multiple word docs (incl subfolders) from .doc to .docx?-CodePudding

Is there a way to edit the following VBA code in a way that it can also convert all .doc documents in sub folders and delete the original .doc?

I have quite many of them and I am not quite familiar with VBA code. Any help would be much appreciated!

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

CodePudding user response：

Please use the next solution:

Add the next API function on top of the module (in the declarations area):

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

Use the next adapted 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

The function has also been adapted, in order to handle the case of not document with extension ".doc" has been found:

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

CodePudding user response：

Maybe this could get you on the right track? (Untested)

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

Documentation: Open, SaveAs2, Dir