Excel修复后ActiveX命令按钮误转图片的逆向修复及代码优化咨询

我有一个Excel启用宏工作簿，包含数十个用于运行各类宏的ActiveX控件命令按钮。近期因Windows/Excel更新、或工作簿无响应触发Excel修复后，ActiveX控件损坏，所有命令按钮被转换为图片，完全失去功能。
这类问题已有公开记录，但现有答复均只提供了删除.EXD文件避免问题复发的方案，未涉及修复已保存的损坏文件的方法。我们在发现按钮问题前已经在文件中新增了大量宏和数据表，退回旧版本重构的成本远高于修复本次损坏带来的问题。
损坏后我发现各工作表中的Sub过程仍完整保留，原命令按钮的名称会变为转换后图片的名称（例如对应Private Sub CommandButton1_Click()的图片名称就是CommandButton1）。
我编写了如下代码可实现批量修复，对其他遇到同类问题的用户可能有参考价值，但目前存在两个核心问题需要解决：

• 无法从转换后的图片中提取原ActiveX控件的Caption、字体、字号等属性，现有CreateButton过程需要硬编码各按钮的样式和标题
• CodeInserter过程不知道如何搜索工作表VBA对象中指定Sub（例如"Private Sub CommandButton1_Click()"）的内部代码，判断指定调用语句（例如Call updateCostsFromLookupLists）是否存在，不存在则自动插入
  希望获得提取原按钮属性的可行方法，以及现有代码的优化建议。

遍历所有选中工作表并存入数组 #

Option Explicit

Sub RepairMissingButtons()
    Dim a As Long, S As Long
    Dim selShArray() As Worksheet
    
    S = 0
   'For Each selSh In ActiveWindow.SelectedSheets put into array
    For a = 1 To ActiveWindow.SelectedSheets.count
        S = S + 1
        ReDim Preserve selShArray(1 To S)
        Set selShArray(S) = ActiveWindow.SelectedSheets(S)
    Next a
    
    Call LoopThroughImages(selShArray())
End Sub

遍历选中工作表内的所有形状，识别被转换为图片的命令按钮 #

注意：工作表内其他图片也会被同步转换

Sub LoopThroughImages(ByRef selectedArr() As Worksheet)
    'Adapted from: https://exceloffthegrid.com/vba-code-to-insert-move-delete-and-control-pictures/
    Dim shp As Shape
    Dim ws As Worksheet
    Dim arr
    Dim x, y, w, h, z, imgName, tlc
    Dim btn As Button
    Dim btnObj
    Dim shName As Variant
    
    For Each shName In selectedArr()
        Set ws = Worksheets(shName.name)
        With ws
            ws.Select  '.Select seems to be necessary: if multiple sheets are selected at once, unable to delete the picture using .Activate
            For Each shp In ws.Shapes
                If shp.Type = msoPicture Then
                    arr = GetImageProperties(shp.name)
                    x = arr(1)
                    y = arr(2)
                    w = arr(3)
                    h = arr(4)
                    z = arr(5)
                    imgName = arr(6)
                    tlc = arr(7)
        
                    Call CreateButton(x, y, w, h, imgName) 'sub to create ActiveX command button
                    
            '    Alternate option to creating new ActiveX command button is to create a new Form Control Button
    '                Set btn = ws.Buttons.Add(x, y, w, h)
    '                btn.OnAction = "Success"
    '                btn.Caption = imgName
                    
                    shp.Delete  'delete the underlying picture image that was created by Excel repair
                End If
            Next shp
            If ws.Shapes.count = 0 And Left(ws.name, 2) <> "x_" Then
                Call CreateButton(371.25, 786, 105.75, 33.75, "CommandButton1")
                Call CreateButton(337.5, 786, 105.75, 33.75, "CommandButton2")
                Call CreateButton(435.75, 786, 105.75, 33.75, "CommandButton3")
                Call CreateButton(305.25, 786, 105.75, 33.75, "CommandButton4")
            End If
        End With
    Next shName
End Sub

从图片中提取属性的代码 #

目前无法提取原按钮的Caption、字体、字号属性，我认为这些信息可能在按钮转图片时已经丢失：

Function GetImageProperties(name As String)
    Dim myImage As Shape
    Dim ws As Worksheet
    Dim arr(1 To 7) As String
    
    Set ws = ActiveSheet
    Set myImage = ws.Shapes(name)
    arr(1) = myImage.Top
    arr(2) = myImage.Left
    arr(3) = myImage.width
    arr(4) = myImage.Height
    arr(5) = myImage.ZOrderPosition
    arr(6) = myImage.name
    arr(7) = myImage.TopLeftCell   
 
    GetImageProperties = arr
End Function

创建新的ActiveX命令按钮代码 #

使用从图片提取的属性创建新的ActiveX命令按钮，目前需要硬编码各按钮丢失的标题、背景色、字体、字号等属性，希望找到从原图片提取这些信息的方法：

Sub CreateButton(cellTop, cellLeft, cellwidth, cellheight, btnName)

    Dim Obj As Object
    Dim shName As String
    Dim code As String
    Dim innerCode As String
    Dim searchCode As String

    'create button
    Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=CSng(cellLeft), Top:=CSng(cellTop), width:=CSng(cellwidth), Height:=CSng(cellheight))
    Obj.name = btnName
    shName = ActiveSheet.name
    With Obj.Object
        Select Case shName
            Case "x_Key"
                .Font.name = "Bookman Old Style"
                .Font.Bold = False
                Select Case btnName
                    Case "CommandButton1"
                        .Caption = "Create New Kit"
                        .Font.Size = 26
                        .BackColor = RGB(255, 255, 153) 'yellow
                    Case "CommandButton2"
                        .Caption = "Update"
                    Case "CommandButton3"
                        .Caption = "Start New Merge"
                        .Font.Size = 14
                        .BackColor = RGB(192, 255, 192) 'green
                    Case "CommandButton4"
                        .Caption = "Edit or Delete Kit"
                        .Font.Size = 14
                        .BackColor = RGB(255, 192, 255) 'pink
                End Select
            Case "x_Merge"
                .Font.name = "Bookman Old Style"
                .Font.Bold = False
                Select Case btnName
                    Case "OpenMergeUFBtn"
                        .Caption = "Start New Merge"
                        .Font.Size = 24
                        .BackColor = RGB(255, 255, 153) 'yellow
                End Select
            Case "x_PhysicalInventory"
                .Font.name = "Calibri"
                .Font.Bold = False
                .Font.Size = 11
                .BackColor = RGB(255, 255, 153) 'yellow
                Select Case btnName
                    Case "CommandButton1"
                        .Caption = "Update From InvCount"
                    Case "CommandButton2"
                        .Caption = "Update Orders Matrix from Lookup Lists"
                    Case "CommandButton3"
                        .Caption = "Update Uniques"
                End Select
            Case "x_ControlPanel"
                .Font.name = "Calibri"
                .Font.Bold = False
                .Font.Size = 11
                .BackColor = RGB(255, 255, 153) 'yellow
                Select Case btnName
                    Case "CommandButton1"
                        .Caption = "Import POS Inventory"
                    Case "CommandButton2"
                        .Caption = "Create Kits"
                    Case "CommandButton3"
                        .Caption = "Start New Merge"
                    Case "CommandButton4"
                        .Caption = "Update Uniques"
                    Case "CommandButton5"
                        .Caption = "Import SLS Catalog"
                    Case "CommandButton6"
                        .Caption = "Edit or Delete Kit"
                        .BackColor = RGB(255, 192, 255) 'pink
                    Case "CommandButton7"
                        .Caption = "Create Order Log"
                    Case "CommandButton8"
                        .Caption = "POS Import"
                    Case "CommandButton9"
                        .Caption = "Update Physical Inv"
                    Case "CommandButton10"
                        .Caption = "Update From InvCount"
                    Case "vendSheetBtn"
                        .Caption = "Create Vendor Sheets"
                End Select
            Case "x_Uniques"
                .Font.name = "Calibri"
                .Font.Bold = False
                .Font.Size = 11
                .BackColor = RGB(255, 255, 153) 'yellow
                Select Case btnName
                    Case "UpdateUniquesBtn"
                        .Caption = "Update Uniques"
                End Select
            Case "x_Template"
                .Font.name = "Adobe Fangsong Std R"
                .Font.Bold = False
                .Font.Size = 14
                .BackColor = RGB(255, 255, 153) 'yellow
                Select Case btnName
                    Case "ClearPricesBtn" 'CommandButton4
                        .Caption = "Clear Pricing"
                        .BackColor = RGB(255, 192, 255) 'pink
                    Case "PosCostBtn" 'CommandButton2
                        .Caption = "POS Data"
                    Case "LookupListBtn" 'CommandButton1
                        .Caption = "LookupList"
                    Case "HtmlBtn" 'CommandButton3
                        .Caption = "HTML"
                End Select
            Case Else
                .Font.name = "Adobe Fangsong Std R"
                .Font.Bold = False
                .Font.Size = 14
                .BackColor = RGB(255, 255, 153) 'yellow
                If Left(shName, 2) <> "x_" Then
                    innerCode = "  'from ClassUpdateCosts module" & vbCrLf
                    Select Case btnName
                        Case "CommandButton4", "ClearPricesBtn"
                            .Caption = "Clear Pricing"
                            .BackColor = RGB(255, 192, 255) 'pink
                            innerCode = innerCode & "    Call deletePricesFromClassSheet"
                        Case "CommandButton2", "PosCostBtn"
                            .Caption = "POS Data"
                            innerCode = innerCode & "    Call updateCostsFromPOSInventory"
                        Case "CommandButton1", "LookupListBtn"
                            .Caption = "LookupList"
                            innerCode = innerCode & "    Call updateCostsFromLookupLists"
                        Case "CommandButton3", "HtmlBtn"
                            .Caption = "HTML"
                            innerCode = innerCode & "    Call updateClassesFreightLaborWebHTML"
                    End Select
                    searchCode = "Private Sub " & btnName & "_Click()"
                    code = CodeBuilder(btnName, innerCode)
                    Call CodeInserter(ActiveSheet, code, searchCode)
                End If
        End Select
    End With
End Sub

VBA代码注入相关代码 #

部分场景下我需要向工作表VBA对象中注入缺失代码，如果搜索完整代码匹配度不足，遇到同名Sub（例如Sub CommandButton1_Click()）时会报代码歧义错误，因此目前仅搜索Sub头部。我了解可以使用ProcBodyLine、ProcCountLines、ProcOfLine、ProcStartLine等属性实现同名Sub内部指定调用代码的存在性校验，不存在则插入到Sub内部，但暂时无法调试成功：

Function CodeBuilder(btnName, innerCode)
    Dim code As String
    code = "Private Sub " & btnName & "_Click()" & vbCrLf
    code = code & innerCode & vbCrLf
    code = code & "End Sub"
    CodeBuilder = code
End Function

Sub CodeInserter(wsName As Worksheet, code As String, searchCode As String)
    Dim existingCode As String
    Dim Found As Boolean
 'add macro at the end of the sheet module
    With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        If .CountOfLines <> 0 Then
            existingCode = .Lines(1, .CountOfLines)
            If InStr(existingCode, searchCode) > 0 Then Found = True Else Found = False
        End If
        If Found = False Or .CountOfLines = 0 Then
            .InsertLines .CountOfLines + 1, code
        End If
    End With
End Sub

内容的提问来源于stack exchange，提问作者mrSteveW