I have an Excel macro enabled workbook which contains dozens of ActiveX Control command buttons used to run various macros. Recently, either due to a Windows or Excel update, or an unresponsive workbook that went into Excel Repair, the ActiveX Controls became corrupted and the command buttons were all converted to images and ceased to function.
This issue has been documented and described here: Microsoft Excel ActiveX Controls Disabled? and ActiveX controls changing to pictures (Excel/VBA)
However the responses and accepted answers all point to how to fix the problem from reoccurring: delete existing .EXD files, not how to reverse the damage that was done in the original file after the Repair version had been saved. In our case, we added many new macros and many additional sheets of data before the problem with the command buttons was noticed. So going back to a previous version and rebuilding the file is more problematic than reversing the damage that was done by the repair.
I found that despite the corruption, the Subs on the individual Sheets remain intact, and the name of the existing CommandButton became the name of the image after corruption (such as Private Sub CommandButton1_Click() ... the name of the image matched the name of the command button: CommandButton1.
I came up with the following code which might be helpful to others, but would like to know if there is a better way to extract the original ActiveX control "Caption" that existed before the corruption. Currently the "CreateButton" Sub below requires hard-coding which sheets contain each button, the style I want for each button, and the appropriate caption.
Is there a way to extract this data from the image and add it to the array in the Function GetImageProperties?
Is it possible to capture the "Caption" or "Font" or "Font Size" data from the Command Button?
For the Sub CodeInserter, is there a way to search within the Sheet's VBA Object for the Sub's title (ex: "Private Sub CommanButton1_Click()"), then look for matching InnerCode (ex: Call updateCostsFromLookupLists); if the InnerCode does not exist within the sub, add it to the sub?
I also have a lot to learn with coding, so if anyone wants to suggest better ways to achieve the result: open to any suggestions on how to improve my code.
Loop through all selected sheets and add worksheets to array:
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
Loop through Shapes within each of the selected worksheets to find the command buttons that were converted to images (caution: if other images are on the sheet they'll be converted too):
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
Below is where I'm extracting the data from the Image. Is it possible to capture the "Caption" or "Font" or "Font Size" data from the Command Button? I think this may have disappeared when button was converted to an image.
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
Using the properties extracted from the Image, create a new ActiveX Command button. Unfortunately my approach requires hard-coding in, for each worksheet and each button within each sheet: the name of Captions, BackColor, Fonts, and Font-Sizes lost from corruption. Is there a way to extract any of this from original image?
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
In some cases I wanted to inject missing code into the Worksheet's VBA Object. First by building the code and then inserting. I found that if I searched for the code in it's entirety and it was not an exact match, the macro would quit and give an Ambiguous Code error if it encountered an existing sub with the same name (such as Sub CommandButton1_Click()), so I just searched for the header.
It would be helpful to know how to search within a Sub with the same named header to see if the Call I need within the sub already exists and if not (see innerCode), add it within the Sub. I believe this might be possible using ProcBodyLine, ProcCountLines, ProcOfLine, ProcStartLine ('https://learn.microsoft.com/en-us/office/vba/language/reference/visual-basic-add-in-model/properties-visual-basic-add-in-model#procbodyline) but having difficulty making that work:
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
Any suggestions on improving the code is appreciated!
