使用 VBA 将所有复选框分配给类模块

Question

我在将 VBA 生成的 ActiveX 复选框分配给类模块时遇到问题。当用户单击一个按钮时，我要实现的目标是： 1st - 删除 excel 表上的所有复选框； 2nd - 自动生成一堆复选框； 3rd - 为这些新复选框分配一个类模块，这样当用户随后单击其中一个时，类模块就会运行。

我从之前的帖子中大量借鉴Make vba code work for all boxes

我遇到的问题是第三个例程（将类模块分配给新复选框）在前两个例程之后运行时不起作用。如果在创建复选框后独立运行，它运行良好。据我所知，在创建复选框以允许分配类模块后，VBA 似乎并没有“释放”它们。

下面的代码是演示这个问题的简化代码。在这段代码中，我使用“Sheet1”上的一个按钮来运行 Sub RunMyCheckBoxes()。单击按钮 1 时，未将类模块分配给新生成的复选框。我使用“Sheet1”上的按钮 2 来运行 Sub RunAfter()。如果在单击按钮 1 后单击按钮 2，则复选框将分配给类模块。我不知道为什么只单击第一个按钮就不会分配类模块。请帮忙。

模块 1： 公共 mcolEvents 作为集合

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

类模块（clsActiveXEvents）： 显式选项

Public WithEvents mCheckBoxes As MSForms.CheckBox

Private Sub mCheckBoxes_click()
MsgBox "test"
End Sub

更新： 在进一步的研究中，这里的底部答案中发布了一个解决方案： Creating events for checkbox at runtime Excel VBA

显然您现在需要强制 Excel VBA 按时运行： Application.OnTime Now ""

编辑了可解决此问题的代码行：

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

而且，使用这种新格式：

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

Answer 1

如果 OLE 对象满足您的需求，那么我很高兴您找到了解决方案。

但是，您是否知道 Excel 的 Checkbox 对象可以使这项任务变得相当简单......而且速度更快？它的简单性在于您可以轻松地迭代Checkboxes 集合并且可以访问它的.OnAction 属性。通过利用Evaluate 函数也很容易识别“发件人”。如果您需要定制其外观，它具有一些格式化功能。

如果您追求的是快速简单的事情，那么下面的示例将让您了解如何编写整个任务：

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