├── .github └── FUNDING.yml ├── .gitignore ├── App.xlsm ├── LICENSE ├── README.md └── src ├── EventListenerEmitter.cls ├── EventListenerItem.cls ├── TestFormEvents.frm └── TestFormEvents.frx /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | custom: ['https://www.buymeacoffee.com/todar'] 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Excel's Backup copies 2 | ~$*.xl* -------------------------------------------------------------------------------- /App.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-EventListener/e6136e1f9186fbb31d9eedd2e4878619e6062b79/App.xlsm -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Robert Todar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA Userform EventListener 2 | 3 | A very easy way to add event listeners to a userform. 4 | 5 | Buy Me A Coffee 6 | 7 | ## Getting Started 8 | > Importing or copying both **EventListenerEmitter.cls** and **EventListenerItem.cls** is **required** in order to work! 9 | 10 | Here is a basic template, simply add this to a userform. 11 | ```vb 12 | Private WithEvents Emitter As EventListenerEmitter 13 | 14 | Private Sub UserForm_Activate() 15 | Set Emitter = New EventListenerEmitter 16 | Emitter.AddEventListenerAll Me 17 | End Sub 18 | ``` 19 | 20 | That's it, now you can start listening for events! 21 | 22 | ## Listening for the events 23 | 24 | You can listen for all events in one event handler **Emitter_EmittedEvent** or each individual controls events. see the example below. 25 | 26 | ```vb 27 | ' EXAMPLE SHOWING A BASIC WAY OF DOING A HOVER EFFECT 28 | Private Sub Emitter_EmittedEvent(Control As Object, ByVal EventName As EmittedEvent, EventParameters As Collection) 29 | ' Select statements are really handy working with these events in this way. 30 | Select Case True 31 | ' Change color when mouseover, for a fun hover effect :) 32 | Case EventName = MouseOver And TypeName(Control) = "CommandButton" 33 | Control.BackColor = 9029664 34 | 35 | ' Don't forget to change it back! 36 | Case EventName = MouseOut And TypeName(Control) = "CommandButton" 37 | Control.BackColor = 8435998 38 | End Select 39 | End Sub 40 | ``` 41 | 42 | You can also listen just to specific events as well. 43 | 44 | ```vb 45 | Private Sub Emitter_Focus(Control As Object) 46 | ' CHANGE BORDER COLOR FOR TEXTBOX TO A LIGHT BLUE 47 | If TypeName(Control) = "TextBox" Then 48 | Control.BorderColor = 16034051 49 | End If 50 | End Sub 51 | 52 | Private Sub Emitter_Blur(Control As Object) 53 | ' CHANGE BORDER COLOR BACK TO A LIGHT GREY 54 | If TypeName(Control) = "TextBox" Then 55 | Control.BorderColor = 12434877 56 | End If 57 | End Sub 58 | ``` 59 | 60 | Or you can listen to specific events on specific controls 61 | 62 | ```vb 63 | Private Sub Emitter_CommandButtonMouseOver(CommandButton As MSForms.CommandButton) 64 | CommandButton.Backcolor = 9029664 65 | End Sub 66 | 67 | Private Sub Emitter_CommandButtonMouseOut(CommandButton As MSForms.CommandButton) 68 | CommandButton.Backcolor = 8435998 69 | End Sub 70 | ``` 71 | 72 | ## Note 73 | This is in the early stages, so feel free to use it as you wish. Currently, the events emitted are pretty simple: Click, DoubleClick, MouseOver, MouseOut, MouseMove, MouseDown, and MouseUp. 74 | 75 | As I have time I'll be adding more events and seeing if I have any needed improvements. 76 | 77 | Feel free to do a pull request if you added to it or improved it in any way! 78 | 79 | **Also, I've posted this code on codereview. Feel free to make suggestions or improvements there as well!** 80 | -------------------------------------------------------------------------------- /src/EventListenerEmitter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "EventListenerEmitter" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | Option Compare Text 12 | 13 | ' Array of all the different event listeners for every userform control and the form itself 14 | Private EventList() As New EventListenerItem 15 | 16 | ' All the current possible events that can be emitted. 17 | ' Note, EmittedEvent is sent for all events! 18 | Public Event EmittedEvent(ByRef control As Object, ByVal EventType As EmittedEvent, ByRef EventParameters As Collection) 19 | Public Event Click(ByRef control As Object) 20 | Public Event DblClick(ByRef control As Object, ByRef Cancel As MSForms.ReturnBoolean) 21 | Public Event KeyUp(ByRef control As Object, ByRef KeyCode As MSForms.ReturnInteger, ByRef Shift As Integer) 22 | Public Event KeyDown(ByRef control As Object, ByRef KeyCode As MSForms.ReturnInteger, ByRef Shift As Integer) 23 | Public Event MouseOver(ByRef control As Object) 24 | Public Event MouseOut(ByRef control As Object) 25 | Public Event MouseMove(ByRef control As Object, ByRef Shift As Integer, ByRef X As Single, ByRef Y As Single) 26 | Public Event Focus(ByRef control As Object) 27 | Public Event Blur(ByRef control As Object) 28 | Public Event Change(ByRef control As Object) 29 | 30 | ' Events to Labels 31 | Public Event LabelMouseOver(ByRef Label As MSForms.Label) 32 | Public Event LabelMouseOut(ByRef Label As MSForms.Label) 33 | Public Event LabelClick(ByRef Label As MSForms.Label) 34 | Public Event LabelDoubleClick(ByRef Label As MSForms.Label, ByRef Cancel As MSForms.ReturnBoolean) 35 | Public Event LabelMouseMove(ByRef Label As MSForms.Label, ByRef Shift As Integer, ByRef X As Single, ByRef Y As Single) 36 | 37 | ' Events to Textboxes 38 | Public Event TextboxFocus(ByRef Textbox As MSForms.Textbox) 39 | Public Event TextboxBlur(ByRef Textbox As MSForms.Textbox) 40 | Public Event TextboxMouseOver(ByRef Textbox As MSForms.Textbox) 41 | Public Event TextboxMouseOut(ByRef Textbox As MSForms.Textbox) 42 | Public Event TextboxClick(ByRef Textbox As MSForms.Textbox) 43 | Public Event TextboxDoubleClick(ByRef Textbox As MSForms.Textbox, ByRef Cancel As MSForms.ReturnBoolean) 44 | Public Event TextboxMouseMove(ByRef Textbox As MSForms.Textbox, ByRef Shift As Integer, ByRef X As Single, ByRef Y As Single) 45 | 46 | ' Events to CommandButtons 47 | Public Event CommandButtonMouseOver(ByRef CommandButton As MSForms.CommandButton) 48 | Public Event CommandButtonMouseOut(ByRef CommandButton As MSForms.CommandButton) 49 | Public Event CommandButtonClick(ByRef CommandButton As MSForms.CommandButton) 50 | Public Event CommandButtonDoubleClick(ByRef CommandButton As MSForms.CommandButton, ByRef Cancel As MSForms.ReturnBoolean) 51 | Public Event CommandButtonMouseMove(ByRef CommandButton As MSForms.CommandButton, ByRef Shift As Integer, ByRef X As Single, ByRef Y As Single) 52 | 53 | ' Types of events that can occur 54 | Public Enum EmittedEvent 55 | Click 56 | DoubleClick 57 | MouseMove 58 | MouseOut 59 | MouseOver 60 | MouseDown 61 | MouseUp 62 | KeyUp 63 | KeyDown 64 | Focus 65 | Blur 66 | End Enum 67 | 68 | ' Called by EventListenerItem class - main entryway of emitting all events 69 | Public Sub EmitEvent(ByRef control As Object, ByVal EventType As EmittedEvent, Optional ByRef EventParameters As Collection) 70 | ' Event raised for all events. This is a way for the user to collect from a single location. 71 | RaiseEvent EmittedEvent(control, EventType, EventParameters) 72 | 73 | ' Specific events 74 | Select Case EventType 75 | 76 | Case Click 77 | RaiseEvent Click(control) 78 | 79 | Case DoubleClick 80 | RaiseEvent DblClick(control, EventParameters("Cancel")) 81 | 82 | Case KeyUp 83 | RaiseEvent KeyUp(control, EventParameters("KeyCode"), EventParameters("Shift")) 84 | 85 | Case KeyDown 86 | RaiseEvent KeyDown(control, EventParameters("KeyCode"), EventParameters("Shift")) 87 | 88 | Case MouseOver 89 | RaiseEvent MouseOver(control) 90 | 91 | Case MouseOut 92 | RaiseEvent MouseOut(control) 93 | 94 | Case Focus 95 | RaiseEvent Focus(control) 96 | 97 | Case Blur 98 | RaiseEvent Blur(control) 99 | 100 | Case MouseMove 101 | RaiseEvent MouseMove(control, EventParameters("Shift"), EventParameters("X"), EventParameters("Y")) 102 | 103 | End Select 104 | 105 | ' Call the specific control type events 106 | Select Case TypeName(control) 107 | Case "Label" 108 | EmitLabelEvent control, EventType, EventParameters 109 | 110 | Case "Textbox" 111 | EmitTextboxEvent control, EventType, EventParameters 112 | 113 | Case "CommandButton" 114 | EmitCommandButtonEvent control, EventType, EventParameters 115 | 116 | End Select 117 | End Sub 118 | 119 | ' Events for Labels 120 | Private Sub EmitLabelEvent(ByRef Label As MSForms.Label, ByVal EventType As String, ByRef EventParameters As Collection) 121 | Select Case EventType 122 | Case EmittedEvent.Click 123 | RaiseEvent LabelClick(Label) 124 | 125 | Case EmittedEvent.DoubleClick 126 | RaiseEvent LabelDoubleClick(Label, EventParameters("Cancel")) 127 | 128 | Case EmittedEvent.MouseOver 129 | RaiseEvent LabelMouseOver(Label) 130 | 131 | Case EmittedEvent.MouseOut 132 | RaiseEvent LabelMouseOut(Label) 133 | 134 | Case EmittedEvent.MouseMove 135 | RaiseEvent MouseMove(Label, EventParameters("Shift"), EventParameters("X"), EventParameters("Y")) 136 | End Select 137 | End Sub 138 | 139 | ' Events for Textboxes 140 | Private Sub EmitTextboxEvent(ByRef Textbox As MSForms.Textbox, ByVal EventType As String, ByRef EventParameters As Collection) 141 | Select Case EventType 142 | Case EmittedEvent.Blur 143 | RaiseEvent TextboxBlur(Textbox) 144 | 145 | Case EmittedEvent.Focus 146 | RaiseEvent TextboxFocus(Textbox) 147 | 148 | Case EmittedEvent.Click 149 | RaiseEvent TextboxClick(Textbox) 150 | 151 | Case EmittedEvent.DoubleClick 152 | RaiseEvent TextboxDoubleClick(Textbox, EventParameters("Cancel")) 153 | 154 | Case EmittedEvent.MouseOver 155 | RaiseEvent TextboxMouseOver(Textbox) 156 | 157 | Case EmittedEvent.MouseOut 158 | RaiseEvent TextboxMouseOut(Textbox) 159 | 160 | Case EmittedEvent.MouseMove 161 | RaiseEvent MouseMove(Textbox, EventParameters("Shift"), EventParameters("X"), EventParameters("Y")) 162 | End Select 163 | End Sub 164 | 165 | ' Events for CommandButton 166 | Private Sub EmitCommandButtonEvent(ByRef CommandButton As MSForms.CommandButton, ByVal EventType As String, ByRef EventParameters As Collection) 167 | Select Case EventType 168 | Case EmittedEvent.Click 169 | RaiseEvent CommandButtonClick(CommandButton) 170 | 171 | Case EmittedEvent.DoubleClick 172 | RaiseEvent CommandButtonDoubleClick(CommandButton, EventParameters("Cancel")) 173 | 174 | Case EmittedEvent.MouseOver 175 | RaiseEvent CommandButtonMouseOver(CommandButton) 176 | 177 | Case EmittedEvent.MouseOut 178 | RaiseEvent CommandButtonMouseOut(CommandButton) 179 | 180 | Case EmittedEvent.MouseMove 181 | RaiseEvent MouseMove(CommandButton, EventParameters("Shift"), EventParameters("X"), EventParameters("Y")) 182 | End Select 183 | End Sub 184 | 185 | ' MUST CALL THIS IF YOU WANT TO programmatically SET CONTROL! OTHERWISE, EVENT'S WILL BE OFF! 186 | Public Sub SetFocusToControl(ByRef control As Object) 187 | 'If the user was to set focus through VBA then this code will fall apart considering 188 | 'it is unaware of that event occurring. 189 | If Not control Is Nothing Then 190 | control.setFocus 191 | EmitEvent control, Focus 192 | End If 193 | End Sub 194 | 195 | ' ADD EVENT Listeners ON SPECIFIC CONTROLS - ALSO CALLED BY AddEventListenerAll 196 | Public Sub AddEventListener(ByRef control As Object) 197 | ' Events are stored in a private EventListenerItem array 198 | If IsArrayEmpty(EventList) Then 199 | ReDim EventList(0 To 0) 200 | Else 201 | ReDim Preserve EventList(0 To UBound(EventList) + 1) 202 | End If 203 | 204 | 'CALL AddEventListener IN EventListenerItem. THIS IS KEPT IN 205 | EventList(UBound(EventList)).AddEventListener control, Me 206 | End Sub 207 | 208 | 'ADD EVENT Listener TO ALL CONTROLS INCLUDING THE FORM 209 | Public Sub AddEventListenerAll(ByRef Form As Object) 210 | AddEventListener Form 211 | 212 | Dim control As MSForms.control 213 | For Each control In Form.Controls 214 | AddEventListener control 215 | Next control 216 | End Sub 217 | 218 | Private Function IsArrayEmpty(Arr As Variant) As Boolean 219 | '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 220 | ' CPEARSON: http://www.cpearson.com/excel/VBAArrays.htm 221 | ' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE. 222 | ' 223 | ' The VBA IsArray function indicates whether a variable is an array, but it does not 224 | ' distinguish between allocated and unallocated arrays. It will return TRUE for both 225 | ' allocated and unallocated arrays. This function tests whether the array has actually 226 | ' been allocated. 227 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 228 | 229 | Err.Clear 230 | On Error Resume Next 231 | If IsArray(Arr) = False Then 232 | ' we weren't passed an array, return True 233 | IsArrayEmpty = True 234 | End If 235 | 236 | ' Attempt to get the UBound of the array. If the array is 237 | ' unallocated, an error will occur. 238 | Dim ub As Long 239 | ub = UBound(Arr, 1) 240 | If (Err.Number <> 0) Then 241 | IsArrayEmpty = True 242 | Else 243 | '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 244 | ' On rare occasion, under circumstances I cannot reliably replicate, Err.Number 245 | ' will be 0 for an unallocated, empty array. On these occasions, LBound is 0 and 246 | ' UBound is -1. To accommodate the weird behavior, test to see if LB > UB. 247 | ' If so, the array is not allocated. 248 | '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 249 | Err.Clear 250 | Dim LB As Long 251 | LB = LBound(Arr) 252 | If LB > ub Then 253 | IsArrayEmpty = True 254 | Else 255 | IsArrayEmpty = False 256 | End If 257 | End If 258 | End Function 259 | -------------------------------------------------------------------------------- /src/EventListenerItem.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-EventListener/e6136e1f9186fbb31d9eedd2e4878619e6062b79/src/EventListenerItem.cls -------------------------------------------------------------------------------- /src/TestFormEvents.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} TestFormEvents 3 | Caption = "Event Testing" 4 | ClientHeight = 5715 5 | ClientLeft = 120 6 | ClientTop = 450 7 | ClientWidth = 4695 8 | OleObjectBlob = "TestFormEvents.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "TestFormEvents" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | 17 | Option Explicit 18 | 19 | Private WithEvents Emitter As EventListenerEmitter 20 | Attribute Emitter.VB_VarHelpID = -1 21 | 22 | Private Sub UserForm_Activate() 23 | Set Emitter = New EventListenerEmitter 24 | Emitter.AddEventListenerAll Me 25 | End Sub 26 | 27 | ' Command Button Events 28 | Private Sub Emitter_CommandButtonMouseOver(CommandButton As MSForms.CommandButton) 29 | CommandButton.Backcolor = 9029664 30 | End Sub 31 | 32 | Private Sub Emitter_CommandButtonMouseOut(CommandButton As MSForms.CommandButton) 33 | CommandButton.Backcolor = 8435998 34 | End Sub 35 | 36 | ' Textbox Events 37 | Private Sub Emitter_TextboxBlur(Textbox As MSForms.Textbox) 38 | RendorEventLabel Textbox, Blur 39 | 40 | ' CHANGE BORDER COLOR BACK TO A LIGHT GREY 41 | Textbox.BorderColor = 12434877 42 | Textbox.BorderStyle = fmBorderStyleNone 43 | Textbox.BorderStyle = fmBorderStyleSingle 44 | End Sub 45 | 46 | Private Sub Emitter_TextboxFocus(Textbox As MSForms.Textbox) 47 | RendorEventLabel Textbox, Focus 48 | 49 | ' CHANGE BORDER COLOR FOR TEXTBOX TO A LIGHT BLUE 50 | Textbox.BorderColor = 16034051 51 | Textbox.BorderStyle = fmBorderStyleNone 52 | Textbox.BorderStyle = fmBorderStyleSingle 53 | End Sub 54 | 55 | ' Mouse Over/out events 56 | Private Sub Emitter_MouseOut(control As Object) 57 | RendorEventLabel control, MouseOut 58 | End Sub 59 | 60 | Private Sub Emitter_MouseOver(control As Object) 61 | RendorEventLabel control, MouseOver 62 | End Sub 63 | 64 | ' Update form to demo what events are happening 65 | Private Sub RendorEventLabel(control As Object, EventName As EmittedEvent) 66 | Select Case EventName 67 | Case MouseOver 68 | MouseOverLabel.Caption = "MouseOver: " & control.name 69 | 70 | Case MouseOut 71 | MouseOutLabel.Caption = "MouseOut: " & control.name 72 | 73 | Case Focus 74 | FocusLabel.Caption = "Focus: " & control.name 75 | 76 | Case Blur 77 | BlurLabel.Caption = "Blur: " & control.name 78 | End Select 79 | End Sub 80 | 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /src/TestFormEvents.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-EventListener/e6136e1f9186fbb31d9eedd2e4878619e6062b79/src/TestFormEvents.frx --------------------------------------------------------------------------------