Событие MouseMove для динамически создаваемой метки элемента управления формы - PullRequest
Новая
       21

Событие MouseMove для динамически создаваемой метки элемента управления формы

0 голосов
/ 29 ноября 2018

Я пытаюсь динамически создать фигуру в VBA, а затем назначить ей событие мыши, чтобы, если пользователь наводит курсор мыши на фигуру, событие вызывалось.

Я искал в этомфорум и в других местах в Интернете, и понял, что формы не могут быть связаны события.Обходной путь - добавить сверху элемент управления from (например, Label) и добавить к нему событие.

Поскольку я динамически создаю метку, я понимаю, что мне нужно создать пользовательский Class и определитьметка WithEvents, чтобы вызвать событие.Я написал код ниже, но получаю сообщение об ошибке

«Объект не генерирует события автоматизации».

Код для определения класса: 

'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

1 Ответ

0 голосов
/ 29 ноября 2018

  • Событие mousemove имеет параметры: 

    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
...