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
