1
votes

I'm having a problem assigning VBA generated ActiveX checkboxes to a class module. When a user clicks a button, the goal of what I am trying to achieve is: 1st - delete all the checkboxes on the excel sheet; 2nd - auto generate a bunch of checkboxes; 3rd - assign a class module to these new checkboxes so when the user subsequently clicks one of them, the class module runs.

I've borrowed heavily from previous posts Make vba code work for all boxes

The problem I've having is that the 3rd routine (to assign a class module to the new checkboxes) doesn't work when run subsequently to the first 2 routines. It runs fine if run standalone after the checkboxes have been created. From the best I can tell, it appears VBA isn't "releasing" the checkboxes after they have been created to allow the class module to be assigned.

The below code is the simplified code that demonstrates this problem. In this code, I use a button on "Sheet1" to run Sub RunMyCheckBoxes(). When button 1 is clicked, the class module did not get assigned to the newly generated checkboxes. I use button 2 on "Sheet1" to run Sub RunAfter(). If button 2 is clicked after button 1 has been clicked, the checkboxes will be assigned to the class module. I can't figure out why the class module won't be assigned if just the first button is clicked. Help please.

Module1: Public mcolEvents As Collection

Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
    Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
    Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Call SetCBAction("Sheet1")
End Sub

Sub DeleteAllCheckboxesOnSheet(SheetName As String)
Dim obj As OLEObject
For Each obj In Sheets(SheetName).OLEObjects
    If TypeOf obj.Object Is MSForms.CheckBox Then
        obj.Delete
    End If
Next
End Sub

Sub InsertCheckBoxes(SheetName As String, CellRow As Double, CellColumn As Double, CBName As String)
Dim CellLeft As Double
Dim CellWidth As Double
Dim CellTop As Double
Dim CellHeight As Double
Dim CellHCenter As Double
Dim CellVCenter As Double

CellLeft = Sheets(SheetName).Cells(CellRow, CellColumn).Left
CellWidth = Sheets(SheetName).Cells(CellRow, CellColumn).Width
CellTop = Sheets(SheetName).Cells(CellRow, CellColumn).Top
CellHeight = Sheets(SheetName).Cells(CellRow, CellColumn).Height
CellHCenter = CellLeft + CellWidth / 2
CellVCenter = CellTop + CellHeight / 2
With Sheets(SheetName).OLEObjects.Add(classtype:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=CellHCenter - 8, Top:=CellVCenter - 8, Width:=16, Height:=16)
    .Name = CBName
    .Object.Caption = ""
    .Object.BackStyle = 0
    .ShapeRange.Fill.Transparency = 1#
End With
End Sub

Sub SetCBAction(SheetName)
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets(SheetName).OLEObjects
    If TypeName(o.Object) = "CheckBox" Then
        Set cCBEvents = New clsActiveXEvents
        Set cCBEvents.mCheckBoxes = o.Object
        mcolEvents.Add cCBEvents
    End If
Next
End Sub


Sub RunAfter()
Call SetCBAction("Sheet1")
End Sub

Class Module (clsActiveXEvents): Option Explicit

Public WithEvents mCheckBoxes As MSForms.CheckBox

Private Sub mCheckBoxes_click()
MsgBox "test"
End Sub

UPDATE: On further research, there is a solution posted in the bottom answer here: Creating events for checkbox at runtime Excel VBA

Apparently you need to force Excel VBA to run on time now: Application.OnTime Now ""

Edited lines of code that works to resolve this issue:

Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
    Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
    Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Application.OnTime Now, "SetCBAction" '''This is the line that changed
End Sub

And, with this new formatting:

Sub SetCBAction() ''''no longer passing sheet name with new format
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets("Sheet1").OLEObjects '''''No longer passing sheet name with new format
    If TypeName(o.Object) = "CheckBox" Then
        Set cCBEvents = New clsActiveXEvents
        Set cCBEvents.mCheckBoxes = o.Object
        mcolEvents.Add cCBEvents
    End If
Next
End Sub
1
Found the solution in another post. Edited original post above with solution. Apparently need to force VBA to run on time now "Application.OnTime Now"user6544548
lol, I just figured it out myself. The problem is that Ole Server is creating the controls outside of the VBA.user6432984
doesn't make much sense to me, i'd try a DoEvents before, just to let Excel finish its work. OLE Objects are quite slow. You could also set the collection and class events while creating objects, instead of doing it after : With Sheets(SheetName).OLEObjects.Add (...) : Set cCBEvents.mCheckBoxes = .object , etc... ?Patrick Lepelletier
Thank you Thomas. The "why" behind this helps so I know how to not run into it again :)user6544548

1 Answers

0
votes

If OLE objects suit your needs then I'm glad you've found a solution.

Are you aware, though, that Excel's Checkbox object could make this task considerably simpler ... and faster? Its simplicity lies in the fact that you can easily iterate the Checkboxes collection and that you can access its .OnAction property. It is also easy to identify the 'sender' by exploiting the Evaluate function. It has some formatting functions if you need to tailor its appearance.

If you're after something quick and easy then the sample below will give you an idea of how your entire task could be codified:

Public Sub RunMe()
    Const BOX_SIZE As Integer = 16
    Dim ws As Worksheet
    Dim cell As Range
    Dim cbox As CheckBox
    Dim i As Integer, j As Integer
    Dim boxLeft As Double, boxTop As Double

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    'Delete checkboxes
    For Each cbox In ws.CheckBoxes
        cbox.Delete
    Next

    'Add checkboxes
    For i = 1 To 10
        For j = 1 To 2
            Set cell = ws.Cells(i, j)
            With cell
                boxLeft = .Width / 2 - BOX_SIZE / 2 + .Left
                boxTop = .Height / 2 - BOX_SIZE / 2 + .Top
            End With
            Set cbox = ws.CheckBoxes.Add(boxLeft, boxTop, BOX_SIZE, BOX_SIZE)
            With cbox
                .Name = "CB" & i & j
                .Caption = ""
                .OnAction = "CheckBox_Clicked"
            End With
        Next
    Next
End Sub
Sub CheckBox_Clicked()
    Dim sender As CheckBox

    Set sender = Evaluate(Application.Caller)
    MsgBox sender.Name & " now " & IIf(sender.Value = 1, "Checked", "Unchecked")
End Sub