It has been a royal pain that MSForm controls are missing simple events such as MouseOver
and Blur
, and I find myself often having a complex system of MouseMove
events to achieve these for hover effects and other stylings.
To solve this issue I've created two class modules EventListenerEmitter
and EventListenerItem
.
Listening for the events
The UserForm stores the EventListnerEmitter
using WithEvents
so that it can then listen for raised events. The UserForm also has to pass itself as a parameter into a method named AddEventListnerAll
, that is where the controls and form are stored.
Private WithEvents Emitter As EventListnerEmitter
Private Sub UserForm_Activate()
Set Emitter = New EventListnerEmitter
Emitter.AddEventListnerAll Me
End Sub
You can listen for all events in one event handler EmittedEvent
(see the example below).
Private Sub Emitter_EmittedEvent(Control As Object, ByVal EventName As String, ByRef EventParameters As Scripting.Dictionary)
'Select statements are really handy working with these events
Select Case True
'Change color when mouseover, for a fun hover effect :)
Case EventName = "MouseOver" And TypeName(Control) = "CommandButton"
Control.BackColor = 9029664
'Don't forget to change it back!
Case EventName = "MouseOut" And TypeName(Control) = "CommandButton"
Control.BackColor = 8435998
End Select
End Sub
You can also listen just to specific events as well.
Private Sub Emitter_Focus(Control As Object)
'CHANGE BORDER COLOR FOR TEXTBOX TO A LIGHT BLUE
If TypeName(Control) = "TextBox" Then
Control.BorderColor = 16034051
End If
End Sub
Private Sub Emitter_Blur(Control As Object)
'CHANGE BORDER COLOR BACK TO A LIGHT GREY
If TypeName(Control) = "TextBox" Then
Control.BorderColor = 12434877
End If
End Sub
EventListenerEmitter
This is the main entry point, and its purpose is to create and hold an array of the EventListenerItems
and to be the mediator between the Userform and the EventListenerItems
.
The Userform and each of its controls are passed through the function AddEventListner
which are then stored in the array EventList() As New EventListnerItem
. This invokes a method in EventListnerItem
also named AddEventListner
(this step is to have a WithEvents
on that specific control).
Here is the code for EventListnerEmitter
(minus a helper function IsArrayEmpty
).
'ARRAY OF ALL THE DIFFERENT EVENT ListenerS FOR EVERY USERFORM CONTROL +FORM ITSELF
Private EventList() As New EventListenerItem
'ALL CURRENT POSSIBLE EVENTS THAT CAN BE EMITTED. NOTE, EMITTEDEVENT IS SENT FOR ALL!
Public Event EmittedEvent(ByRef Control As Object, ByVal EventName As String, ByRef EventParameters As Scripting.Dictionary)
Public Event Click(ByRef Control As Object)
Public Event DblClick(ByRef Control As Object, ByRef Cancel As MSForms.ReturnBoolean)
Public Event KeyUp(ByRef Control As Object, ByRef KeyCode As MSForms.ReturnInteger, ByRef Shift As Integer)
Public Event KeyDown(ByRef Control As Object, ByRef KeyCode As MSForms.ReturnInteger, ByRef Shift As Integer)
Public Event MouseOver(ByRef Control As Object)
Public Event MouseOut(ByRef Control As Object)
Public Event MouseMove(ByRef Control As Object, ByRef Shift As Integer, ByRef X As Single, ByRef Y As Single)
Public Event Focus(ByRef Control As Object)
Public Event Blur(ByRef Control As Object)
Public Event Change(ByRef Control As Object)
'***********************************************************************************
' PUBLIC METHODS
'***********************************************************************************
'CALLED BY EVENTLISTENERCOLLECTION CLASS - MAIN ENTRYWAY OF EMITTING ALL EVENTS
Public Sub EmitEvent(ByRef Control As Object, ByVal EventName As String, ByRef EventParameters As Scripting.Dictionary)
'EVENT RAISED FOR ALL EVENTS. THIS IS A WAY FOR THE USER TO COLLECT FROM A SINGLE LOCATION.
RaiseEvent EmittedEvent(Control, EventName, EventParameters)
'SPECIFIC EVENTS PER OBJECT-TYPE
Select Case EventName
Case "Click"
RaiseEvent Click(Control)
Case "DblClick"
RaiseEvent DblClick(Control, EventParameters("Cancel"))
Case "KeyUp"
RaiseEvent KeyUp(Control, EventParameters("KeyCode"), EventParameters("Shift"))
Case "KeyDown"
RaiseEvent KeyDown(Control, EventParameters("KeyCode"), EventParameters("Shift"))
Case "MouseOver"
RaiseEvent MouseOver(Control)
Case "MouseOut"
RaiseEvent MouseOut(Control)
Case "Focus"
RaiseEvent Focus(Control)
Case "Blur"
RaiseEvent Blur(Control)
Case "MouseMove"
RaiseEvent MouseMove(Control, EventParameters("Shift"), EventParameters("X"), EventParameters("Y"))
End Select
End Sub
'MUST CALL THIS IF YOU WANT TO programmatically SET CONTROL! OTHERWISE, EVENT'S WILL BE OFF!
Public Sub SetFocusToControl(ByRef Control As Object)
'If the user was to set focus through VBA then this code will fall apart considering
'it is unaware of that event occurring.
If Not Control Is Nothing Then
Control.setFocus
EmitEvent Control, "Focus", Nothing
End If
End Sub
'ADD EVENT ListenerS ON SPECIFIC CONTROLS - ALSO CALLED BY AddEventListenerAll
Public Sub AddEventListener(ByRef Control As Object)
'Events are stored in a private EventListenerItem array
If IsArrayEmpty(EventList) Then
ReDim EventList(0 To 0)
Else
ReDim Preserve EventList(0 To UBound(EventList) + 1)
End If
'CALL AddEventListener IN EventListenerItem. THIS IS KEPT IN
EventList(UBound(EventList)).AddEventListener Control, Me
End Sub
'ADD EVENT Listener TO ALL CONTROLS INCLUDING THE FORM
Public Sub AddEventListenerAll(ByRef Form As Object)
AddEventListener Form
Dim Ctrl As MSForms.Control
For Each Ctrl In Form.Controls
AddEventListener Ctrl
Next Ctrl
End Sub
EventListenerItem
This class contains one control only, and stores that control under the appropriate WithEvents
variable.
Additionally, it stores a reference to the emitter class Private WithEvents pEmitter As EventListenerEmitter
.
As this control has events it will call EmitEvent
from the EventListenerEmitter
class, where it will then raise the appropriate events.
All controls will be listening for these events to then store whether or not it is the current hovered or focused control. This is how I'm able to then raise my custom events hover
and blur
.
I've broken this class up into sections for readability.
Private Variables
'SET FROM AddEventListener - NEEDED TO EMIT EVENT BACK TO IT.
Private WithEvents pEmitter As EventListenerEmitter
'CONTROLS THAT HAVE THE EVENTS CURRENTLY
Private WithEvents Form As MSForms.UserForm
Private WithEvents Txt As MSForms.Textbox
Private WithEvents Lbl As MSForms.Label
Private WithEvents Btn As MSForms.CommandButton
Private WithEvents Cmb As MSForms.ComboBox
Private WithEvents Frm As MSForms.Frame
'PROPERTIES OF SPECIFIC CONTROL
Private pControl As Object 'Used for comparison
Private IsHoveredControl As Boolean
Private IsFocusedControl As Boolean
Public Functions
Only one public function. It's called from EventListenerEmitter
class.
'ONLY PUBLIC METHOD. CALLED FROM EVENTListener CLASS MODULE
Public Sub AddEventListener(ByRef ControlOrForm As Object, ByRef Emitter As EventListenerEmitter)
'CAPTURE THE EMITTER CLASS. WILL USE THIS TO EMIT EVENTS FROM EACH CONTROL
Set pEmitter = Emitter
'USED TO COMPARE CHECK IF IT IS THE CONTROL TRIGGERING THE EVENT
Set pControl = ControlOrForm
'SET CONTROL(OR FORM) BASED ON IT'S TYPE
Select Case TypeName(ControlOrForm)
Case "CommandButton"
Set Btn = ControlOrForm
Case "ComboBox"
Set Cmb = ControlOrForm
Case "Frame"
Set Frm = ControlOrForm
Case "Label"
Set Lbl = ControlOrForm
Case "TextBox"
Set Txt = ControlOrForm
Case Else
If IsUserform(ControlOrForm) Then
Set Form = ControlOrForm
End If
End Select
End Sub
Private helper functions
'CALLED ON MOUSEMOVE EVENT, THIS IS A WAY OF CREATING A MOUSEOVER AND MOUSEOUT EVENT
Private Sub CheckIfHoveredControl()
If Not IsHoveredControl Then
IsHoveredControl = True
pEmitter.EmitEvent pControl, "MouseOver", Dict()
End If
End Sub
'CALLED ON MOUSEMOVE EVENT, THIS IS A WAY OF CREATING A MOUSEOVER AND MOUSEOUT EVENT
Private Sub CheckIfFocusedControl()
If Not IsFocusedControl Then
If TypeName(pControl) = "Frame" Then
pEmitter.SetFocusToControl pControl.ActiveControl
Else
IsFocusedControl = True
pEmitter.EmitEvent pControl, "Focus", Dict()
End If
End If
End Sub
'CHECK TO SEE IF OBJ IS A USERFORM
Private Function IsUserform(ByRef Obj As Object) As Boolean
If TypeOf Obj Is MSForms.UserForm Then
IsUserform = True
End If
End Function
'SIMPLE DICTIONARY FACTORY - USED TO PASS EVENT PARAMETERS BACK TO EMITTER
Private Function Dict(ParamArray KeyValue() As Variant) As Scripting.Dictionary
'CHECK IF THERE IS EVEN PARAMETERS
If Not ArrayCount(KeyValue) Mod 2 = 0 Then
Debug.Print "Function Dict() requires an even amount of key value arguments." _
& " Only provided " & ArrayCount(KeyValue)
Exit Function
End If
Set Dict = New Scripting.Dictionary
Dim Index As Long
For Index = LBound(KeyValue) To UBound(KeyValue) Step 2
Dict.Add KeyValue(Index), KeyValue(Index + 1)
Next Index
End Function
'USED WITH Dict To SEE IF THERE ARE AN EVEN AMOUNT OF PARAMETERS
Private Function ArrayCount(ByVal SourceArray As Variant) As Long
ArrayCount = UBound(SourceArray) - LBound(SourceArray) + 1
End Function
Event Listener
This is so that each control can check if it is the current hovered or focused control and store that information. This is used to then raise custom events.
' ONCE AN EVENT HAS EMMITED, EACH EVENTListenerITEM WILL LISTEN FOR THAT EVENT
Private Sub pEmitter_EmittedEvent(ByRef Control As Object, ByVal EventName As String, ByRef EventParameters As Scripting.Dictionary)
'CREATE A MOUSEOVER MOUSEOUT EVENTS
Select Case EventName
Case "MouseOver"
If pControl.Name <> Control.Name And IsHoveredControl Then
IsHoveredControl = False
pEmitter.EmitEvent pControl, "MouseOut", Dict()
End If
Case "Focus"
If pControl.Name <> Control.Name And IsFocusedControl Then
IsFocusedControl = False
pEmitter.EmitEvent pControl, "Blur", Dict()
ElseIf pControl.Name = Control.Name And IsFocusedControl = False Then
IsFocusedControl = True
End If
End Select
End Sub
Events Per control
'------------------------------------------------------------------------
' USERFORM
'------------------------------------------------------------------------
Private Sub Form_Click()
pEmitter.EmitEvent pControl, "Click", Dict()
End Sub
Private Sub Form_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
pEmitter.EmitEvent pControl, "DblClick", Dict("Cancel", Cancel)
End Sub
Private Sub Form_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfHoveredControl
pEmitter.EmitEvent pControl, "MouseMove", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Form_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseDown", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Form_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseUp", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
'------------------------------------------------------------------------
' COMMAND BUTTON
'------------------------------------------------------------------------
Private Sub Btn_Click()
pEmitter.EmitEvent pControl, "Click", Dict()
End Sub
Private Sub Btn_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
pEmitter.EmitEvent pControl, "DblClick", Dict("Cancel", Cancel)
End Sub
Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfHoveredControl
pEmitter.EmitEvent pControl, "MouseMove", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Btn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfFocusedControl
pEmitter.EmitEvent pControl, "MouseUp", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Btn_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseDown", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Btn_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
CheckIfFocusedControl
pEmitter.EmitEvent pControl, "KeyUp", Dict("KeyCode", KeyCode, "Shift", Shift)
End Sub
Private Sub Btn_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
pEmitter.EmitEvent pControl, "KeyDown", Dict("KeyCode", KeyCode, "Shift", Shift)
End Sub
'------------------------------------------------------------------------
' LABEL
'------------------------------------------------------------------------
Private Sub Lbl_Click()
pEmitter.EmitEvent pControl, "Click", Dict()
End Sub
Private Sub Lbl_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
pEmitter.EmitEvent pControl, "DblClick", Dict("Cancel", Cancel)
End Sub
Private Sub Lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfHoveredControl
pEmitter.EmitEvent pControl, "MouseMove", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub lbl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseDown", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub lbl_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseUp", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
'------------------------------------------------------------------------
' Frame
'------------------------------------------------------------------------
Private Sub Frm_Click()
pEmitter.EmitEvent pControl, "Click", Dict()
End Sub
Private Sub Frm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
pEmitter.EmitEvent pControl, "DblClick", Dict("Cancel", Cancel)
End Sub
Private Sub Frm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfHoveredControl
pEmitter.EmitEvent pControl, "MouseMove", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Frm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfFocusedControl 'FRAME DOESN'T TAKE FOCUS BUT ACTIVE CONTROL IN FRAME DOES
pEmitter.EmitEvent pControl, "MouseDown", Dict()
End Sub
Private Sub Frm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseUp", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
'------------------------------------------------------------------------
' Textbox
'------------------------------------------------------------------------
Private Sub Txt_Click()
pEmitter.EmitEvent pControl, "Click", Dict()
End Sub
Private Sub Txt_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
pEmitter.EmitEvent pControl, "DblClick", Dict("Cancel", Cancel)
End Sub
Private Sub Txt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfHoveredControl
pEmitter.EmitEvent pControl, "MouseMove", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Txt_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CheckIfFocusedControl
pEmitter.EmitEvent pControl, "MouseUp", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Txt_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
pEmitter.EmitEvent pControl, "MouseDown", Dict("Button", Button, "Shift", Shift, "X", X, "Y", Y)
End Sub
Private Sub Txt_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
CheckIfFocusedControl
pEmitter.EmitEvent pControl, "KeyUp", Dict("KeyCode", KeyCode, "Shift", Shift)
End Sub
Private Sub Txt_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
pEmitter.EmitEvent pControl, "KeyDown", Dict("KeyCode", KeyCode, "Shift", Shift)
End Sub
This has worked for my overall needs to this point and I like how simple it is to use; however, I feel like there are better design patterns out there than what I currently have that are more flexible for change.
At this point, I only have a small list of events that I'm emitting and already it can be quite a bit of code to maintain. I would love any suggestion as I'm always looking to improve on best practices and writing clean code.
Here is my Github Repository in case you need the full code.
EmitEvent Control, "Focus", ""
. You should use Nothing in place of the vbNullString but I would probably just makeEventParameters
optional. \$\endgroup\$