动态创建的表单控件标签上的 MouseMove 事件
MouseMove event on dynamically created Form Control Label
我试图在 VBA 中动态创建一个形状,然后为其分配一个鼠标事件,这样如果用户将鼠标移到该形状上,就会触发一个事件。
我在这个论坛和互联网上的其他地方进行了搜索,发现形状不能关联事件。解决方法是在顶部添加一个 from 控件(如 Label)并向其添加一个事件。
由于我是动态创建标签,我明白我需要创建自定义 Class
并定义标签 WithEvents
来触发事件。我写了下面的代码,但收到错误
"Object does not source automation events".
Class 定义的代码:
'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
鼠标移动事件有参数:
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
我试图在 VBA 中动态创建一个形状,然后为其分配一个鼠标事件,这样如果用户将鼠标移到该形状上,就会触发一个事件。
我在这个论坛和互联网上的其他地方进行了搜索,发现形状不能关联事件。解决方法是在顶部添加一个 from 控件(如 Label)并向其添加一个事件。
由于我是动态创建标签,我明白我需要创建自定义 Class
并定义标签 WithEvents
来触发事件。我写了下面的代码,但收到错误
"Object does not source automation events".
Class 定义的代码:
'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
鼠标移动事件有参数:
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