WithEvents arrays

[elHollandes]

Hi All,

Reading the ´WithEvents Question´ by MichaelBronner I wondred about the way to get around WithEvents for arrays. Basic does it with control arrays, so it´s possible. You can´t use a safearray though. The control arrays of Basic look more look collections.... I craeted the testprojectgroup i´ll discribe below and hope to get some reactions. It´s not very clean programming, but servers my goal as a discussion example. It creates a form where you can populate an array with objects that contain a Name as string. If the name of one of the objects changes, an event will be raisen indicating the object by the array index and then new name. A control array reacts on these events by displaying the new name.

The testprojectgroup consists of two projects (it'll work as a single project too, just put everything in a standard exe project). The first is a standard exe that only contains one form. On the form then following controls:

- A TextBox called txtNr (with associated label)
Here you can define the size of the array
- A CheckBox called chkPreserve
If you change the size, this checkbox determains if the old names are presereved
- A Listbox called lstItem (with label)
A list of numbers indicating the elements of the array
- A TextBox called txtName (with label)
The name of the selected element
- An array of 5 labels called lblNr(1 to 5)
The frist fivel element numbers
- An array of 5 labels called lblName(1 to 5)
The fiirst five element names

The code listing of this form is as follows

LISTING 1

Option Explicit

Private mfNrChanged As Boolean
Private WithEvents mcClass2 As Class2

Private Sub Form_Load()
Dim piCnt As Integer
'declare counter
Set mcClass2 = New Class2
'create array class
For piCnt = 1 To 5
'Enum labels
lblNr(piCnt) = piCnt
'set label number
Next
End Sub

Private Sub lstItem_Click()
txtName = mcClass2(lstItem.ListIndex + 1)
'display name of selected item
End Sub

Private Sub txtName_Change()
mcClass2(lstItem.ListIndex + 1) = txtName
'change object name invoces event
End Sub

Private Sub txtNr_Change()
mfNrChanged = True
'set changed flag
End Sub

Private Sub txtNr_LostFocus()
Dim piCnt As Integer

If mfNrChanged Then
'change is made
If Val(txtNr) < 1 Then txtNr = 1
'validate text
If chkPreserve.Value = vbChecked Then
mcClass2.crReDim Val(txtNr), True
'redim with preserve
Else
mcClass2.crReDim Val(txtNr)
'redim without preserve
End If
lstItem.Clear
'reset items list
For piCnt = 1 To Val(txtNr)
lstItem.AddItem Format(piCnt)
'add numbers
Next
lstItem = Format(1)
'set to first item
End If
End Sub

Private Sub mcClass2_cxName(ByVal aiIndex As Integer, ByVal asName As String)
If aiIndex < 6 Then lblName(aiIndex) = asName
'the array event sends an index to identify the
'element that caused the event
End Sub

END LISTING 1

The second project is a DLL project (you should make a reference from the exe project to this one to make it work) and consists of two classes. I didn't change the class names, so they are Class1 and Class 2. Class 1 represents an element of the array and Class2 represents the array. Here are the listings:

START LISTING 2

Option Explicit

Dim msName As String
'name property
Dim miIndex As Integer
'index in array
Dim mcParent As Class2
'parent array class

Friend Property Set fpcParent(ByVal acParent As Class2)
Set mcParent = acParent
End Property

Friend Property Let fpiIndex(ByVal aiIndex As Integer)
miIndex = aiIndex
End Property

Public Property Get cpsName() As String
cpsName = msName
End Property

Public Property Let cpsName(ByVal asName As String)
If msName = asName Then Exit Property
'no changes
msName = asName
'set name
mcParent.frName miIndex, msName
'raise array event
End Property

END LISTING 2

START LISTING 3

Option Explicit
'declare all variables
Option Base 1
'lowbound of arrays = 1
Private mcItems() As Class1
'array of class1 objects
Public Event cxName(ByVal aiIndex As Integer, ByVal asName As String)
'array event

Public Sub crReDim(ByVal aiItems As Integer, Optional ByVal afPreserve As Boolean = False)
'dimension array
Dim piCnt As Integer
'declare counter
If aiItems < 1 Then Exit Sub
'invalid value
If afPreserve Then
'preserve old elements
If UBound(mcItems) > aiItems Then
'decrease array
For piCnt = aiItems + 1 To UBound(mcItems)
'elements to delete
RaiseEvent cxName(piCnt, "")
'raise event to delete name property
Next
End If
ReDim Preserve mcItems(aiItems)
'change dimension preserving exisiting elements
Else
'dimension without preserve
For piCnt = 1 To UBound(mcItems)
'enum all old elements
RaiseEvent cxName(piCnt, "")
'raise event to delete name property
Next
ReDim mcItems(aiItems)
'redim without preserve
End If
For piCnt = 1 To aiItems
'enum all elements
On Error GoTo CreateObject
'error if element is nothing
mcItems(piCnt).fpiIndex = piCnt
'set index
Set mcItems(piCnt).fpcParent = Me
'set parent
Next
Exit Sub
CreateObject:
Set mcItems(piCnt) = New Class1
'create new object
Resume
End Sub

Public Function cpcItem(ByVal aiIndex As Integer) As Class1
'get class1 object
If aiIndex < 1 Then Exit Function
'out of range
If aiIndex > UBound(mcItems) Then Exit Function
'out of range
Set cpcItem = mcItems(aiIndex)
'return object
End Function

Friend Sub frName(ByVal aiIndex As Integer, asName As String)
'to be called by array member
RaiseEvent cxName(aiIndex, asName)
'call array event
End Sub

Private Sub Class_Initialize()
ReDim mcItems(1)
'minimum size
End Sub

END LISTING 3

Hope it'll help someone.

El Holandes