excel - 动态创建的表单控件标签上的 MouseMove 事件

Question

我正在尝试在 VBA 中动态创建一个形状，然后为其分配一个鼠标事件，这样如果用户将鼠标移到该形状上，就会触发一个事件。

我在这个论坛和互联网上的其他地方进行了搜索，并意识到形状不能关联事件。解决方法是在顶部添加一个来自控件(如标签)并为其添加一个事件。

由于我是动态创建标签，所以我知道我需要创建一个自定义 Class并定义标签 WithEvents触发事件。我写了下面的代码，但收到错误

"Object does not source automation events".

类定义代码:

'Class name clsEventShape

Public WithEvents evtLabel As Label

Private Sub evtLabel_mousemove()
    MsgBox "Mouse Moved!!"
End Sub

生成形状和标签的代码:

Option Explicit
Option Base 1

Dim Lbl As Label
Dim evtLbl As clsEventShape
Dim Shp As Shape
Dim WS As Worksheet

Public Sub addShape()
    WS = ActiveSheet

    Set Shp = WS.Shapes.addShape(msoShapeRoundedRectangle, 10, 10, 100, 100)

    With Shp
        .Fill.ForeColor.RGB = RGB(Rnd() * 255, Rnd() * 255, Rnd() * 255)
    End With

    evtLbl = New clsEventShape
    Set evtLbl.evtLabel = WS.Controls.Add("Form.Label.1")
    Set Lbl = evtLbl.evtLabel

    With Lbl
        .Left = 10
        .Top = 10
        .Width = 100
        .Height = 100
        .Caption = "Hello"
    End With 
End Sub

Answer 1

mousemove-event 有参数:

Public WithEvents evtLabel As msforms.Label

Private Sub evtLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 MsgBox "Mouse Moved!!"
End Sub

模块中的代码略有更改:

Option Explicit
Option Base 1

Dim Lbl As OLEObject
Dim evtLbl As clsEventShape
Dim Shp As Shape
Dim WS As Worksheet

    Public Sub addShape()
  Set WS = ActiveSheet

    Set Shp = WS.Shapes.addShape(msoShapeRoundedRectangle, 10, 10, 100, 100)

    With Shp
        .Fill.ForeColor.RGB = RGB(Rnd() * 255, Rnd() * 255, Rnd() * 255)
    End With

    Set evtLbl = New clsEventShape
    Set Lbl = WS.OLEObjects.Add("Forms.Label.1")
    Set evtLbl.evtLabel = Lbl.Object
    With Lbl
        .Left = 10
        .Top = 10
        .Width = 100
        .Height = 100
        .Object.Caption = "Hello"
        .Object.BackStyle = fmBackStyleTransparent 'added
     End With
    WS.Shapes(Lbl.Name).Fill.Transparency = 1 'added
End Sub