Having recently encountered (again) this ancient issue of trying to add UDTs to a VB6 Collection, I have decided to take another look at it. There are several existing methods to tackle this problem which include converting the UDT into a Class, creating an in-memory TypeLib for the UDT, serialize the UDT into a byte array, declare the UDT in a Public Class from an ActiveX DLL and possibly others.
As it turns out, just by adding a measly 8 bytes to each UDT, you can easily convince VB6 that your UDT is in fact an object and it will happily add it "as is" to any collection. Just declare your desired UDT in a BAS module and manage it through a Public Property Get/Let. The UDT can contain members of any type (numeric, strings (fixed or variable length), static or dynamic arrays, objects, other UDTs, etc):
frmCollectionUDT form. Just click on the form to print and modify UDTs from the collection:
mdlCollectionUDT BAS module:
The UDT also contains a "Dummy" class member for demonstration purposes just to show how each object fires its "Class_Terminate" event when the collection is destroyed.
Here's the demo project: CollectionUDT.zip
As it turns out, just by adding a measly 8 bytes to each UDT, you can easily convince VB6 that your UDT is in fact an object and it will happily add it "as is" to any collection. Just declare your desired UDT in a BAS module and manage it through a Public Property Get/Let. The UDT can contain members of any type (numeric, strings (fixed or variable length), static or dynamic arrays, objects, other UDTs, etc):
Code:
Public Type UDT
ID As Long
Value As Currency
Date As String
Year As String * 4
ByteArray() As Byte
Picture As IPicture
DummyClass As New cDummy
End Type
Public Property Get CollectionItem - Retrieve an UDT stored in the collection
Public Property Let CollectionItem - Update an UDT from the collection
Public Sub CollectionAdd - add a new UDT to the collectionCode:
Option Explicit
Private Sub PrintItem(tUDT As UDT)
With tUDT
Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .Date
End With
End Sub
Private Sub Form_Click()
Dim tUDT As UDT, i As Long
i = Rand(1, 20)
tUDT = CollectionItem(i, tUDT): PrintItem tUDT ' Retrieve an UDT from the collection and print the values of its members
With tUDT
If .Value > 0 Then
.Value = -.Value
.Date = "This date has been reset!"
.Year = "NULL"
.ByteArray = StrConv(.Year, vbFromUnicode)
Set .Picture = Nothing
.DummyClass.ID = -.ID
CollectionItem(i, tUDT) = tUDT ' Update the collection with the modified UDT
End If
End With
End Sub
Private Sub Form_Load()
Dim tUDT As UDT, i As Long
Randomize
For i = 1 To 20
With tUDT
.ID = i
.Value = 10000 * Rnd
.Date = Format$(DateSerial(Rand(1970, 2024), Rand(1, 12), Rand(1, 31)), "dddd, mmmm dd yyyy")
.Year = Right$(.Date, 4)
.ByteArray = StrConv(UCase$(Left$(.Date, InStr(.Date, ",") - 1)), vbFromUnicode)
Set .Picture = Icon
.DummyClass.ID = i
End With
CollectionAdd tUDT ' Create a new UDT with random values and add it to the collection
Next i
End Sub
Private Function Rand(lMin As Long, lMax As Long) As Long
Rand = Int((lMax - lMin + 1) * Rnd + lMin)
End FunctionCode:
Option Explicit
Private Type VTable
VTable(0 To 2) As Long
End Type
Public Type UDT
ID As Long
Value As Currency
Date As String
Year As String * 4
ByteArray() As Byte
Picture As IPicture
DummyClass As New cDummy
End Type
Private Type ObjectUDT
pVTable As Long
RefCount As Long
tUDT As UDT
End Type
Private Declare Sub CopyBytesZero Lib "msvbvm60" Alias "#184" (ByVal Length As Long, Destination As Any, Source As Any)
Private Declare Sub PutMem4 Lib "msvbvm60" Alias "#307" (Ptr As Any, ByVal NewVal As Long)
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cbMem As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal lpMem As Long)
Private m_VTable As VTable, m_pVTable As Long, colUDT As New Collection
Private Property Get GetVTablePointer() As Long
Dim i As Long
If m_pVTable = 0 Then ' one-time VTable creation for this UDT object
With m_VTable
For i = LBound(.VTable) To UBound(.VTable)
.VTable(i) = Choose(i + 1, AddressOf QueryInterfaceUDT, AddressOf AddRefUDT, AddressOf ReleaseUDT)
Next i
End With
m_pVTable = VarPtr(m_VTable)
End If
GetVTablePointer = m_pVTable
End Property
Private Function QueryInterfaceUDT(This As ObjectUDT, ByVal rIID As Long, pObj As Long) As Long
Const E_NOINTERFACE As Long = &H80004002
Debug.Assert False ' QueryInterface shouldn't be called
pObj = 0: QueryInterfaceUDT = E_NOINTERFACE
End Function
Private Function AddRefUDT(This As ObjectUDT) As Long
With This
.RefCount = .RefCount + 1: AddRefUDT = .RefCount ' Increase the reference count for this UDT object
End With
End Function
Private Function ReleaseUDT(This As ObjectUDT) As Long
With This
.RefCount = .RefCount - 1: ReleaseUDT = .RefCount ' Decrease the reference count for this UDT object
If .RefCount = 0 Then DeleteThis VarPtr(This) ' Clean up the resources taken by this UDT object when the reference count reaches zero
End With
End Function
Private Sub DeleteThis(pThis As Long)
Dim tCopyUDT As ObjectUDT
CopyBytesZero LenB(tCopyUDT), ByVal VarPtr(tCopyUDT), ByVal pThis ' Automatically release any Strings, Arrays or Objects stored in this UDT as soon as the function exits
CoTaskMemFree pThis ' Free the previously allocated memory for this UDT object
End Sub
Private Function CreateInstance(tUDT As UDT) As IUnknown
Dim pThis As Long
pThis = CoTaskMemAlloc(LenB(tUDT) + 8) ' Allocate memory for this UDT plus an additional 8 bytes for the VTable pointer and reference count
If pThis Then
PutMem4 ByVal pThis, GetVTablePointer: PutMem4 ByVal pThis + 4, 1& ' Initialize the VTable pointer and reference count for this UDT object
CopyBytesZero LenB(tUDT), ByVal pThis + 8, ByVal VarPtr(tUDT) ' Copy the UDT contents to the newly allocated memory and erase the original to prevent unwanted deallocations
PutMem4 CreateInstance, pThis ' Complete the creation of this UDT object
End If
End Function
Public Property Get CollectionItem(ByVal lIndex As Long, tUDT As UDT) As UDT ' The "tUDT" parameter is just a generic placeholder to reserve space on the stack
If lIndex > 0 And lIndex <= colUDT.Count Then
PutMem4 ByVal VarPtr(lIndex) + 4, ObjPtr(colUDT(lIndex)) + 8 ' Now the "tUDT" parameter points to the corresponding UDT member stored in the collection
CollectionItem = tUDT
End If
End Property
Public Property Let CollectionItem(ByVal lIndex As Long, tUDT As UDT, tmpUDT As UDT) ' The "tUDT" parameter is just a generic placeholder to reserve space on the stack
If lIndex > 0 And lIndex <= colUDT.Count Then
PutMem4 ByVal VarPtr(lIndex) + 4, ObjPtr(colUDT(lIndex)) + 8 ' Now the "tUDT" parameter points to the corresponding UDT member stored in the collection
tUDT = tmpUDT
End If
End Property
Public Sub CollectionAdd(tUDT As UDT, Optional Before, Optional After)
colUDT.Add CreateInstance(tUDT), , Before, After ' Create a new instance of this UDT and add it to the collection
End SubHere's the demo project: CollectionUDT.zip