userform control events for controls added during runtime

[Jon von der Heyden]

Hi

I am using table driven forms controls on userforms. E.g.:

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	UI Name	MultiPage Parent	Page Parent	Control	Name	Top	Left	Height	Width	Caption	Tag	ControlTipText	SpecialEffect	WordWrap	MultiLine	BorderStyle	BorderColor	BackColor	BackStyle	ForeColor	ColumnCount	ColumnWidths	ListStyle	MultiSelect	Sort	Filter	Primary	Source	Click	Right-Click	Double-Click	View	Edit
2	CustomerHeader	mpMain	1	Forms.Label.1	lblCustomerID	0	1	12	54	Customer ID		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	TRUE
3	CustomerHeader	mpMain	1	Forms.Label.1	lblCustomerName	0	55	12	110	Customer Name		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
4	CustomerHeader	mpMain	1	Forms.Label.1	lblTradingName	0	165	12	110	Trading Name		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
5	CustomerHeader	mpMain	1	Forms.Label.1	lblLegal Name	0	275	12	110	Legal Name		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
6	CustomerHeader	mpMain	1	Forms.Label.1	lblAddress1	0	385	12	100	Address 1			0	TRUE		1	6	12566463							FALSE	TRUE	FALSE
7	CustomerHeader	mpMain	1	Forms.Label.1	lblAddress2	0	485	12	100	Address 2			0	TRUE		1	6	12566463							FALSE	TRUE	FALSE
8	CustomerHeader	mpMain	1	Forms.Label.1	lblCity	0	585	12	75	City		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
9	CustomerHeader	mpMain	1	Forms.Label.1	lblPostCode	0	660	12	60	Post Code		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
10	CustomerHeader	mpMain	1	Forms.Label.1	lblRegion	0	720	12	75	Region		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
11	CustomerHeader	mpMain	1	Forms.Label.1	lblCountry	0	795	12	75	Country		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
12	CustomerHeader	mpMain	1	Forms.Label.1	lblWebsite	0	870	12	75	Website			0	TRUE		1	6	12566463							FALSE	TRUE	FALSE
13	CustomerHeader	mpMain	1	Forms.Label.1	lblIndustry	0	945	12	65	Industry		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
14	CustomerHeader	mpMain	1	Forms.Label.1	lblActive	0	1010	12	45	Active		Click to Sort	0	TRUE		1	6	12566463							TRUE	TRUE	FALSE
15	CustomerHeader	mpMain	1	Forms.ListBox.1	lbxCustomerHeader	12	0	200	1056			Right-click for contextual menu	0			1	6	16777215			13	54;110;110;110;100;100;75;60;75;75;75;65;45	0	0
16	CustomerHeader	mpMain	1	Forms.Label.1	lblPrimaryContact	217	1	12	85	> Primary Contact		Click to see Primary Contact details	0	TRUE		0		16777215	0	16711680
17	CustomerHeader	mpMain	1	Forms.Label.1	lblCommercialContact	217	86	12	85	> Commercial Contact		Click to see Commercial Contact details	0	TRUE		0		16777215	0	16711680
18	CustomerHeader	mpMain	1	Forms.CommandButton.1	cbtAddEdit	239	1	19	48	Add/Edit		Click to Add or Edit Customer						16777215
UI

I use the following (work in progress) function to add the controls to the userform (usually added to page or frame).

Public Function AddControls(ByVal objTarget As Object, ByVal strUiName As String)
    Dim rngControls As Excel.Range, rngProperties As Excel.Range
    Dim rngControl As Excel.Range, rngProperty As Excel.Range
    Dim objControl As Object
    
    With shtFormUI
        Set rngControls = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
    End With
    
    For Each rngControl In rngControls
        With rngControl
            If .Offset(0, -3).Value = strUiName Then
                Set objControl = objTarget.Controls.Add(.Value)
                Set rngProperties = Intersect(shtFormUI.Range("E:X"), .EntireRow)
                For Each rngProperty In rngProperties
                    With rngProperty
                        If .Value <> "" Then
                            Call CallByName(objControl, shtFormUI.Cells(1, .Column).Value, VbLet, .Value)
                        End If
                    End With
                Next rngProperty
                If TypeName(objControl) = "ListBox" Then
                    'testing only - retrieve records using SQL recordset
                    objControl.List = Sheet1.Range("A2:M3").Value
                End If
            End If
        End With
    Next rngControl
End Function

Now I need a means of trapping the controls events. I thought I could use a class, e.g.:
cFormEvents

Option Explicit


Public WithEvents lblLabel As MSForms.Label
Public WithEvents tbxTextBox As MSForms.TextBox
Public WithEvents cbxComboBox As MSForms.ComboBox
Public WithEvents lbxListBox As MSForms.ListBox
Public WithEvents cbtCommandButton As MSForms.CommandButton


Private Sub lblLabel_Click()
    Dim strProcName As String
    
    On Error Resume Next
        strProcName = Application.VLookup(lblLabel.Object.Name, shtFormUI.Range("E:AC"), 29, False)
    On Error GoTo 0
    
    If strProcName <> "" Then
        Call Application.Run(ThisWorkbook.Name & "!" & strProcName)
    End If
End Sub

It seems I cannot reference the controls because I they are added at runtime. For the given example, I want to run whatever procedure name appears for lblPrimaryContact in column AC (click event). So in my userform module I instantiate the class, but I get an error when I try and reference the control:

Set m_clsFormEvents.lblLabel = Me.lblPrimaryContact

Error is "method or data member not found".

Can anyone suggest an alternative method to grab the click event for the control added at runtime?

 

[mikerickson]

By "circular reference", I assume that you mean that each member of a clsRTControls collection has that collection as a Public property.

That end of stuff, I don't really understand and let passing out of scope deal with it. What run-time features might I see by improperly terminating these classes.

 

[Kyle123]

By circular reference I mean that the RTControls class holds a reference to each RTControl object, which in turn holds a reference back to the RTControls class. This means that the garbage collector cannot resolve the reference hence the object resources are never released. There's a better description here: Dealing with Circular References

There are a couple of ways around the issue, you could use something like weak references - so just store a pointer to the object, but it's a bit in depth, it's much easier to write a dispose method to explicitly resolve the references in order. In any normal circumstances, simply letting the object go out of scope would be fine, however an object is only released when there are no further references to it - in this case there will always be a reference - VBA's garbage collector isn't advanced enough to resolve these on its own. So the resources will not be released until excel closes.

For small scale projects, this may not be much of a issue, but if you have a lot of large objects then memory usage will continue to climb for each you add and you'll eventually run out of memory. You can easily test whether you have circular reference since the terminate routine of the relevant classes will not fire (since they aren't terminated) - so if you put a debug.print in, it will never print.

 

[mikerickson]

Good to know. Thanks for the reference.

 

[mikerickson]

I've been working on this and ...
One of the problems with custom userform objects is that they don't have Enter, Exit or Before/After Update events.
I think I've found a partial work-around.

This version of clsRTControl and clsRTControls adds Key Down, Press and Up events and Mouse Down, Move and Up.

The clsRTControls object has soEnter and soExit events. (think Sort of Enter)

In clsRTControls, the MouseMove, MouseDown and KeyDown events have been coded to detect when the focus has changed. And fire soExit or soEnter.

with Focus in an RT control:
user clicks or tabs the focus into an rtControl, both soEnter and soExit will fire
user clicks into a design time control, no soExit event fires, the native Enter event fires for the design time control
user tabs into a design time control, soExit and native Enter will fire.

with Focus in a design time control.
user clicks into a RT control, both native Exit & soEnter fire
user tabs into an RT control, native Exit event only
user tabs or clicks into a different design time control, native Exit and native Enter fire.

The .SetFocus method won't fire soEnter or soExit.
But a .MoveFocusTo method has been added to the userform that will fire soEnter or soExit, if appropriate.

in clsRTControl code module

Option Explicit
' in class clsRTControl

Rem control properties
Public RTControl As MSForms.Control
Public WithEvents RTLabel As MSForms.Label
Public WithEvents RTListBox As MSForms.ListBox
Public WithEvents RTTextBox As MSForms.TextBox
Public RTParent  As clsRTControls

Rem other properties
Public Index As Long

Rem event declarations to pass to clsRTControls
Event Change(ctrl As MSForms.Control)
Event Click(ctrl As MSForms.Control)
Event DblClick(ctrl As MSForms.Control, ByVal Cancel As MSForms.ReturnBoolean)
Event KeyDown(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Event KeyPress(ctrl As MSForms.Control, ByVal keyAscii As MSForms.ReturnInteger)
Event KeyUp(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Event MouseDown(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Event MouseMove(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Event MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

Property Get Name() As String
    Name = RTControl.Name
End Property

Private Sub Class_Terminate()
    Rem release variables
    Set RTControl = Nothing
    Set RTLabel = Nothing
    Set RTListBox = Nothing
    Set RTTextBox = Nothing
    Set RTParent = Nothing
End Sub

Rem events triggered by controls
Private Sub RTLabel_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Click(RTControl)
End Sub
Private Sub RTLabel_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub
Private Sub RTLabel_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseDown(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseMove(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTLabel_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseUp(RTControl, Button, Shift, x, y)
End Sub

Private Sub RTListBox_Change()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub
Private Sub RTListBox_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Click(RTControl)
End Sub
Private Sub RTListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub
Private Sub RTListbox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Set RTParent.EventedRTControl = Me
    RaiseEvent KeyDown(RTControl, KeyCode, Shift)
End Sub
Private Sub RTListbox_KeyPress(ByVal keyAscii As MSForms.ReturnInteger)
    Set RTParent.EventedRTControl = Me
    RaiseEvent KeyPress(RTControl, keyAscii)
End Sub
Private Sub RTListBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseDown(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTListBox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseMove(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseUp(RTControl, Button, Shift, x, y)
End Sub


Private Sub RTTextBox_Change()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub
Private Sub RTTextBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub
Private Sub RTTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Set RTParent.EventedRTControl = Me
    RaiseEvent KeyDown(RTControl, KeyCode, Shift)
End Sub
Private Sub RTTextBox_KeyPress(ByVal keyAscii As MSForms.ReturnInteger)
    Set RTParent.EventedRTControl = Me
    RaiseEvent KeyPress(RTControl, keyAscii)
End Sub
Private Sub RTTextBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Set RTParent.EventedRTControl = Me
    RaiseEvent KeyUp(RTControl, KeyCode, Shift)
End Sub

Private Sub RTTextBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseDown(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTTextBox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseMove(RTControl, Button, Shift, x, y)
End Sub
Private Sub RTTextBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseUp(RTControl, Button, Shift, x, y)
End Sub

in clsRTControls code module

Option Explicit
' in class module clsRTControls

Rem collections
Public Item As Collection
Public RT_Controls As Collection

Rem properties
Public Parent As Object

Rem object to receive events passed up by clsRTControl
Public WithEvents EventedRTControl As clsRTControl
Dim ExitedControl As MSForms.Control
Public EventsDisabled As Boolean

Rem event declarations to be passed to userform
Event DblClick(ctrl As MSForms.Control, ByVal Cancel As MSForms.ReturnBoolean)
Event Change(ctrl As MSForms.Control)
Event Click(ctrl As MSForms.Control)
Event KeyDown(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Event KeyPress(ctrl As MSForms.Control, ByVal keyAscii As MSForms.ReturnInteger)
Event KeyUp(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Event MouseDown(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Event MouseMove(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Event MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Event soEnter(ctrl As MSForms.Control)
Event soExit(ctrl As MSForms.Control)

Property Get Count() As Long
    Count = Item.Count
End Property

Function Add(progID As Variant, Optional Name As String = "", Optional isVisible As Boolean = True) As MSForms.Control
    Dim newControl As MSForms.Control
    Dim newRTControl As clsRTControl

    If TypeName(progID) = "String" Then
        If Name = vbNullString Then
            Set newControl = Parent.Controls.Add(progID, visible:=isVisible)
        Else
            Set newControl = Parent.Controls.Add(bstrProgid:=progID, Name:=Name, visible:=isVisible)
        End If
    Else
        Set newControl = progID
    End If
    
    If Not (newControl Is Nothing) Then
        Set newRTControl = New clsRTControl
        With newRTControl
            Set .RTParent = Me
            Set .RTControl = newControl
            Select Case TypeName(.RTControl)
                Case "Label"
                    Set .RTLabel = newControl
                Case "ListBox"
                    Set .RTListBox = newControl
                Case "TextBox"
                    Set .RTTextBox = newControl
                Case Else
                    Set newRTControl = Nothing
            End Select
        End With
    End If
    If newRTControl Is Nothing Then
        MsgBox "Bad progID"
        Parent.Controls.Remove newControl.Name
        Set newControl = Nothing
    Else
        RT_Controls.Add Item:=newRTControl, Key:=newControl.Name
        Item.Add Item:=newControl, Key:=newControl.Name
        newRTControl.Index = Item.Count
    End If
    Set Add = newControl
End Function

Private Sub EventedRTControl_Change(ctrl As MSForms.Control)
    If EventsDisabled Then Exit Sub
    RaiseEvent Change(ctrl)
End Sub
Private Sub EventedRTControl_Click(ctrl As MSForms.Control)
    If EventsDisabled Then Exit Sub
    RaiseEvent Click(ctrl)
End Sub
Private Sub EventedRTControl_DblClick(ctrl As MSForms.Control, ByVal Cancel As MSForms.ReturnBoolean)
    If EventsDisabled Then Exit Sub
    RaiseEvent DblClick(ctrl, Cancel)
End Sub

Private Sub EventedRTControl_KeyDown(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If EventsDisabled Then Exit Sub
    Dim ctrlGoingTo As MSForms.Control
    Dim Trigger As Boolean
    'Trigger = True
    
    RaiseEvent KeyDown(ctrl, KeyCode, Shift)
    Trigger = CBool(KeyCode)
    Rem is enter/exit
    Select Case KeyCode
        Case vbKeyReturn
            Select Case TypeName(ctrl)
                Case "TextBox", "RefEdit"
                    Trigger = Trigger Xor ctrl.EnterKeyBehavior
                Case "ComboBox"
                    Trigger = True
                Case Else
                    Trigger = False
            End Select
        Case vbKeyTab
            If TypeName(ctrl) = "TextBox" Then
                Trigger = Trigger Xor ctrl.TabKeyBehavior
            End If
        Case vbKeyUp, vbKeyDown
            Rem problem to find next control
            Trigger = False
        Case Else
            Trigger = False
    End Select
    
    If Trigger Then
        If CBool(Shift) Then
            Set ctrlGoingTo = PreviousTabStop(ctrl)
        Else
            Set ctrlGoingTo = NextTabStop(ctrl)
        End If
        
        RaiseEvent soExit(ctrl)
        If IsMyControl(ctrlGoingTo) Then
            RaiseEvent soEnter(ctrlGoingTo)
        End If
    End If
    
End Sub

Private Sub EventedRTControl_KeyPress(ctrl As MSForms.Control, ByVal keyAscii As MSForms.ReturnInteger)
    If EventsDisabled Then Exit Sub
    RaiseEvent KeyPress(ctrl, keyAscii)
End Sub
Private Sub EventedRTControl_KeyUp(ctrl As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If EventsDisabled Then Exit Sub
    RaiseEvent KeyUp(ctrl, KeyCode, Shift)
End Sub

Private Sub EventedRTControl_MouseDown(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If EventsDisabled Then Exit Sub
    If ExitedControl.Name <> EventedRTControl.Name Then
        If IsMyControl(ExitedControl) Then
            RaiseEvent soExit(ExitedControl)
        End If
        RaiseEvent soEnter(ctrl)
        RaiseEvent MouseDown(ctrl, Button, Shift, x, y)
    End If
End Sub
Private Sub EventedRTControl_MouseMove(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If EventsDisabled Then Exit Sub
    Set ExitedControl = ReallyActiveControl(Parent)
    RaiseEvent MouseMove(ctrl, Button, Shift, x, y)
End Sub
Private Sub EventedRTControl_MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If EventsDisabled Then Exit Sub
    RaiseEvent MouseUp(ctrl, Button, Shift, x, y)
End Sub

Public Sub MoveFocusTo(ToControl As MSForms.Control, Optional ForceFire As Boolean)
    Dim FromControl As MSForms.Control
    Set FromControl = ReallyActiveControl(Parent)
    
    If (FromControl.Name <> ToControl.Name) Or ForceFire Then
        If IsMyControl(FromControl) Then
            RaiseEvent soExit(FromControl)
        End If
    End If
    
    If (FromControl.Name <> ToControl.Name) Then
        ToControl.SetFocus
    End If
    
    If (FromControl.Name <> ToControl.Name) Or ForceFire Then
        If IsMyControl(ToControl) Then
            RaiseEvent soEnter(ToControl)
        End If
    End If
End Sub

Public Function IsMyControl(ctrl As MSForms.Control) As Boolean
    Dim oneControl As MSForms.Control
    For Each oneControl In Item
        IsMyControl = IsMyControl Or (ctrl.Name = oneControl.Name)
    Next oneControl
End Function

Private Function UFParent(ctrl As MSForms.Control) As Object
    Set UFParent = Parent
End Function


Private Sub Class_Initialize()
    Set Item = New Collection
    Set RT_Controls = New Collection
End Sub

Public Sub Dismiss()
    Dim oneObject As Object
    For Each oneObject In RT_Controls
        Parent.Controls.Remove oneObject.Name
        Set oneObject = Nothing
    Next oneObject
    For Each oneObject In Item
        Set oneObject = Nothing
    Next oneObject
    Set RT_Controls = Nothing
    Set Item = Nothing
End Sub

Private Sub Class_Terminate()
   Debug.Print "class term"
End Sub

Private Function ReallyActiveControl(Container As Object) As MSForms.Control
    Select Case TypeName(Container)
        Case "Frame"
            If Container.ActiveControl Is Nothing Then
                Set ReallyActiveControl = Container
            Else
                Set ReallyActiveControl = ReallyActiveControl(Container.ActiveControl)
            End If
        Case "MultiPage"
            With Container
                With .Pages(.Value)
                    If .ActiveControl Is Nothing Then
                        Set ReallyActiveControl = Container
                    Else
                        Set ReallyActiveControl = ReallyActiveControl(.ActiveControl)
                    End If
                End With
            End With
        Case "Page"
            If Container.ActiveControl Is Nothing Then
                Set ReallyActiveControl = Container.Parent
            Else
                Set ReallyActiveControl = ReallyActiveControl(Container.ActiveControl)
            End If
        Case Else
            Rem container is userform
            If Container.Name = TypeName(Container) Then
                If Container.ActiveControl Is Nothing Then
                    Set ReallyActiveControl = Nothing
                Else
                    Set ReallyActiveControl = ReallyActiveControl(Container.ActiveControl)
                End If
            Else
                Rem container is control
                Set ReallyActiveControl = Container
            End If
    End Select
End Function

Function NextTabStop(ctrl As MSForms.Control) As MSForms.Control
    Const Delimiter As String = ","
    Dim namesArray As Variant, ctrlIndex As Variant, Size As Long
    
    namesArray = Split(TabOrderedControlNames(UFParent(ctrl), Delimiter), Delimiter)
    Size = UBound(namesArray) + 1
    ctrlIndex = Application.Match(ctrl.Name, namesArray, 0)
    If IsNumeric(ctrlIndex) Then
        ctrlIndex = ctrlIndex Mod Size
        Set NextTabStop = UFParent(ctrl).Controls(namesArray(ctrlIndex))
    Else
    
    End If
End Function

Function PreviousTabStop(ctrl As MSForms.Control) As MSForms.Control
    Const Delimiter As String = ","
    Dim namesArray As Variant, ctrlIndex As Variant, Size As Long
    
    namesArray = Split(TabOrderedControlNames(UFParent(ctrl), Delimiter), Delimiter)
    Size = UBound(namesArray) + 1
    
    ctrlIndex = Application.Match(ctrl.Name, namesArray, 0)
    
    If IsNumeric(ctrlIndex) Then
        ctrlIndex = (ctrlIndex - 2 + Size) Mod Size
        Set PreviousTabStop = UFParent(ctrl).Controls(namesArray(ctrlIndex))
    End If
End Function

Function TabOrderedControlNames(ByVal Container As Object, ByRef Delimiter As String) As String
    
    Dim ControlArray As Variant
    Dim oneControl As Variant
    Dim pointer As Long, i As Long, j As Long
    Dim result As String
   
    
    If TypeName(Container) = "MultiPage" Then
        Set Container = Container.Pages(Container.Value)
    End If
    
    If 0 < Container.Controls.Count Then
        ReDim ControlArray(1 To Container.Controls.Count)
        
        For Each oneControl In Container.Controls
            Select Case TypeName(oneControl)
                Case "Image", "Label"
                    Rem non tab stop control types
                Case Else
                    With oneControl
                        If .visible And .Enabled And .TabStop Then
                            If .Parent.Name = Container.Name Then
                                pointer = pointer + 1
                                Set ControlArray(pointer) = oneControl
                            End If
                        End If
                    End With
            End Select
        Next oneControl
        
       
        
        result = vbNullString
        If 0 < pointer Then
            ReDim Preserve ControlArray(1 To pointer)
             Rem sortcontrolarray
             For i = 1 To UBound(ControlArray) - 1
                For j = i + 1 To UBound(ControlArray)
                    If ControlArray(j).TabIndex < ControlArray(i).TabIndex Then
                        Set oneControl = ControlArray(i)
                        Set ControlArray(i) = ControlArray(j)
                        Set ControlArray(j) = oneControl
                    End If
                Next j
             Next i
         
            For Each oneControl In ControlArray
                Select Case TypeName(oneControl)
                Case "Frame"
                    result = result & Delimiter & TabOrderedControlNames(oneControl, Delimiter)
                Case "MultiPage"
                    result = result & Delimiter & TabOrderedControlNames(oneControl.Pages(oneControl.Value), Delimiter)
                Case Else
                    result = result & Delimiter & oneControl.Name
                End Select
            Next oneControl
            result = Mid(result, Len(Delimiter) + 1)
        End If
    End If
    
    If result = vbNullString Then
        If TypeName(Container) = "Page" Then
            result = Container.Parent.Name
        Else
            result = Container.Name
        End If
    End If
    TabOrderedControlNames = result
End Function

That can be used in a userform like this.
It will sum the numbers entered.
If a text box or two is put in the userform at design time, one can see how soEnter and soExit act with design-time controls.

Option Explicit
' in userform code module

Public WithEvents rtNumericTextBoxes As clsRTControls
Public WithEvents rtOperatorLabels As clsRTControls
Public WithEvents rtResultLabels As clsRTControls
Dim ufEventsDisabled As Boolean

Private Sub rtNumericTextBoxes_Change(ctrl As MSForms.Control)
    If ufEventsDisabled Then Exit Sub
    Dim NumVal As Double, DenomVal As Double, Prefix As String
    Dim lblResult As MSForms.Label
    
    ctrl.Tag = CStr(Val(ctrl.Text)): Rem preserve true entry
    
    Rem calculate and display sum
    Prefix = Left(ctrl.Name, 1)
    NumVal = Val(rtNumericTextBoxes.Item(Prefix & "Numerator").Tag)
    DenomVal = Val(rtNumericTextBoxes.Item(Prefix & "Denominator").Tag)
    Set lblResult = rtResultLabels.Item(Prefix & "Result")
    
    lblResult.Caption = "= " & Format((NumVal + DenomVal), "0.000;-0.000")
End Sub

Private Sub rtNumericTextBoxes_KeyPress(ctrl As MSForms.Control, ByVal keyAscii As MSForms.ReturnInteger)
    Rem restrict to numeric entry
    If ufEventsDisabled Then Exit Sub
    Dim newString As String
    
    With ctrl
        newString = Left(.Text, .SelStart) & Chr(keyAscii) & Mid(.Text, .SelStart + .SelLength + 1)
    End With
    keyAscii = -CLng(IsNumeric(newString & "0")) * keyAscii
End Sub

Private Sub rtNumericTextBoxes_soEnter(ctrl As MSForms.Control)
    Rem show full value when has focus
    If ufEventsDisabled Then Exit Sub
    
    Me.EventsDisabled = True
    
    With ctrl
        .Text = .Tag: Rem recall true value
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
    Me.EventsDisabled = False
End Sub

Private Sub rtNumericTextBoxes_soExit(ctrl As MSForms.Control)
    If ufEventsDisabled Then Exit Sub
    Rem show 2 places when not focus
    Me.EventsDisabled = True
    With ctrl
        .Text = Format(Val(.Tag), "#.00;-#.00")
    End With
    Me.EventsDisabled = False
End Sub

Private Sub rtResultLabels_Click(ctrl As MSForms.Control)
    If ufEventsDisabled Then Exit Sub
    Dim Prefix As String
    Prefix = Left(ctrl.Name, 1)
    Me.MoveFocusTo rtNumericTextBoxes.Item(Prefix & "Numerator")
End Sub

Private Sub UserForm_Click()
    
End Sub

Private Sub UserForm_Initialize()
    Dim Size As Long
    Dim i As Long
    Set rtNumericTextBoxes = New clsRTControls
    Set rtOperatorLabels = New clsRTControls
    Set rtResultLabels = New clsRTControls
     Set rtNumericTextBoxes.Parent = Me
     Set rtOperatorLabels.Parent = Me
     Set rtResultLabels.Parent = Me
     
    For i = 0 To 4
        With rtNumericTextBoxes
            With .Add("forms.TextBox.1", Chr(65 + i) & "Numerator", True)
                .Top = 10 + 30 * i: .Left = 10
                .Height = 22: .Width = 75: .Font.Size = 10
                .AutoWordSelect = False
            End With
            With .Add("forms.TextBox.1", Chr(65 + i) & "Denominator", True)
                .Top = 10 + 30 * i: .Left = 97
                .Height = 22: .Width = 75: .Font.Size = 10
                .AutoWordSelect = False
            End With
        End With
        
        With rtOperatorLabels
            With .Add("forms.Label.1", Chr(65 + i) & "Operator", True)
                .Top = 10 + 30 * i: .Left = 86
                .Height = 22: .Width = 10: .Font.Size = 10
                .Caption = "+"
            End With
        End With
        
        With rtResultLabels
            With .Add("forms.Label.1", Chr(65 + i) & "Result", True)
                .Top = 10 + 30 * i: .Left = 97 + 75 + 1
                .Height = 22: .Width = 100
                .Font.Size = 10
                .BorderStyle = fmBorderStyleSingle
                
                .Caption = "="
            End With
        End With
    Next i
End Sub

Private Sub UserForm_Terminate()
    rtNumericTextBoxes.Dismiss: Set rtNumericTextBoxes = Nothing
    rtOperatorLabels.Dismiss: Set rtOperatorLabels = Nothing
    rtResultLabels.Dismiss: Set rtResultLabels = Nothing
End Sub

Sub MoveFocusTo(ctrl As MSForms.Control)
    rtNumericTextBoxes.MoveFocusTo ctrl, ForceFire:=True
    rtOperatorLabels.MoveFocusTo ctrl, ForceFire:=True
    rtResultLabels.MoveFocusTo ctrl, ForceFire:=True
End Sub
Property Get EventsDisabled() As Boolean
    EventsDisabled = ufEventsDisabled
End Property
Property Let EventsDisabled(DisableEvents As Boolean)
    rtNumericTextBoxes.EventsDisabled = DisableEvents
    rtOperatorLabels.EventsDisabled = DisableEvents
    rtResultLabels.EventsDisabled = DisableEvents
    ufEventsDisabled = DisableEvents
End Property

 

[Jon von der Heyden]

Hi Mike

I just wanted to post a "thank you"! Thanks, really, very much! I have built this into my project and it seems to be working swimingly! If you're ever in my neck of the woods I owe you a large beer (or whatever, name your poison)!

 

[Jon von der Heyden]

Hi Mike

Sorry to pull this up again. I'm trying to manage a CommandButton for the first time but it doesn't seem to want to raise the event. I've checked that I have made the updates but for the life of me it triggers. If I substitute the control for a label then it seems to work.

I'm reposting the code but it is largely the same as what you wrote before. I've bolded the command button stuff.

cRTControl

Option Explicit


'control properties
Public RTControl                    As MSForms.Control
Public WithEvents RTLabel           As MSForms.Label
Public WithEvents RTListBox         As MSForms.ListBox
Public WithEvents RTComboBox        As MSForms.ComboBox
Public WithEvents RTTextBox         As MSForms.TextBox
Public WithEvents RTCommandButton   As MSForms.CommandButton
Public WithEvents RTCheckBox        As MSForms.CheckBox
Public RTParent                     As cRTControls


'other properties
Public Index                        As Long


'event declarations to pass to cRTControls
Event Change(ctrl As MSForms.Control)
Event Click(ctrl As MSForms.Control)
Event DblClick(ctrl As MSForms.Control, ByRef Cancel As MSForms.ReturnBoolean)
Event MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Event DropButt*******()


Property Get Name() As String
    Name = RTControl.Name
End Property


'events triggered by controls
Private Sub RTLabel_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Click(RTControl)
End Sub
Private Sub RTLabel_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub


Private Sub RTListBox_Change()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub
Private Sub RTListBox_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Click(RTControl)
End Sub
Private Sub RTListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub
Private Sub RTListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Set RTParent.EventedRTControl = Me
    RaiseEvent MouseUp(RTControl, Button, Shift, X, Y)
End Sub


Private Sub RTComboBox_Change()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub


Private Sub RTTextBox_Change()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub
Private Sub RTTextBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set RTParent.EventedRTControl = Me
    RaiseEvent DblClick(RTControl, Cancel)
End Sub
Private Sub RTTextBox_DropButt*******()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub


Private Sub RTCommandButton_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub


Private Sub RTCheckBox_Click()
    Set RTParent.EventedRTControl = Me
    RaiseEvent Change(RTControl)
End Sub

cRTControls

Option Explicit


'collections
Public Item                         As Collection
Public RT_Controls               As Collection


'properties
Public Parent                       As Object


'object to receive events passed up by cRTControl
Public WithEvents EventedRTControl  As cRTControl


'event declarations to be passed to userform
Event Change(ctrl As MSForms.Control)
Event Click(ctrl As MSForms.Control)
Event DblClick(ctrl As MSForms.Control, ByRef Cancel As MSForms.ReturnBoolean)
Event MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Event DropButt*******()


Property Get Count() As Long
    Count = Item.Count
End Property


Function Add(progID As Variant, Optional Name As String = "", Optional isVisible As Boolean = True) As MSForms.Control
    Dim ctlControl              As MSForms.Control
    Dim ctlRTControl            As cRTControl


    If TypeName(progID) = "String" Then
        If Name = vbNullString Then
            Set ctlControl = Parent.Controls.Add(progID, Visible:=isVisible)
        Else
            Set ctlControl = Parent.Controls.Add(bstrProgid:=progID, Name:=Name, Visible:=isVisible)
        End If
    Else
        Set ctlControl = progID
    End If
    
    If Not (ctlControl Is Nothing) Then
        Set ctlRTControl = New cRTControl
        With ctlRTControl
            Set .RTParent = Me
            Set .RTControl = ctlControl
            Select Case TypeName(.RTControl)
                Case "Label"
                    Set .RTLabel = ctlControl
                Case "ListBox"
                    Set .RTListBox = ctlControl
                Case "ComboBox"
                    Set .RTComboBox = ctlControl
                Case "TextBox"
                    Set .RTTextBox = ctlControl
                Case "CommandButton"
                    Set .RTCommandButton = ctlControl
                Case "CheckBox"
                    Set .RTCheckBox = ctlControl
                Case Else
                    Set ctlRTControl = Nothing
            End Select
        End With
    End If
    
    If ctlRTControl Is Nothing Then
        MsgBox "Bad progID"
        Call Parent.Controls.Remove(ctlControl.Name)
        Set ctlControl = Nothing
    Else
        Call RT_Controls.Add(Item:=ctlRTControl, Key:=ctlControl.Name)
        Call Item.Add(Item:=ctlControl, Key:=ctlControl.Name)
        ctlRTControl.Index = Item.Count
    End If
    
    Set Add = ctlControl
End Function


Private Sub EventedRTControl_Change(ctrl As MSForms.Control)
    RaiseEvent Change(ctrl)
End Sub


Private Sub EventedRTControl_Click(ctrl As MSForms.Control)
    RaiseEvent Click(ctrl)
End Sub


Private Sub EventedRTControl_DblClick(ctrl As MSForms.Control, ByRef Cancel As MSForms.ReturnBoolean)
    RaiseEvent DblClick(ctrl, Cancel)
End Sub


Private Sub EventedRTControl_MouseUp(ctrl As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    RaiseEvent MouseUp(ctrl, Button, Shift, X, Y)
End Sub


Private Sub EventedRTControl_DropButt*******()
    RaiseEvent DropButt*******
End Sub




Private Sub Class_Initialize()
    Set Item = New Collection
    Set RT_Controls = New Collection
End Sub


Public Sub Dispose()
    Dim objControl               As Object
    
    For Each objControl In RT_Controls
        Call objControl.RTParent.Parent.Controls.Remove(objControl.Name) 'Added extra parent to get to the form
        Set objControl = Nothing
    Next objControl
    
    For Each objControl In Item
        Set objControl = Nothing
    Next objControl
    
    Set RT_Controls = Nothing
    Set Item = Nothing
End Sub

I have a function to trawl a table and add controls at runtime:

Private Function AddControls(ByVal objParent As Object, ByVal strUIName As String) As cRTControls
    Dim clsRTcontrols           As cRTControls
    Dim rngControls             As Excel.Range
    Dim rngProperties           As Excel.Range
    Dim rngControl              As Excel.Range
    Dim rngProperty             As Excel.Range
    Dim objControl              As Object
    Dim strType                 As String
    Dim strQuery                As String
    
    Set clsRTcontrols = New cRTControls
    Set clsRTcontrols.Parent = objParent
    
    With shtFormUI
        Set rngControls = Application.Intersect(.Range(m_strControlType), .UsedRange)
    End With
    
    For Each rngControl In rngControls
        With rngControl
            If .Offset(0, -3).Value = strUIName Then
                Set objControl = clsRTcontrols.Add(.Value, Name:=.Offset(0, 1).Value)
                Set rngProperties = Intersect(shtFormUI.Range(m_strControlProperties), .EntireRow)
                For Each rngProperty In rngProperties
                    With rngProperty
                        If Len(.Value) Then
                            Call CallByName(objControl, shtFormUI.Cells(1, .Column).Value, VbLet, .Value)
                        End If
                    End With
                Next rngProperty
                strType = TypeName(objControl)
                If IsNumeric(Application.Match(strType, VBA.Array("ListBox", "ComboBox"), 0)) Then
                    strQuery = shtFormUI.Range(m_strControlSource)(rngControl.Row).Value
                    With m_clsDB
                        objControl.List = TransposeArray(.RunScript(.GetSQL(strQuery)).GetRows())
                    End With
                End If
            End If
        End With
    Next rngControl
    
    Set AddControls = clsRTcontrols
End Function

This is an example of where the controls get added at runtime:

Private Sub BuildContacts()
    If Not m_clsControls Is Nothing Then
        Call m_clsControls.Dispose
        Set m_clsControls = Nothing
    End If
    
    Set m_clsControls = AddControls(Me.fmeResearch, "ResearchContacts")
End Sub

Here's the click event in the userform class:

Private Sub m_clsControls_Click(ctrl As MSForms.Control)    
    '--> Upload contacts
    If ctrl.Name = "cbtUploadContacts" Then
        Call UploadContacts
    End If
End Sub

When I launch the userform the controls get added just fine. All controls except commandbutton are firing off the events (so it's not just the click event). It's literally only the commandbutton that causes a problem. The commandbutton properties are fine too (not disabled or anything like that).

If/When you have time I would be really grateful if you can check. I'll keep fiddling meanwhile and see if I can work anything out.

Cheers
Jon

 

[RoryA]

You appear to be raising a Change event in the Click event of the first class.

 

[Jon von der Heyden]

That's what happens when I copy and paste. Thanks Rory - I feel like a prize idiot now!

Edit: Seems I have done that with the other control events too! Sheesh I need a drink!