Office Conversion Advice

[mat41]

hi there - I am not sure where to put this post, please advise if there is a better area?

We want to create a server side tool that allow users to upload batches of documents (or specify share drives) to convert from Office 2003 (binary) to Office 2010 (XML).

Is is possible to create a web service or server side tool that can process / convert a Microsoft Office document from binary to XML using Office Automation methods - e.g. ConvertAccessProject ? (noting

http://support.microsoft.com/kb/257757)

Failing the above, I envision falling back to a shell execution of the OMPM (batch conversion tool - OFC.exe) with dynamic manipulation of the INI file...

TYIA

 

[macropod]

Hi Mat,

I'd have thought a better idea was to leave the old files alone. Unless you need to add features to existing documents that the binary format doesn't support, there's little to be gained by converting them. Besides, merely opening the documents and converting them may result in macros running and/or fields, links etc updating.

Cheers
Paul Edstein
[MS MVP - Word]

 

[byundt]

If you want to convert all the files from .xls file format to .xlsx, you will need to open each file in turn, then save it with the new file format.

Here is an Excel macro (BinaryUpdater) that will automate the task. It works on a user-selected folder, and works on subfolders too. The macro will list the files converted along with their path in columns A and B of the active worksheet.

Install the code in a regular module. Make sure that you save the workbook as .xlsm file format, otherwise the code will be deleted

Dim FSO As Object

Sub BinaryUpdater()
'Opens all .xls files in a folder & subfolders, then saves them in .xlsx format
Dim TopFolderName As String
Dim TopFolderObj As Object
Dim wOut As Worksheet
        'Input Path and Search Term
TopFolderName = Application.GetOpenFilename("Excel Files (*.xls), *.xls", _
        Title:="Pick any file in desired folder, then click 'Open' button.")
If TopFolderName = "False" Then Exit Sub
TopFolderName = Left(TopFolderName, InStrRev(TopFolderName, Application.PathSeparator) - 1)

Set wOut = ActiveSheet

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set FSO = CreateObject("Scripting.FileSystemObject")
With wOut
    .Range("A1:B1").Value = Array("Path", "Workbook")
End With
Set TopFolderObj = FSO.GetFolder(TopFolderName)

SubFolderRecursionBU TopFolderObj, wOut
wOut.Range("A:B").EntireColumn.AutoFit
Set FSO = Nothing
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "Done"
End Sub

Sub SubFolderRecursionBU(OfFolder As Object, wOut As Worksheet)

Dim SubFolder As Object
UpdateFolderBU OfFolder.Path, wOut
For Each SubFolder In OfFolder.SubFolders
    SubFolderRecursionBU SubFolder, wOut
    UpdateFolderBU SubFolder.Path, wOut
Next SubFolder
End Sub
    
Sub UpdateFolderBU(strPath As String, wOut As Worksheet)
Dim flPathName As String, strFile As String
Dim wbk As Workbook
Dim lRow As Long

With wOut
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    strFile = Dir(strPath & Application.PathSeparator & "*.xls")
    Do While strFile <> ""
        If strFile <> ActiveWorkbook.Name Then
            flPathName = strPath & Application.PathSeparator & strFile
            Set wbk = Workbooks.Open(Filename:=flPathName)
            wbk.SaveAs Filename:=flPathName & "x", FileFormat:=51
            wbk.Close SaveChanges:=False
            wOut.Cells(lRow, 1).Resize(1, 2).Value = Array(strPath, strFile)
            lRow = lRow + 1
            'Kill flPathName    'Delete the original file
        End If
        strFile = Dir
    Loop
End With
End Sub

Brad

 

[macropod]

Hi Brad,

Your code omits an important test: whether the opened workbook contains any macros. Saving such a workbook in the xlsx format will delete the code. Also, saving the workbooks in the new format changes their date/time stamps. It might be useful to restore those to the original file's values, so that their 'real' age remains apparent.

Cheers
Paul Edstein
[MS MVP - Word]

 

[byundt]

Paul,
You raise a good point about .xlsx file format deleting any macros. I added a macro to test whether any code module contains 3 or more lines of code. If so, then the file is saved as .xlsm. For the Asker's benefit, this will require two steps before running the macro:
[ul]
[li]Must set a reference to Microsoft Visual Basic for Applications Extensibility using Tools...References menu item[/li]
[li]Must also check the box to Trust access to the VBA project object model in worksheet user interface
File...Options...Trust Center...Trust Center Settings...Macro Settings[/li]
[/ul]

I also added code to "restore" the original values of the Creation Date and Last Print Date to the new file. Doing so requires saving the file a second time. Unfortunately, the second save wipes out the Last Save Time property--so there is no point capturing it.

Dim FSO As Object
'****Note: Must set a reference to Microsoft Visual Basic for Applications Extensibility using Tools...References menu item
'****      Must also check the box to Trust access to the VBA project object model in worksheet user interface _
                        File...Options...Trust Center...Trust Center Settings...Macro Settings

Sub BinaryUpdater()
'Opens all .xls files in a folder & subfolders, then saves them in .xlsx format (.xlsm format if they contain macros)
Dim TopFolderName As String
Dim TopFolderObj As Object
Dim wOut As Worksheet
        'Input Path and Search Term
TopFolderName = Application.GetOpenFilename("Excel Files (*.xls), *.xls", _
        Title:="Pick any file in desired folder, then click 'Open' button.")
If TopFolderName = "False" Then Exit Sub
TopFolderName = Left(TopFolderName, InStrRev(TopFolderName, Application.PathSeparator) - 1)

Set wOut = ActiveSheet

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set FSO = CreateObject("Scripting.FileSystemObject")
With wOut
    .Range("A1:B1").Value = Array("Path", "Workbook")
End With
Set TopFolderObj = FSO.GetFolder(TopFolderName)

SubFolderRecursionBU TopFolderObj, wOut
wOut.Range("A:B").EntireColumn.AutoFit
Set FSO = Nothing
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "Done"
End Sub

Function ContainsVBA(wb As Workbook) As Boolean
Dim vbProj As Object
Dim vbComp As VBComponent
Dim n As Long
Set vbProj = wb.VBProject
For Each vbComp In vbProj.VBComponents
    n = vbComp.CodeModule.CountOfLines
    If n > 2 Then
        ContainsVBA = True
        Exit Function
    End If
Next
End Function

Sub SubFolderRecursionBU(OfFolder As Object, wOut As Worksheet)

Dim SubFolder As Object
UpdateFolderBU OfFolder.Path, wOut
For Each SubFolder In OfFolder.SubFolders
    SubFolderRecursionBU SubFolder, wOut
    UpdateFolderBU SubFolder.Path, wOut
Next SubFolder
End Sub
    
Sub UpdateFolderBU(strPath As String, wOut As Worksheet)
Dim flPathName As String, sCreate As String, strFile As String
Dim vPrint As Variant
Dim wbk As Workbook
Dim lRow As Long

With wOut
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    strFile = Dir(strPath & Application.PathSeparator & "*.xls")
    Do While strFile <> ""
        If strFile <> ActiveWorkbook.Name Then
            flPathName = strPath & Application.PathSeparator & strFile
            Set wbk = Workbooks.Open(Filename:=flPathName)
            On Error Resume Next
                'Capture properties from newly opened workbook, then apply those properties to new workbook. _
                    Can't meaningfully apply the Last Save Time property, because saving the file will wipe it out.
            sCreate = wbk.BuiltinDocumentProperties("Creation Date")
            vPrint = Nothing
            vPrint = wbk.BuiltinDocumentProperties("Last Print Date")
            On Error GoTo 0
            If ContainsVBA(wbk) Then
                wbk.SaveAs Filename:=flPathName & "m", FileFormat:=52   'save as .xlsm
            Else
                wbk.SaveAs Filename:=flPathName & "x", FileFormat:=51   'save as .xlsx
            End If
            wbk.BuiltinDocumentProperties("Creation Date") = sCreate
            If Not IsEmpty(vPrint) Then
                wbk.BuiltinDocumentProperties("Last Print Date") = vPrint
            End If
            wbk.Save    'Must resave the workbook with the "restored" properties
            wbk.Close SaveChanges:=False
            wOut.Cells(lRow, 1).Resize(1, 2).Value = Array(strPath, strFile)
            lRow = lRow + 1
            'Kill flPathName    'Delete the original file
        End If
        strFile = Dir
    Loop
End With
End Sub

Brad

 

[macropod]

Hi Brad,

You don't need the complications of a reference to 'Microsoft Visual Basic for Applications Extensibility', or the associated function. Instead, you could use:

            If wbk.HasVBProject Then
                wbk.SaveAs Filename:=flPathName & "m", FileFormat:=52   'save as .xlsm
            Else
                wbk.SaveAs Filename:=flPathName & "x", FileFormat:=51   'save as .xlsx
            End If

As for the file's date/time stamp, I was thinking of what one sees in Windows Explorer. The code for that would be something like:

Dim oItem As Object, StrDtTm As String
StrDtTm = FileDateTime(strFile)
' Reset the new file's Date/Time stamp.
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set oItem = FSO.GetFile(wbk.FullName)
On Error Resume Next
If IsDate(StrDtTm) Then
  If oItem.DateLastModified <> StrDtTm Then oItem.DateLastModified = StrDtTm
End If

Cheers
Paul Edstein
[MS MVP - Word]

 

[byundt]

Paul,
The Workbook.HasVBProject property is a good improvement. It requires Excel 2007 or later, but that shouldn't be a problem if a person is trying to update to one of the XML file formats.

The FSO File object suggestion is easily implemented because the code already uses FSO for folder recursion. But the .DateLastModified and .DateCreated properties are read-only in Excel 2007 & 2010.

Brad