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

Question

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

Answer 1

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

Answer 2

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