How do you convert a large number of files to docx? - vba

Question

I had a large number of doc files that I wanted to convert to docx files.
I discovered that there was not a really good way to automatically do this conversion.
I have submitted the method I used to do this but perhaps there are now other ways.

Answer 1

I found a few thing that might help:
Microsoft Bulk Converter
Simple Microsoft Word macro
However I was not satisfied with macro provided. I needed something recursive to also convert nested files. So I expanded it to do so.
Sub SaveAllAsDOCX()
'Search #EXT to change the extensions to save to docx
Dim strDocName As String
Dim strPath As String
Dim oDoc As Document
Dim fDialog As FileDialog
Dim intPos As Integer
'Create a folder dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select root folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
'Select root folder
strPath = fDialog.SelectedItems.Item(1)
'Ensure the Folder Name ends with a "\"
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
'Close any open documents
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
'remove any quotes from the folder string
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
'begin recusion
recurse (strPath)
End Sub
'This method controls the recusion
Function recurse(folder As String)
'save all the files in the current folder
SaveFilesInFolder (folder)
'get all the subfolders of the current folder
Dim folderArray
folderArray = GetSubFolders(folder)
'Loop through all the non-empty elements for folders
For j = 1 To UBound(folderArray)
If folderArray(j) <> "" Then
'begin recusion on subfolder
recurse (folder & folderArray(j) & "\")
End If
Next
End Function
'Saves all files with listed extensions
Function SaveFilesInFolder(folder As String)
'List of extensions to look for #EXT
Dim strFilename As String
extsArray = Array("*.rtf", "*.doc")
'Loop through extensions
For i = 0 To (UBound(extsArray))
'select the 1st file with the current extension
strFilename = Dir(folder & extsArray(i), vbNormal)
'double check the current extension (don't to resave docx files)
Dim ext As String
ext = ""
On Error Resume Next
ext = Right(strFilename, 5)
If ext = ".docx" Or ext = "" Then
'Don't need to resave files in docx format
Else
'Save the current file in docx format
While Len(strFilename) <> 0
Set oDoc = Documents.Open(folder & strFilename)
strDocName = ActiveDocument.FullName
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
strDocName = strDocName & ".docx"
oDoc.SaveAs FileName:=strDocName, _
FileFormat:=wdFormatDocumentDefault
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFilename = Dir
Wend
End If
Next
strFilename = ""
End Function
'List all the subfolders in the current folder
Function GetSubFolders(RootPath As String)
Dim FS As New FileSystemObject
Dim FSfolder As folder
Dim subfolder As Variant
Set FSfolder = FS.GetFolder(RootPath)
'subfolders is variable length
Dim subfolders() As String
ReDim subfolders(1 To 10)
Dim i As Integer
i = LBound(subfolders)
For Each subfolder In FSfolder.subfolders
subfolders(i) = subfolder.Name
'increase the size of subfolders if it's needed
i = i + 1
If (i >= UBound(subfolders)) Then
ReDim subfolders(1 To (i + 10))
End If
Next subfolder
Set FSfolder = Nothing
GetSubFolders = subfolders
End Function
Yeah I know it's a lot of code. :)