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?

 

[Jon von der Heyden]

In case anyone is wondering - it seems to work if I use the USerForm controls collection:

Set m_clsFormEvents.lblLabel = Me.Controls("lblPrimaryContact")

Happy days - I think this is much nicer than having to store the event code and write it out each time the control is added... Particularly since I have a few common procs to run on control click and I can use Application.Run to call the proc and populate the arguments...

 

[Kyle123]

Wouldn't it be easier to set the object reference of the events class at the same time as adding them to the userform rather than looping through the form again? - So something like:

            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
					Set m_clsFormEvents = New cFormEvents
					Set m_clsFormEvents.lbxListBox = objControl
					MyEventsCollection.Add m_clsFormEvents
                End If

 

[Jon von der Heyden]

I actually tried that Kyle - but it doesn't even instantiate the class. I *think* it may be because the AddControls function is separate from the UserForm class...

 

[tweedle]

Glad you figured out the referencing.
I have a Q though...
Does "Object" in lblLabel.Object.Name throw an error for you?
Wouldn't lblLabel.Name get the correct attribute for the vlookup?

strProcName = Application.VLookup(lblLabel.Object.Name, shtFormUI.Range("E:AC"), 29, False)

 

[Jon von der Heyden]

Good question! You're absolutely correct. When I finally got the class to work it threw a RT error and I quickly fixed it...

 

[Jon von der Heyden]

Thanks Mike. I am using a collection (well now I am ) - but for starters just to make sure it was working I was testing a single control. The controls are added via a function in a standard module. The trouble was setting the class control object by referring to the control name, e.g.

Set m_clsFormControls.lblLabel = Me.lblPrimaryContact

I didn't have a reference from when the control was added (because it is added via the function in the other module - adding heaps of controls because it is table driven)

It seems I have to use

Set m_clsFormControls.lblLabel = Me.Controls("control.name")

 

[mikerickson]

You can do this by passing the events to the userform. This approach requires two custom classes, clsRTControls, which is a collection of instances of the custom class clsRTControl.
For this example, we are restricting ourselves to TextBoxes, ListBoxes, and Labels. The only events we are using are Change, Click and DblClick
This is the code that goes in clsRTControl. Each kind of control has a Public WithEvents variable of that type. And each of the events for those controls fires one of the custom event listed.

' 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, ByRef Cancel As MSForms.ReturnBoolean)


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

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

when clsRTControl fires an event, the EventedRTControl object in clsRTControls captures that event and, in turn, passes it (and the control which fired the event) back to the userform.

' 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

Rem event declarations to be passed to userform
Event DblClick(ctrl As MSForms.Control, ByRef Cancel As MSForms.ReturnBoolean)
Event Change(ctrl As MSForms.Control)
Event Click(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)
    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 Class_Initialize()
    Set Item = New Collection
    Set RT_Controls = New Collection
End Sub

Private Sub Class_Terminate()
    Dim oneObject As Object
    For Each oneObject In RT_Controls
        oneObject.RTParent.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

This is used by a userform with code like.

' in userform code module
Public WithEvents RunTimeControls As clsRTControls

Private Sub UserForm_Initialize()
    Set RunTimeControls = New clsRTControls
    Set RunTimeControls.Parent = Me
    
    With RunTimeControls
        With .Add("forms.TextBox.1")
            .Height = 22: .Width = 100
            .Top = 5: .Left = 5
            .AutoWordSelect = False
        End With
    
        With .Add("forms.Label.1")
            .Height = 22: .Width = 100
            .Top = 5: .Left = 105
            .BorderStyle = fmBorderStyleSingle
            .Caption = "Made Label"
        End With
        
        With .Add("forms.ListBox.1")
            .Height = 100: .Width = 105
            .Top = 30: .Left = 5
            .AddItem "alpha"
            .AddItem "Beta"
            .AddItem "Gamma"
        End With
    End With
End Sub


Private Sub RunTimeControls_Change(ctrl As MSForms.Control)
    Select Case TypeName(ctrl)
        Case "Label"
            Rem labels dont change
        Case "ListBox"
            With ctrl
                If .ListIndex = -1 Then
                    MsgBox "Change: Nothing is selected from " & ctrl.Name
                Else
                    MsgBox "Change: " & ctrl.Name & " has item # " & (.ListIndex + 1) & " selected." _
                        & vbCr & "Changed to " & .List(.ListIndex)
                End If
            End With
        Case "TextBox"
            MsgBox "The textbox named " & ctrl.Name & " changed to " & ctrl.Text
    End Select
End Sub

Private Sub RunTimeControls_Click(ctrl As MSForms.Control)
    Select Case TypeName(ctrl)
        Case "Label"
            MsgBox ctrl.Name & " clicked"
        Case "ListBox"
            With ctrl
                If .ListIndex = -1 Then
                    MsgBox "Nothing is selected from " & ctrl.Name
                Else
                    MsgBox "Listbox " & ctrl.Name & " clicked."
                End If
            End With
        Case "TextBox"
            Rem textBoxes dont click
    End Select
End Sub

Private Sub RunTimeControls_DblClick(ctrl As MSForms.Control, Cancel As MSForms.ReturnBoolean)
    MsgBox ctrl.Name & " has been double clicked"
End Sub


Private Sub UserForm_Terminate()
    Set RunTimeControls = Nothing
End Sub

Notice that the custom classes don't need to be touched. (Other to add more controls or more events). All the coding for what happens when an event fires is in the userform's code module. As the above example shows, differentiating what to do when different types of controls fire the event can be tedious. One way around that would be for the userform to have a different clsRTControls object for each kind of control.

' in useform2 code module

Public WithEvents myAddedTextBoxes As clsRTControls
Public WithEvents myAddedListBoxes As clsRTControls
Dim ufEventsDisabled As Boolean

Private Sub UserForm_Initialize()
    Set myAddedTextBoxes = New clsRTControls
    Set myAddedListBoxes = New clsRTControls
    Set myAddedTextBoxes.Parent = Me
    Set myAddedListBoxes.Parent = Me
    
    With myAddedTextBoxes.Add("forms.TextBox.1", Name:="myTextBox1")
        .Top = 25: .Left = 115
        .Height = 22: .Width = 100
    End With
    With myAddedListBoxes.Add("forms.ListBox.1", Name:="myListBox1")
        .Top = 10: .Left = 5
        .Height = 80: .Width = 100
        .AddItem "Smith"
        .AddItem "Jones"
        .AddItem "Williams"
    End With
    
    With myAddedTextBoxes.Add("forms.TextBox.1", Name:="myTextBox2")
        .Top = 105: .Left = 115
        .Height = 22: .Width = 100
    End With
    With myAddedListBoxes.Add("forms.ListBox.1", Name:="myListBox2")
        .Top = 90: .Left = 5
        .Height = 100: .Width = 100
        .AddItem "Able"
        .AddItem "Baker"
        .AddItem "Charlie"
    End With
    
End Sub

Private Sub myAddedListBoxes_Change(ctrl As MSForms.Control)
    Dim matchingTextBox As MSForms.TextBox
    ufEventsDisabled = True
    With ctrl
        Set matchingTextBox = myAddedTextBoxes.Item(Replace(.Name, "myListBox", "myTextBox"))
        If .ListIndex = -1 Then
            matchingTextBox.Text = vbNullString
        Else
            matchingTextBox.Text = .List(.ListIndex)
        
        End If
    End With
    ufEventsDisabled = False
End Sub

Private Sub myAddedListBoxes_Click(ctrl As MSForms.Control)
    Dim matchingListBox
    'ufEventsDisabled
    
End Sub

Private Sub myAddedTextBoxes_Change(ctrl As MSForms.Control)
    Dim matchingListBox As MSForms.ListBox
    Set matchingListBox = myAddedListBoxes.Item(Replace(ctrl.Name, "myTextBox", "myListBox"))
    ufEventsDisabled = True
    With matchingListBox
        If -1 < .ListIndex Then
            ufEventsDisabled = True
            .List(.ListIndex) = ctrl.Text
        End If
    End With
    ufEventsDisabled = False
End Sub


Private Sub UserForm_Terminate()
    Set myAddedListBoxes = Nothing
    Set myAddedTextBoxes = Nothing
End Sub

One could even have different objects (different code) for different kinds of TextBoxes. NumbericTextBoxes vs. AlphabeticTextBoxes are an option. Notice that the .Add function of clsRTControls will also accept an existing control as an argument, so that control would be controlled by the same event code as the other members in the collection class.

Put this code in a userform that has a design-time TextBox (TextBox1)

' in userform3

Public WithEvents NumericTextBoxes As clsRTControls
Public WithEvents AlphabeticTextBoxes As clsRTControls
Dim ufEventsDisabled As Boolean

Private Sub AlphabeticTextBoxes_Change(ctrl As MSForms.Control)
    ufEventsDisabled = True
    ctrl.Text = Application.Proper(ctrl.Text)
    ufEventsDisabled = False
End Sub

Private Sub NumericTextBoxes_Change(ctrl As MSForms.Control)
    If Not (IsNumeric(ctrl.Text & "0")) Then
        MsgBox "numeric entry only"
    End If
End Sub

Private Sub UserForm_Initialize()
     Dim nullTop As Single
    nullTop = TextBox1.Top + TextBox1.Height + 10
    
    Set NumericTextBoxes = New clsRTControls
    Set AlphabeticTextBoxes = New clsRTControls
    Set NumericTextBoxes.Parent = Me
    Set AlphabeticTextBoxes.Parent = Me
    
    Dim i As Long
    For i = 0 To 5
        With NumericTextBoxes.Add("forms.TextBox.1")
            .Left = 5: .Top = nullTop + i * 28
            .Height = 22: .Width = 75
        End With
        With AlphabeticTextBoxes.Add("forms.TextBox.1")
            .Left = 105: .Top = nullTop + i * 28
            .Height = 22: .Width = 140
        End With
    Next i
    NumericTextBoxes.Add TextBox1
End Sub

Private Sub UserForm_Terminate()
    Set NumericTextBoxes = Nothing
    Set AlphabeticTextBoxes = Nothing
End Sub

Notice that all three of these userforms, with their various actions, need only the two classes above.

 

[Jon von der Heyden]

Wow!

I particularly like that I can enforce data types in certain types of controls, something I have to do in this project.

Thanks for sharing Mike - it's going to take some work on my part to undo my junk code and integrate this, but seems it will be well worth the effort!

 

[Kyle123]

That's really nice Mike, couple of suggestions if I may; since you have circular references, you can't tear them down in the terminate event of the RTControls class since it never fires; even though the class is explicitly set to nothing.

The clsRTControls needs a dispose subroutine that is called on the Userform Terminate Routine:

Private Sub UserForm_Terminate()
    RunTimeControls.Dispose
    'Set RunTimeControls = Nothing - This doesn't actually do anything, it is ignored due to the circular reference
End Sub

Then in clsRTControls:

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




Private Sub Class_Terminate()


End Sub

This is easily testable by putting the following in the RTControl Class:

Private Sub Class_Terminate()
    Debug.Print "Terminate", RTControl.Name
End Sub