AW: Controls mit Events in Collections verwalten
09.05.2026 03:58:45
Sumbu
Hallo Uwe,
richtig, die gezeigte Funktion erzeugt nur die gewünschten Controls. Aber mit dieser Funktion ist das Erzeugen ziemlich praktisch, weil man damit in einer verschachtelten Schleife sehr einfach ein Grid erzeugen kann, wo man genau die Größe und Position der Controls (In diesem Fall, geht es mir um Textboxen) festlegen kann.
Bei den Werten geht es nur darum, sie in einer Minidatenbank zu speichern, und beim Start wieder einzulesen. Der Code dazu:
in einem Standardmodul (basClasses):
Option Explicit
Option Private Module
Public NoEvent As Boolean
Public ProductType As clsProductType
Public SingleProduct As clsSingleProduct
Public gGridForm As frmGridEditor
'Public gCtlWatchers As Collection ' hält Instanzen von clsControlEvents / clsWatchEvents
Public idCount As Long
Private mCols As Long, mRows As Long
Private Type ProdType
prodTypeID As String * 20
SingProdID As String * 20
ProdTypeName As String * 25
SingProdName As String * 25
SingProdBackCol As String * 8
SingProdForeCol As String * 8
End Type
Public Sub ShowProductGrid()
' ProductType muss gefüllt sein (z. B. durch testProductsClasses)
If Not classIsInitialized(ProductType) Then Set ProductType = New clsProductType
'mRows = IIf(ProductType Is Nothing, 0, ProductType.Count)
'mCols = singleProductTotalCount()
Set gGridForm = New frmGridEditor
Set gCtlWatchers = New Collection
gGridForm.Show vbModeless
'BuildGrid mRows, mCols
End Sub
Public Sub testProductClasses()
'Mit diesem Sub lassen sich die sich die Klassen zu Testzwecken mit Beispieldaten füllen
Dim rows As Long, cols As Long, X As Long, Y As Long, aCounter As Long, bCounter As Long
rows = 5
cols = 4
'bCounter = 1
Set ProductType = New clsProductType
For X = 1 To rows
Call ProductType.Add("X" & Left("00000" & CStr(X), 6), "Name" & CStr(X))
Set SingleProduct = New clsSingleProduct
For Y = 1 To cols
Call ProductType(X).SingleProduct.Add(createID, "Produkt" & CStr(Y), 65535, 0)
Next Y
Next X
End Sub
Public Function createID() As String
Dim Y As Long
'If idCount = 10 Then Stop
idCount = idCount + 1
createID = "X" & Right("00000" & CStr(idCount), 6)
End Function
Public Sub writeProducts() 'Speichert die Klasse ProductType.SingleProduct in einer Minidatenbank
Dim X As Long, Y As Long
Dim Intfile As Integer
Dim TypeConvert As ProdType
Dim myPath As String
Call testProductClasses
Const myFilename As String = "CartData.mealcards"
myPath = MainPath & "DATA\" & myFilename
Dim pvstrFiller As String
For X = 1 To 25
pvstrFiller = pvstrFiller & Chr(12)
Next X
If IsFileOpen(myPath) = 0 Then Kill myPath
Intfile = FreeFile
Open myPath For Random As #Intfile Len = Len(TypeConvert)
For X = 1 To ProductType.Count
For Y = 1 To ProductType(X).SingleProduct.Count
With TypeConvert
.prodTypeID = Right(pvstrFiller & CStr(ProductType(X).ID), 20)
.ProdTypeName = Right(pvstrFiller & CStr(ProductType(X).Name), 25)
.SingProdID = Right(pvstrFiller & CStr(ProductType(X).SingleProduct(Y).ID), 20)
.SingProdName = Right(pvstrFiller & CStr(ProductType(X).SingleProduct(Y).Name), 25)
.SingProdBackCol = Right(pvstrFiller & CStr(ProductType(X).SingleProduct(Y).BackColor), 8)
.SingProdForeCol = Right(pvstrFiller & CStr(ProductType(X).SingleProduct(Y).ForeColor), 8)
End With
Put #Intfile, , TypeConvert
Next Y
Next X
Close #Intfile
End Sub
Public Sub readProductsALT()
Dim X As Long, Intfile As Integer, myPath As String, TypeConvert As ProdType
Const myFilename As String = "CartData.mealcards"
On Error Resume Next
myPath = MainPath & "DATA\" & myFilename
If Not classIsInitialized(ProductType) Then
Set ProductType = New clsProductType
Else
Set ProductType = Nothing
Set ProductType = New clsProductType
End If
Intfile = FreeFile
If Dir(myPath) = "" Then Exit Sub
Open myPath For Random As #Intfile Len = Len(TypeConvert)
Do While Not EOF(Intfile)
X = X + 1
Get #Intfile, , TypeConvert
With TypeConvert
Call ProductType.Add(removeChr12(.prodTypeID), removeChr12(.ProdTypeName))
Do
Loop
End With
Loop
End Sub
Public Sub readProducts()
Dim TypeConvert As ProdType
Dim Intfile As Integer
Dim myPath As String
Const myFilename As String = "CartData.mealcards"
Dim existing As clsProductType
myPath = MainPath & "DATA\" & myFilename
If Not classIsInitialized(ProductType) Then
Set ProductType = New clsProductType
Else
Set ProductType = Nothing
Set ProductType = New clsProductType
End If
Intfile = FreeFile
If Dir(myPath) = "" Then Exit Sub
Open myPath For Random As #Intfile Len = Len(TypeConvert)
On Error GoTo Cleanup
Do While Not EOF(Intfile)
Get #Intfile, , TypeConvert
' ProdTypeID bereinigen (falls Chr(12) am Anfang vorhanden)
Dim prodTypeID As String
prodTypeID = CStr(removeChr12(TypeConvert.prodTypeID))
' Prüfen, ob ProdType bereits existiert
On Error Resume Next
Set existing = ProductType.Item(prodTypeID)
If Err.Number > 0 Then
Err.Clear
'Neu anlegen (Name bereinigen)
Call ProductType.Add(prodTypeID, CStr(removeChr12(TypeConvert.ProdTypeName)))
Set existing = ProductType.Item(removeChr12(prodTypeID))
Else
'ggf. Name ergänzen, falls leer
If existing.Name = "" Then existing.Name = CStr(removeChr12(TypeConvert.ProdTypeName))
End If
On Error GoTo Cleanup
'SingleProduct zur gefundenen/erstellten ProductType-Instanz hinzufügen
With TypeConvert
existing.SingleProduct.Add _
CStr(removeChr12(.SingProdID)), _
CStr(removeChr12(.SingProdName)), _
CLng(removeChr12(.SingProdBackCol)), _
CLng(removeChr12(.SingProdForeCol))
End With
Set existing = Nothing
Loop
Cleanup:
If Err.Number > 0 Then
'Fehlerbehandlung: optional Debug-Ausgabe
Debug.Print "readProducts Fehler: " & Err.Number & " - " & Err.Description
Err.Clear
End If
If Intfile > 0 Then Close #Intfile
End Sub
Public Function removeChr12(pvString As String) As String
If Len(pvString) = 0 Then
removeChr12 = pvString
Exit Function
End If
Do While Len(pvString) > 0 And Left$(pvString, 1) = Chr$(12)
pvString = Mid$(pvString, 2)
Loop
removeChr12 = pvString
End Function
Public Function IsFileOpen(filename As String) As Integer
Dim filenum As Integer, errnum As Integer
On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
IsFileOpen = errnum
End Function
Public Function singleProductTotalCount() As Long
Dim X As Long, Y As Long
singleProductTotalCount = 0
For X = 1 To ProductType.Count
If singleProductTotalCount ProductType(X).SingleProduct.Count Then
singleProductTotalCount = ProductType(X).SingleProduct.Count
End If
Next X
singleProductTotalCount = singleProductTotalCount + 1
End Function
Public Function classIsInitialized(pvobjClass As Object) As Boolean
Dim ID_Check As String
On Error GoTo errorhandler
ID_Check = ProductType(1).ID
classIsInitialized = True
Exit Function
errorhandler:
classIsInitialized = False
End Function
In einem Klassenmodul (clsProductType):
Option Explicit
Option Compare Text
'Modulname: clsProductType
Private mstrID As String
Private mstrName As String
Private mobjSingleProduct As clsSingleProduct
Private mobjProductType As Collection
Private Sub Class_Initialize()
Set ProductType = New Collection
Set SingleProduct = New clsSingleProduct
End Sub
Private Sub Class_Terminate()
Set ProductType = Nothing
Set SingleProduct = Nothing
End Sub
Friend Property Get ID() As String
ID = mstrID
End Property
Friend Property Let ID(ByVal pvstrID As String)
mstrID = pvstrID
End Property
Friend Property Get Name() As String
Name = mstrName
End Property
Friend Property Let Name(ByVal pvstrName As String)
mstrName = pvstrName
End Property
Friend Property Get ProductType() As Collection
Set ProductType = mobjProductType
End Property
Friend Property Set ProductType(ByRef pvobjProductType As Collection)
Set mobjProductType = pvobjProductType
End Property
Friend Property Get SingleProduct() As clsSingleProduct
Set SingleProduct = mobjSingleProduct
End Property
Friend Property Set SingleProduct(ByRef pvobjSingleProduct As clsSingleProduct)
Set mobjSingleProduct = pvobjSingleProduct
End Property
Friend Sub Add( _
ByVal pvstrID As String, ByVal pvstrName As String)
Dim objProductTypeClass As clsProductType
Set objProductTypeClass = New clsProductType
With objProductTypeClass
.ID = pvstrID
.Name = pvstrName
Set .SingleProduct = New clsSingleProduct
End With
Call ProductType.Add(Item:=objProductTypeClass, key:=pvstrID)
Set objProductTypeClass = Nothing
End Sub
Friend Sub Move( _
ByVal pvvntIndex As Variant, _
Optional ByVal opvvntBefore As Variant = Empty, _
Optional ByVal opvvntAfter As Variant = Empty)
Dim objProductType As clsProductType
If Not IsEmpty(opvvntBefore) Then
With Me
Set objProductType = .Item(pvvntIndex)
Call .Delete(pvvntIndex)
Call ProductType.Add(Item:=objProductType, key:=pvvntIndex, Before:=opvvntBefore)
End With
Set objProductType = Nothing
ElseIf Not IsEmpty(opvvntAfter) Then
With Me
Set objProductType = .Item(pvvntIndex)
Call .Delete(pvvntIndex)
Call ProductType.Add(Item:=objProductType, key:=pvvntIndex, Before:=opvvntAfter)
End With
Set objProductType = Nothing
Else
Call MsgBox("Fehlender Parameter in der Move-Methode der " & _
"ProductType-Klasse.", vbCritical, "Methode fehlgeschlagen")
End If
End Sub
Private Function SortString(ByVal pvlngIndex As Long) As String
SortString = Item(pvlngIndex).Name
End Function
Friend Sub Sort( _
Optional ByVal opvenmSortOrder As XlSortOrder = xlAscending, _
Optional ByVal opvvntLBound As Variant, _
Optional ByVal opvvntUBound As Variant)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntBuffer As Variant
If IsMissing(opvvntLBound) Then opvvntLBound = 1
If IsMissing(opvvntUBound) Then opvvntUBound = Count
lngIndex1 = opvvntLBound
lngIndex2 = opvvntUBound
vntBuffer = SortString((lngIndex1 + lngIndex2) \ 2)
Do
If opvenmSortOrder = xlAscending Then
Do While SortString(lngIndex1) vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer SortString(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While SortString(lngIndex1) > vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > SortString(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1 lngIndex2 Then
Call Move(pvvntIndex:=Item(lngIndex1).ID, _
opvvntBefore:=Item(lngIndex2).ID)
Call Move(pvvntIndex:=Item(lngIndex2).ID, _
opvvntBefore:=Item(lngIndex1).ID)
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If opvvntLBound lngIndex2 Then Call Sort( _
opvenmSortOrder, opvvntLBound, lngIndex2)
If lngIndex1 opvvntUBound Then Call Sort( _
opvenmSortOrder, lngIndex1, opvvntUBound)
End Sub
Friend Function Count() As Long
Count = ProductType.Count
End Function
Friend Sub Delete(ByVal pvvntIndex As Variant)
Call ProductType.Remove(pvvntIndex)
End Sub
Public Function Item(ByVal pvvntIndex As Variant) As clsProductType
Set Item = ProductType.Item(pvvntIndex)
End Function
Public Function NewEnum() As IUnknown
Set NewEnum = ProductType.[_NewEnum]
End Function
Und in einem weitereren Klassenmodul die untergeordnete Klasse (clsSingleProduct):
Option Explicit
Option Compare Text
'Modulname: clsSingleProduct
Private mstrID As String
Private mstrName As String
Private mlngBackColor As Long
Private mlngForeColor As Long
Private mobjSingleProduct As Collection
Private Sub Class_Initialize()
Set SingleProduct = New Collection
End Sub
Private Sub Class_Terminate()
Set SingleProduct = Nothing
End Sub
Friend Property Get ID() As String
ID = mstrID
End Property
Friend Property Let ID(ByVal pvstrID As String)
mstrID = pvstrID
End Property
Friend Property Get Name() As String
Name = mstrName
End Property
Friend Property Let Name(ByVal pvstrName As String)
mstrName = pvstrName
End Property
Friend Property Get BackColor() As Long
BackColor = mlngBackColor
End Property
Friend Property Let BackColor(ByVal pvlngBackColor As Long)
mlngBackColor = pvlngBackColor
End Property
Friend Property Get ForeColor() As Long
ForeColor = mlngForeColor
End Property
Friend Property Let ForeColor(ByVal pvlngForeColor As Long)
mlngForeColor = pvlngForeColor
End Property
Friend Property Get SingleProduct() As Collection
Set SingleProduct = mobjSingleProduct
End Property
Friend Property Set SingleProduct(ByRef pvobjSingleProduct As Collection)
Set mobjSingleProduct = pvobjSingleProduct
End Property
Friend Sub Add( _
ByVal pvstrID As String, ByVal pvstrName As String, ByVal pvlngBackColor As Long, ByVal pvlngForeColor As Long)
Dim objSingleProductClass As clsSingleProduct
Set objSingleProductClass = New clsSingleProduct
With objSingleProductClass
.ID = pvstrID
.Name = pvstrName
.BackColor = pvlngBackColor
.ForeColor = pvlngForeColor
End With
Call SingleProduct.Add(Item:=objSingleProductClass, key:=pvstrID)
Set objSingleProductClass = Nothing
End Sub
Friend Sub Move( _
ByVal pvvntIndex As Variant, _
Optional ByVal opvvntBefore As Variant = Empty, _
Optional ByVal opvvntAfter As Variant = Empty)
Dim objSingleProduct As clsSingleProduct
If Not IsEmpty(opvvntBefore) Then
With Me
Set objSingleProduct = .Item(pvvntIndex)
Call .Delete(pvvntIndex)
Call SingleProduct.Add(Item:=objSingleProduct, key:=pvvntIndex, Before:=opvvntBefore)
End With
Set objSingleProduct = Nothing
ElseIf Not IsEmpty(opvvntAfter) Then
With Me
Set objSingleProduct = .Item(pvvntIndex)
Call .Delete(pvvntIndex)
Call SingleProduct.Add(Item:=objSingleProduct, key:=pvvntIndex, Before:=opvvntAfter)
End With
Set objSingleProduct = Nothing
Else
Call MsgBox("Fehlender Parameter in der Move-Methode der " & _
"SingleProduct-Klasse.", vbCritical, "Methode fehlgeschlagen")
End If
End Sub
Private Function SortString(ByVal pvlngIndex As Long) As String
SortString = Item(pvlngIndex).Name
End Function
Friend Sub Sort( _
Optional ByVal opvenmSortOrder As XlSortOrder = xlAscending, _
Optional ByVal opvvntLBound As Variant, _
Optional ByVal opvvntUBound As Variant)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntBuffer As Variant
If IsMissing(opvvntLBound) Then opvvntLBound = 1
If IsMissing(opvvntUBound) Then opvvntUBound = Count
lngIndex1 = opvvntLBound
lngIndex2 = opvvntUBound
vntBuffer = SortString((lngIndex1 + lngIndex2) \ 2)
Do
If opvenmSortOrder = xlAscending Then
Do While SortString(lngIndex1) vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer SortString(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While SortString(lngIndex1) > vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > SortString(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1 lngIndex2 Then
Call Move(pvvntIndex:=Item(lngIndex1).ID, _
opvvntBefore:=Item(lngIndex2).ID)
Call Move(pvvntIndex:=Item(lngIndex2).ID, _
opvvntBefore:=Item(lngIndex1).ID)
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If opvvntLBound lngIndex2 Then Call Sort( _
opvenmSortOrder, opvvntLBound, lngIndex2)
If lngIndex1 opvvntUBound Then Call Sort( _
opvenmSortOrder, lngIndex1, opvvntUBound)
End Sub
Friend Function Count() As Long
Count = SingleProduct.Count
End Function
Friend Sub Delete(ByVal pvvntIndex As Variant)
Call SingleProduct.Remove(pvvntIndex)
End Sub
Public Function Item(ByVal pvvntIndex As Variant) As clsSingleProduct
Set Item = SingleProduct.Item(pvvntIndex)
End Function
Public Function NewEnum() As IUnknown
Set NewEnum = SingleProduct.[_NewEnum]
End Function
Auf die Art verwalte ich die Werte des anvisierten Textbox-Arrays. Die Frage ist jetzt, wie ich mir die Textboxen in eigens dafür vorgesehenen Klassen erzeuge und verwalte. Also ich will sie nicht nur mit der newControl-Function erzeugen, sondern auch gleich mit = an eine Klasse übergeben.
Liebe Grüße Guido