How to make this code apply recursively to all sub-folders - vba

Question

I found this code to change .doc files to .docx files. I would like to modify it so I can specify a top level folder and have it work through it AND every sub-folder. Appreciate any assistance.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "C:\Temp\doc\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub

Answer 1

I suggest switching from Dir to FileSystemObject. With FSO, you can get a folder as an object with GetFolder and then access the Folder Object's files and folders as collections. This enables For Each loops like For Each File In Folder. and then you can do the recursion For Each SubFolder In Folder where you can re-call the macro as if each subfolder was the top level folder.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim strFolder As String
strFolder = "C:\Temp\doc\"
Dim StartingFolder As Object
Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
FolderToDocx StartingFolder, objWordApplication
Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
Dim File As Object
For Each File In Folder.Files
If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
Next
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
FolderToDocx SubFolder, wdApp
Next
End Sub
Sub SaveToDocx(File As Object, wdApp As Word.Application)
With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
.SaveAs Filename:=File.Path & "x"), FileFormat:=16
.Close
End With
End Sub
The file matching expression I did in this answer is just an example. You may want to improve that expression to prevent errors. One error that may come up is with Microsoft Office temp files. They are usually hidden and prefixed with ~$ like ~$Word Document.docx. So to avoid accidentally matching one of those, it would be good to exclude anything with that prefix.

Answer 2

I would recommend splitting out the file searching into a separate function: it's easier to tweak your logic and the main method doesn't get overloaded by the code for finding the files.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(Filename:=strFile, _
AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs Filename:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function