互換モードのExcel（拡張子.xls）を、まとめて「拡張子 .xlsx」に変換

先日は、互換モードのファイルパスを受け取り、以下の拡張子で保存し直すマクロに挑戦した。

「.xlsb」（バイナリー　※指定時のみ）
「.xlsx」（マクロを含まない場合　※自動判別）
「.xlsm」（マクロを含む場合　※自動判別）

infoment.hatenablog.com

今日は、「渡す側」の作成に挑戦する。
f:id:Infoment:20190922151955p:plain

作業用に、このようなシートを作成した。
f:id:Infoment:20190922152118p:plain

フォルダパスを入力するセルには、予め「FolderPath」と命名してある。
バイナリ形式で保存したい場合のため、チェックボックスを設けた。
バイナリ形式に馴染みが無い方のために、リンクも張っておいた。
https://wa3.i-3-i.info/word15089.htmlwa3.i-3-i.info

B1にフォルダパスを入力して「更新」ボタンを押すと、サブフォルダ内を含め全ての互換モードファイル（拡張子 .xls）を探し出し、新しい拡張子で保存し直す。

以下が、今回作成したもの。更新した結果を二次元配列で返す関数とした。

Function UpdateExtension() As Variant

    ' 画面更新の一時停止。
    Application.ScreenUpdating = False
    ' アラートの一時停止。
    Application.DisplayAlerts = False

    ' ファイルシステムオブジェクト。
    ' ※ファイルの存在確認や拡張子取得用。
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダーパスの取得。
    Dim FolderPath As String
        FolderPath = Range("FolderPath").Value
        If Range("FolderPath") = vbNullString Then
            FolderPath = ThisWorkbook.Path
            Application.StatusBar = "フォルダパスが空欄のため、このファイルの保存パスをフォルダパスに設定しました。"
        ElseIf FSO.FolderExists(FolderPath) = False Then
            FolderPath = ThisWorkbook.Path
            Application.StatusBar = "ご指定のフォルダが存在しないため、このファイルの保存パスをフォルダパスに設定しました。"
        End If
    
    ' 指定フォルダーパス下のファイル名取得。
    ' ※サブフォルダ以下も対象。
    Dim arr As Variant
        arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & FolderPath & """ /b /s /a-d").StdOut.ReadAll, vbCrLf), ".")
    
    ' 更新結果を格納するための配列。
    Dim Result() As Variant
    ReDim Result(1 To UBound(arr) + 2, 1 To 2)
    ' 更新結果のラベル。
        Result(1, 1) = "更新前"
        Result(1, 2) = "更新後"
    
    Dim i As Long
    Dim j As Long: j = 2
        For i = 0 To UBound(arr)
            Application.StatusBar = i + 1 & " / " & UBound(arr) + 1 & " 個目を更新中。"
            If FSO.GetExtensionName(arr(i)) = "xls" Then
                Result(j, 1) = arr(i)
                Result(j, 2) = ToNewExtension(CStr(arr(i)), Sheet1.CheckBox1.Value)
                j = j + 1
            End If
        Next

    UpdateExtension = Result

    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Function

更新ボタンをクリックした際の処理。結果をシートに貼り付けている。

Private Sub CommandButton1_Click()
    
    Dim arr() As Variant
        arr = UpdateExtension
        
        Columns("E:F").ClearContents
        Cells(3, "E").Resize(UBound(arr), 2) = arr
    
End Sub