Solved

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

Posted on 2012-03-16
5
1,139 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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 47

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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

This article helps those who get the 0xc004d307 error when trying to rearm (reset the license) Office 2013 in a Virtual Desktop Infrastructure (VDI) and/or those trying to prep the master image for Microsoft Key Management (KMS) activation. (i.e.- C…
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …

707 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