• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1193
  • Last Modified:

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

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
lou6150
Asked:
lou6150
2 Solutions
 
JSRWilsonCommented:
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
 
Patrick MatthewsCommented:
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
 
Martin LissRetired ProgrammerCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
0
 
lou6150Author Commented:
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

NEW Veeam Agent for Microsoft Windows

Backup and recover physical and cloud-based servers and workstations, as well as endpoint devices that belong to remote users. Avoid downtime and data loss quickly and easily for Windows-based physical or public cloud-based workloads!

Tackle projects and never again get stuck behind a technical roadblock.
Join Now