VBA to re-save all files in a directory (document conversion to office 2010)

Posted on 2012-03-16
Last Modified: 2012-04-17
I am trying to do a mass conversion of our Word and Excel documents from the 2003 format to the office 2010 file formats.  There are about 3500 docs that I am looking to convert.

I have managed to create this macro which converts Word docs fairly quickly on a 1-by-1 basis without the extra prompts, but I would love to expand the code to do it for entire directories at a time (even better if it would do it recursively for subfolders).

I am not as familiar with VBA as vbscript and am having a hard time doing this.  Can anyone help?

OriginalFileName = ActiveDocument.Name
Path = ActiveDocument.Path
NewFileName = OriginalFileName & "x"
ChangeFileOpenDirectory Path
ActiveDocument.SaveAs2 FileName:=NewFileName, FileFormat:= _
    wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
    :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
    :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
    SaveAsAOCELetter:=False, CompatibilityMode:=14
WholePath = Path & "\" & OriginalFileName
Kill WholePath

Open in new window

I have played with the Microsoft OMPM converter utility, but although this seems to convert doc's and xls's to docx's and xlsx's, it seems to put them into 2007 version.  When you open them in 2010 it still says "Compatibility Mode" at the top.  So this is not a good solution for me.

Question by:lou6150
LVL 23

Assisted Solution

JSRWilson earned 250 total points
ID: 37732090
Can you not use the File Scripting Object?

Here's the basic code which you can add your open / resave code too

Sub get_all()
Dim fso As Object
Dim folder As Object
Dim subfolder As Object
Dim file As Object
Dim directory As String

directory = "C:\Users\John\Desktop\Test\" ' change of course

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(directory)
For Each file In folder.Files
MsgBox file.Name ' open save here
Next file
For Each subfolder In folder.SubFolders
For Each file In subfolder.Files
MsgBox file.Name 'open save here
Next file
Next subfolder
End Sub

Open in new window

LVL 92

Accepted Solution

Patrick Matthews earned 250 total points
ID: 37733890
This appears to be working.  It will recursively drill into all the subfolders it finds.

It looks for all files in the starting folder plus descendant folders with the following extensions:


It converts each to its macro-enabled equivalent to ensure no problems with VBA getting chopped out.

Make a back-up of your stuff before using this!

Dim Result
Dim xlApp, wdApp, xlWb, wdDoc
Dim Counter, OldName, NewName
Dim fso

GetFiles "c:\Test" 'change as needed

If IsArray(Result) Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xlApp = CreateObject("Excel.Application")
    Set wdApp = CreateObject("Word.Application")
    For Counter = 0 To UBound(Result)
        OldName = Result(Counter)
        Select Case LCase(Right(OldName, 4))
            Case ".xls"
                Set xlWb = xlApp.Workbooks.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "xlsm"
                xlWb.SaveAs NewName, 52
            Case ".xlt"
                Set xlWb = xlApp.Workbooks.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "xltm"
                xlWb.SaveAs NewName, 53
            Case ".xla"
                Set xlWb = xlApp.Workbooks.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "xlam"
                xlWb.SaveAs NewName, 55
            Case ".doc"
                Set wdDoc = wdApp.Documents.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "docm"
                wdDoc.SaveAs2 NewName, 13, , , , , , , , , , , , , , , 65535
            Case ".dot"
                Set wdDoc = wdApp.Documents.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "dotm"
                wdDoc.SaveAs2 NewName, 15, , , , , , , , , , , , , , , 65535
        End Select
        fso.DeleteFile OldName
    Set xlWb = Nothing
    Set xlApp = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set fso = Nothing
    MsgBox "Converted " & (UBound(Result) + 1) & " files"
    MsgBox "No files found"
End If

Sub GetFiles(FolderPath)

    Dim fso, fld, subf, fil

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(FolderPath)

    For Each fil In fld.Files
        Select Case LCase(Right(fil.Name, 4))
            Case ".xls", ".xlt", ".xla", ".doc", ".dot"
                If IsArray(Result) Then
                    ReDim Preserve Result(UBound(Result) + 1)
                    ReDim Result(0)
                End If
                Result(UBound(Result)) = fil.Path
        End Select

    For Each subf In fld.SubFolders
        GetFiles subf.Path

    Set fil = Nothing
    Set subf = Nothing
    Set fld = Nothing
    Set fso = Nothing

End Sub

Open in new window

LVL 46

Expert Comment

by:Martin Liss
ID: 37848038
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.

Author Comment

ID: 37857166
Just wanted to thank both JSRWilson and matthewspatrick and apologize for not getting back to this question.  It seems the experts-exchange email notifications were getting filtered by our mail scrubber.

I ended up looking into this more and used the FSO object to accomplish this, very similar to what JSR suggested.  It was easy once I knew I could use that.  Thanks.

The recursive routine the matthewspatrick offered looks great, although I'm not sure what to do with it or where to put it.  I tried dumping it into VBA editor and it didn't work.

Featured Post

Courses: Start Training Online With Pros, Today

Brush up on the basics or master the advanced techniques required to earn essential industry certifications, with Courses. Enroll in a course and start learning today. Training topics range from Android App Dev to the Xen Virtualization Platform.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
PowerPoint Links 7 42
Help with Word VBA class module 4 51
Why doesn't duplicate values work on this spreadsheet? 6 44
Excel 2010:  VBA Question.  Unable to Run Macro. 2 32
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
No matter the version of Windows you are using, you may have some problems with Windows Search running too slow or possibly not running at all. Before jumping into how you can solve this issue, just know there are many other viable alternative deskt…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …

816 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now