Solved

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

Posted on 2012-03-16
5
1,103 Views
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
        
ActiveDocument.Close
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.

Thanks!
0
Comment
Question by:lou6150
5 Comments
 
LVL 23

Assisted Solution

by:JSRWilson
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

0
 
LVL 92

Accepted Solution

by:
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:

xls
xlt
xla
doc
dot

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
                xlWb.Close
            Case ".xlt"
                Set xlWb = xlApp.Workbooks.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "xltm"
                xlWb.SaveAs NewName, 53
                xlWb.Close
            Case ".xla"
                Set xlWb = xlApp.Workbooks.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "xlam"
                xlWb.SaveAs NewName, 55
                xlWb.Close
            Case ".doc"
                Set wdDoc = wdApp.Documents.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "docm"
                wdDoc.SaveAs2 NewName, 13, , , , , , , , , , , , , , , 65535
                wdDoc.Close
            Case ".dot"
                Set wdDoc = wdApp.Documents.Open(OldName)
                NewName = Left(OldName, InStrRev(OldName, ".")) & "dotm"
                wdDoc.SaveAs2 NewName, 15, , , , , , , , , , , , , , , 65535
                wdDoc.Close
        End Select
        fso.DeleteFile OldName
    Next
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    Set wdDoc = Nothing
    wdApp.Quit
    Set wdApp = Nothing
    Set fso = Nothing
    MsgBox "Converted " & (UBound(Result) + 1) & " files"
Else
    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)
                Else
                    ReDim Result(0)
                End If
                Result(UBound(Result)) = fil.Path
        End Select
    Next

    For Each subf In fld.SubFolders
        GetFiles subf.Path
    Next

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

End Sub

Open in new window

0
 
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.
0
 

Author Comment

by:lou6150
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.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Spell checking an unbound form in MS Access 2013 9 58
Retrieve Windows Office Files from Parallels 12 VM 9 61
vbModal 12 35
TSQL DateADD update Question 4 29
Entering a date in Microsoft Access can be tricky. A typo can cause month and day to be shuffled, entering the day only causes an error, as does entering, say, day 31 in June. This article shows how an inputmask supported by code can help the user a…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This video shows where to find the word count, how to display it, and what it breaks down to in Microsoft Word.
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 …

920 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

16 Experts available now in Live!

Get 1:1 Help Now