Macro to convert .xls to .xlsx crashes Excel

Question

My goal is to convert a directory full of .xls files to .xlsx files while preserving embedded images. An automated solution is required because the intended set of files is several hundred. My test set has 532 .xls files. Opening the files one at a time and saving them does work, but is obviously tedious and I'd prefer to automate.

To accomplish this I've tried using Office File Converter, which tells me that none of the files could be converted. Cheers Microsoft.

I've also tried several macro suggestions. They all seem to end with:

"Microsoft Excel has stopped working"

I have not been able to determine why it crashes (help with where to look for useful logs would be great, EventViewer doesn't appear to contain anything of immediate value to me). At first I thought it was opening the files, then I read it might be closing the files. (It seems others have experienced this).

Running an open with xlRepairData does not appear to make a difference.

Set wbk = Workbooks.Open(Filename:=strPath & strFile, CorruptLoad:=xlRepairData)

xlExtractData runs great but also strips out the images, not the desired behaviour!

Set wbk = Workbooks.Open(Filename:=strPath & strFile, CorruptLoad:=xlExtractData)

Then I created a batch of brand new .xls files with a picture of a bunny and kitten in them and duplicated it until I had >50 files. Running this test set opened and closed repetitively just fine. AH-HAH!

I'm now under the impression that it is the files I'm trying to open causing the issue. I have narrowed down one in particular which I can open manually in "protected view" as Excel deems it exceptionally suspicious. Unfortunately any macro attempt to open it results in

"Microsoft Excel has stopped working"

I've seen that a lot recently.

Unfortunately I cannot share the specific file as it contains data I'm not allowed to share, and re-saving the file to strip private data will likely remove the error condition. (Suggestions on how to recreate the condition in a new file would also be useful).

I've tried modifying both of the proposed solutions found here. Excel crashes. Also occasionally showing this Run-time error:

"Run-time error '-2147021892 (80070bbc)': Office has detected a problem with this file. To help protect your computer this file cannot be opened."

I've attempted to skip the files when an error is detected, this also ends in disaster - Excel crashes. Is there a correct way to abort the .Open operation that caused an error?

Sub ConvertToXlsx()
    Dim strPath As String
    Dim strFile As String
    Dim wbk As Workbook

    strPath = "C:\Test1\"
    strFile = Dir(strPath & "*.xls")
    On Error GoTo NextFile:
    Do While strFile <> ""
        If Right(strFile, 3) = "xls" Then
            Set wbk = Workbooks.Open(Filename:=strPath & strFile)
            'Save would go here
            wbk.Close SaveChanges:=False
            'Deleting the .xls file after would be a nice touch
        End If
NextFile:
        strFile = Dir
    Loop
End Sub

I'm not sure how to effectively use this solution instead:

 Application.ProtectedViewWindows.Open Filename:=fName
 Application.ActiveProtectedViewWindow.Edit

Is there a good block of code to run through a directory and open any .xls file? It should handle errors gracefully and not totally collapse Excel. Perhaps it's able to check the compatibility of the file before attempting .Open? Is Excel just the wrong tool for the job?

Quick config information:
Windows 8.1 Pro - Excel 2013
Windows 10 - Excel 2013

Thanks in advance for any sanity granting assistance. :)

---

My workaround:

I installed LibreOffice 5 and ran it from the command line.
{install_dir}\program\soffice --headless --convert-to xlsx:"Calc MS Excel 2007 XML" {filename}.xls This either works, and the xlsx file is created, or it fails... silently. I used the following windows batch script to iterate through the folder of xls files.

@echo off

set soffice="C:\Program Files\LibreOffice 5\program\soffice"
for %%v in (*.xls) do (
    %soffice% --headless --convert-to xlsx:"Calc MS Excel 2007 XML" "%%v"
    if not exist "%%~nv.xlsx" (
        echo "ERROR: %%~nv"
    ) else (
        echo "***deleting %%v"
        del "%%v"
    )
)

Once the script had finished there were 214 files that would not be converted by LibreOffice, these seem to have no problem being opened via an Excel macro (I tested by running the Open->Close code above). So now the solution proposed and any of the solutions I'd been trying to adapt should work. Will update once confirmed.

Answer 1

OK; so the following may work for you. As stated, the files are being deleted after being saved. As a result - if it does error, hopefully you just need to run the macro again (or deal with the error producing file - which should be the first (*.xls) file in the folder)

Sub ConvertXLStoXLSX()
    Dim sFolder As String: sFolder = "P:\Test"
    Dim wbOpen As Workbook, sFullName As String

    On Error GoTo ExitSub
    Application.ScreenUpdating = False
    For Each Item In EnumerateFiles(sFolder)
        sFullName = sFolder & "\\" & Item
        Set wbOpen = GetWorkBook(sFullName)
        Debug.Print wbOpen.Name
        Application.DisplayAlerts = False
            On Error Resume Next
                wbOpen.SaveAs FileName:=sFullName & "x", FileFormat:=xlOpenXMLWorkbook
                wbOpen.Close False
            On Error GoTo ExitSub
            If Len(Dir$(sFullName & "x")) > 0 Then Kill (sFullName)
        Application.DisplayAlerts = True
    Next Item

ExitSub:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Function EnumerateFiles(sFolder As String) As Variant
    Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder As Object: Set objFolder = objFSO.GetFolder(sFolder)
    Dim objFile As Object, V() As String

    For Each objFile In objFolder.Files
        If Right(objFile.Name, 4) = ".xls" Then
            If IsArrayAllocated(V) = False Then
                ReDim V(0)
            Else
                ReDim Preserve V(UBound(V) + 1)
            End If
            V(UBound(V)) = objFile.Name
        End If
    Next objFile

    EnumerateFiles = V
End Function

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)
End Function

Public Function GetWorkBook(ByVal sFullName As String, Optional ReadOnly As Boolean) As Workbook
    Dim sFile As String: sFile = Dir(sFullName)
    On Error Resume Next
        Set GetWorkBook = Workbooks(sFile)
        If GetWorkBook Is Nothing Then Set GetWorkBook = Workbooks.Open(sFullName, ReadOnly:=ReadOnly)
        If GetWorkBook Is Nothing Then
            Dim wbPVW As ProtectedViewWindow
            Set wbPVW = Application.ProtectedViewWindows.Open(sFullName).Edit
            Set GetWorkBook = wbPVW.Workbook
        End If
    On Error GoTo 0
End Function