Wie schon darauf hingewiesen wurde, ist das nicht ganz so einfach/trivial:
z.B. UserForm1:
'
'in UserForm
'
Option Explicit
Private WithEvents m_objCtlWrapper As VBAProject.CtlWrapper
Private Sub CommandButton1_Click()
Dim i As Long
For i = 1 To 3
With m_objCtlWrapper.AddControl(UserForm1, "Forms.Label.1", "lblTest" & Format$(i, "00"), True)
.Caption = "Test" & Format$(i, "00")
.Left = 10
.Width = 50
.Top = 30 * i
End With
Next
End Sub
Private Sub m_objCtlWrapper_OnClick(ByVal Control As MSForms.Control)
If TypeOf Control Is MSForms.Label Then
MsgBox "Label_Click {Name: '" & Control.Name & "', Caption: '" & Control.Caption & "'}", vbInformation
End If
End Sub
Private Sub UserForm_Initialize()
Set m_objCtlWrapper = New VBAProject.CtlWrapper
End Sub
Private Sub UserForm_Terminate()
m_objCtlWrapper.RemoveAll
Set m_objCtlWrapper = Nothing
End Sub
Klasse: CtlWrapper
'
'in Klassenmodul: CtlWrapper
'
Option Explicit
Event OnClick(ByVal Control As MSForms.Control)
Private m_colControls As VBA.Collection
Public Function AddControl(Container As MSForms.UserForm, ProgID As String, Optional Name, Optional Visible) As MSForms.Control
Const E_NOTIMPL = &H80004001
Dim ctl As Object
Select Case UCase$(ProgID)
Case "FORMS.LABEL.1"
Set ctl = New VBAProject.CtlLabel
Set ctl.Control = Container.Controls.Add(ProgID, Name, Visible)
Set ctl.Wrapper = Me
' Case "..."
'...
Case Else
Err.Raise E_NOTIMPL, TypeName(Me) & "::AddControl()", "invalid or not supported ProgID"
End Select
Call m_colControls.Add(ctl)
If IsMissing(Name) Then Name = ctl.Control.Name
If IsMissing(Visible) Then Name = ctl.Control.Visible
Set AddControl = ctl.Control
End Function
Public Sub Remove(ByVal Control As Object)
If Not TypeOf Control Is MSForms.Control Then Exit Sub
Dim i As Long
For i = 1 To m_colControls.Count
If m_colControls(i).Control Is Control Then
Call m_colControls.Remove(i)
Exit Sub
End If
Next
Err.Raise 9, TypeName(Me) & "::Remove()", "cannot remove control; not in list" 'index out of range
End Sub
Public Function RemoveAll()
Dim ctl As Object
For Each ctl In m_colControls
Set ctl.Control = Nothing
Set ctl.Wrapper = Nothing
Next
Set m_colControls = New VBA.Collection
End Function
Friend Sub InvokeEvent(ByVal EventType As String, ByVal Caller As MSForms.Control)
Select Case LCase$(EventType)
Case "click": RaiseEvent OnClick(Caller)
' Case ...: RaiseEvent ...
End Select
End Sub
Private Sub Class_Initialize()
Set m_colControls = New VBA.Collection
End Sub
Private Sub Class_Terminate()
Set m_colControls = Nothing
End Sub
Klasse: CtlLabel
'
'in Klassenmodul: CtlLabel
'
Option Explicit
Private WithEvents m_objMSFLabel As MSForms.Label
Private m_objWrapper As VBAProject.CtlWrapper
Public Property Get Control() As MSForms.Control
Set Control = m_objMSFLabel
End Property
Friend Property Set Control(ByVal RHS As MSForms.Control)
Set m_objMSFLabel = RHS
End Property
Public Property Get Wrapper() As VBAProject.CtlWrapper
Set Wrapper = m_objWrapper
End Property
Friend Property Set Wrapper(ByVal RHS As VBAProject.CtlWrapper)
Set m_objWrapper = RHS
End Property
'### EVENTs ###
Private Sub m_objMSFLabel_Click()
m_objWrapper.InvokeEvent "click", m_objMSFLabel
End Sub
Grüße
|