Assign class module to Form controls (1 Viewer)

[MsAccessNL]

Class TaskLabel

Option Compare Database
Option Explicit

Private WithEvents mLabel As Access.Label
Private mName As String
Public Property Get Name() As String
  Name = mLabel.Name
End Property
Public Property Get TaskLabel() As Access.Label
  Set TaskLabel = mLabel
End Property
Public Property Set TaskLabel(TheLabel As Access.Label)
' On Error GoTo ErrHandler
  Set mLabel = TheLabel
  'You can add More Events and more controls here
   mLabel.OnClick = "[Event Procedure]"
  ' ....
  Exit Property
ErrHandler:
   If Not (Err.Number = 459 Or Err.Number = 91) Then
      MsgBox ("Error: " & Err.Number _
            & " " & Err.Description _
            & " " & Err.Source)
   End If
   Resume Next
End Property
Private Sub mLabel_Click()
  MsgBox mLabel.Caption & " " & Me.Name
End Sub

Class TaskLabels

Option Compare Database
Option Explicit

'Class Module Name: TaskLabels
'Developed by: MajP
'
'Purpose: This Class Module is the collection class for the object class "TaskLabels"
'The collection allows you to build a pseudo control array that will react to one or more events.

'************************ Class Code Start ****************************************************

Private mTaskLabels As New Collection
Public Function Add(TheLabel As Access.Control, ctlName As String) As TaskLabel
   Dim newTaskLabel As TaskLabel
   Set newTaskLabel = New TaskLabel
   Set newTaskLabel.TaskLabel = TheLabel
   mTaskLabels.Add newTaskLabel, ctlName
   Set Add = newTaskLabel
End Function
Public Property Get count() As Integer
   count = mTaskLabels.count
End Property
Public Property Get Item(ByVal index As Variant) As TaskLabel
   Set Item = mTaskLabels(index)
End Property
Public Sub Remove(index As Variant)
   mTaskLabels.Remove (index)
End Sub
Public Sub Remove_ByName(ByVal TheName As String)
   Dim i As Integer
   For i = 1 To mTaskLabels.count
     If mTaskLabels(i).Name = TheName Then
        Remove (i)
        Exit Sub
     End If
   Next
End Sub

Private Sub Class_Terminate()
Set mTaskLabels = Nothing
End Sub
Public Sub Clear()
    Set mTaskLabels = New Collection
End Sub

Public Property Get Item_ByName(ByVal TheName As String) As TaskLabel
   Dim Tasklbl As TaskLabel
   For Each Tasklbl In mTaskLabels
     If Tasklbl.Name = TheName Then
       Set Item_ByName = Tasklbl
     End If
   Next
End Property

Demo

Dim MyTasks As New TaskLabels

Private Sub cmdDemo_Click()
  'Demo by index
  MsgBox MyTasks.Item(1).Name
  'Demo by name. Note did not add a caption property to TaskLabels
  MsgBox MyTasks.Item_ByName("Label7").TaskLabel.Caption
  'Demo Remove
  MsgBox "Count " & MyTasks.count
  MsgBox "Last " & MyTasks.Item(1).Name
  MyTasks.Remove (MyTasks.count)
  MsgBox "Count " & MyTasks.count
  'Demo Remove by Name
  MyTasks.Remove_ByName ("label19")
  MsgBox "Count " & MyTasks.count
End Sub

Private Sub Form_Load()
  Dim ctl As Access.Control
  For Each ctl In Me.Controls
     If ctl.Tag = "T" Then
        MyTasks.Add ctl, ctl.Name
      End If
  Next ctl
End Sub

Hello Majp,

I react to this old feed. I don't succeed to get your code working. If I add a HelloWorld funtion it works, but it doesn't pick up the Event Procedure. I am using Access 2010 and had to adept the form load code:

Private Sub Form_Load()
Dim ctl As Access.Control
Dim MyTasks As TaskLabels
Set MyTasks = New TaskLabels

For Each ctl In Me.Form.Section(acHeader).Controls
If ctl.Tag = "T" Then
MyTasks.Add ctl, ctl.Name
End If
Next ctl
'Debug.Print Me.First_Name_Label.OnClick
End Sub