dimanche 3 juillet 2016

Use VBA to assign all checkboxes to class module

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




Aucun commentaire:

Enregistrer un commentaire