VB6 - Add/Modify UDTs (User Defined Types) to/from a VB6 Collection (No ActiveX DLL)

[VanGoghGaming]

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):

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 collection

Public Sub CollectionRemove - Remove an UDT from the collection (by its numeric Index or its Key string)

frmCollectionUDT form. Just click on the form to print and modify UDTs from the collection:

Option Explicit

Private Sub cmdIterateCollectionByIndex_Click()
Dim i As Long
    For i = 1 To CollectionCount
        With CollectionItem(i)
            If Weekday(.Date) = vbSunday Then
                Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .DateString
            End If
        End With
    Next i
    Debug.Print String$(110, 45)
End Sub

Private Sub cmdIterateCollectionForEach_Click()
Dim colItem As Object
    For Each colItem In GetCollection
        With CollectionItem(colItem)
            If Weekday(.Date) = vbSunday Then
                Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .DateString
            End If
        End With
    Next colItem
    Debug.Print String$(110, 45)
End Sub

Private Sub Form_Click()
Dim tUDT As UDT, i As Long
    If CollectionCount > 0 Then
        i = Rand(1, CollectionCount)
        tUDT = CollectionItem(i) ' Retrieve an UDT from the collection (by its numeric Index) and print the values of its members
        With tUDT
            Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .DateString
            If .Value > 0 Then
                .Value = -.Value
                .DateString = "This date has been reset!"
                .Year = "NULL"
                .ByteArray = StrConv(.Year, vbFromUnicode)
                Set .Picture = Nothing
                .DummyClass.ID = -.ID
                CollectionItem("Key" & .ID) = tUDT ' Update the collection with the modified UDT (by its Key string this time)
            Else
                CollectionRemove i ' Remove this element from the collection (by its numeric Index)
                Debug.Print "Element with ID = " & .ID & " has been removed from the collection! Remaining elements: " & CollectionCount
            End If
        End With
    Else
        Debug.Print "Collection is empty!"
    End If
End Sub

Private Sub Form_Load()
Dim tUDT As UDT, i As Long
    Randomize
    For i = 1 To 30
        With tUDT
            .ID = i
            .Value = 10000 * Rnd
            .Date = DateSerial(Rand(1970, 2024), Rand(1, 12), Rand(1, 31))
            .DateString = Format$(.Date, "dddd, mmmm dd yyyy")
            .Year = Right$(.Date, 4)
            .ByteArray = StrConv(UCase$(Left$(.DateString, InStr(.DateString, ",") - 1)), vbFromUnicode)
            Set .Picture = Icon
            .DummyClass.ID = i
        End With
        CollectionAdd tUDT, "Key" & i ' 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 Function

mdlCollectionUDT BAS module:

Option Explicit

Public Type UDT
    ID As Long
    Value As Currency
    Date As Date
    DateString As String
    Year As String * 4
    ByteArray() As Byte
    Picture As IPicture
    DummyClass As New cDummy
End Type

Private Type VTable
    VTable(0 To 2) As Long
End Type

Private Type ObjectUDT
    pVTable As Long
    RefCount As Long
End Type

Private Enum HRESULT
    S_OK = 0
    S_FALSE = 1
    E_NOTIMPL = &H80004001
    E_NOINTERFACE = &H80004002
    E_POINTER = &H80004003
    E_ABORT = &H80004004
    E_FAIL = &H80004005
    E_ACCESSDENIED = &H80070005
    E_HANDLE = &H80070006
    E_OUTOFMEMORY = &H8007000E
    E_INVALIDARG = &H80070057
    E_UNEXPECTED = &H8000FFFF
End Enum

Private Const sIID_IUnknown As String = "{00000000-0000-0000-C000-000000000046}", sIID_IProvideClassInfo As String = "{B196B283-BAB4-101A-B69C-00AA00341D07}"

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 Declare Function IsEqualGUID Lib "ole32" (rGUID1 As Any, rGUID2 As Any) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpString As Long, rIID As Any) As Long
Private Declare Function StringFromIID Lib "ole32" (ByVal rIID As Long, lpString As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" Alias "#3" (ByVal pBSTR As Long, ByVal lpString As Long) As Long

Private m_VTable As VTable, m_pVTable As Long, IID_IUnknown(0 To 1) As Currency, IID_IProvideClassInfo(0 To 1) As Currency, colUDT As New Collection

Public Function StringFromGUID(ByVal rIID As Long) As String
    If StringFromIID(rIID, rIID) = S_OK Then SysReAllocString VarPtr(StringFromGUID), rIID: CoTaskMemFree rIID
End Function

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): IIDFromString StrPtr(sIID_IUnknown), IID_IUnknown(0): IIDFromString StrPtr(sIID_IProvideClassInfo), IID_IProvideClassInfo(0)
    End If
    GetVTablePointer = m_pVTable
End Property

Private Function QueryInterfaceUDT(This As ObjectUDT, ByVal rIID As Long, pObj As Long) As HRESULT
    If IsEqualGUID(ByVal rIID, IID_IUnknown(0)) Then ' This object implements only IUnknown
        AddRefUDT This: pObj = VarPtr(This)
    ElseIf IsEqualGUID(ByVal rIID, IID_IProvideClassInfo(0)) Then
        QueryInterfaceUDT = E_NOTIMPL ' Only when setting a breakpoint, the IDE will query this object for the "IProvideClassInfo" interface which obviously isn't implemented...
    Else
        pObj = 0: QueryInterfaceUDT = E_NOINTERFACE
    End If
    Debug.Print StringFromGUID(rIID)
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) ' Free the resources taken by this UDT object when the reference count reaches zero
    End With
End Function

Private Sub DeleteThis(pThis As Long)
Dim tUDT As UDT
    CopyBytesZero LenB(tUDT), ByVal VarPtr(tUDT), ByVal pThis + 8 ' Automatically release any Strings, Arrays or Objects stored in this UDT as soon as "tUDT" goes out of scope
    CoTaskMemFree pThis ' Free the previously allocated memory for this UDT object
End Sub

Private Function CreateInstance(tUDT As UDT) As Object
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

Private Sub GetLetUDT(tPlaceHolder As UDT, ByVal pUDT As Long, tUDT As UDT, Optional bLet As Boolean) ' The "tPlaceHolder" parameter is just a generic placeholder to reserve space on the stack
    PutMem4 ByVal VarPtr(pUDT) - 4, pUDT ' Now the "tPlaceHolder" parameter points to the corresponding UDT member stored in the collection
    If Not bLet Then tUDT = tPlaceHolder Else tPlaceHolder = tUDT
End Sub

Public Property Get CollectionItem(vItem As Variant) As UDT
Dim pUDT As Long
    If (VarType(vItem) And vbObject) = vbObject Then pUDT = ObjPtr(vItem) + 8 Else pUDT = ObjPtr(colUDT(vItem)) + 8
    GetLetUDT CollectionItem, pUDT, CollectionItem
End Property

Public Property Let CollectionItem(vItem As Variant, tRHS As UDT)
Dim pUDT As Long
    If (VarType(vItem) And vbObject) = vbObject Then pUDT = ObjPtr(vItem) + 8 Else pUDT = ObjPtr(colUDT(vItem)) + 8
    GetLetUDT tRHS, pUDT, tRHS, True
End Property

Public Sub CollectionAdd(tUDT As UDT, Optional vKey As Variant, Optional vBefore As Variant, Optional vAfter As Variant)
    colUDT.Add CreateInstance(tUDT), vKey, vBefore, vAfter ' Create a new instance of this UDT and add it to the collection
End Sub

Public Sub CollectionRemove(vIndexOrKey As Variant)
    colUDT.Remove vIndexOrKey ' Can be a numeric Index or a string Key
End Sub

Public Property Get CollectionCount() As Long
    CollectionCount = colUDT.Count
End Property

Public Property Get GetCollection() As Collection
    Set GetCollection = colUDT
End Property

The UDT also contains a "Dummy" class member for demonstration purposes just to show how each object fires its "Class_Terminate" event when the UDT is removed from the collection or when the collection is destroyed.

Here's the demo project: CollectionUDT.zip

[VanGoghGaming]

For the sake of completeness and to take full advantage of the features offered by a collection (as opposed to, say, an array), I've updated the example above to include managing the UDTs from the collection either by their numeric Indexes or by their string Keys.

[Schmidt]

If you add the two following Private Helper-Routines to your module...

Private Sub CopyFromCol(ColPlaceHolder As UDT, ByVal pUDT As Long, Dst As UDT)
    PutMem4 ByVal VarPtr(pUDT) - 4, pUDT
    Dst = ColPlaceHolder
End Sub
Private Sub CopyToCol(ColPlaceHolder As UDT, ByVal pUDT As Long, Src As UDT)
    PutMem4 ByVal VarPtr(pUDT) - 4, pUDT
    ColPlaceHolder = Src
End Sub

...then the Public Prop Get/Let pair could be written in a less confusing way (with only one single Param):

Public Property Get CollectionItem(vKey As Variant) As UDT
    Dim ColPlaceHolder As UDT
    CopyFromCol ColPlaceHolder, ObjPtr(colUDT(vKey)) + 8, CollectionItem
End Property
Public Property Let CollectionItem(vKey As Variant, tRHS As UDT)
    Dim ColPlaceHolder As UDT
    CopyToCol ColPlaceHolder, ObjPtr(colUDT(vKey)) + 8, tRHS
End Property

Olaf

[VanGoghGaming]

Very nice suggestion Olaf, cheers! It's not even necessary to declare the local "Dim ColPlaceHolder As UDT" since you already have such a placeholder readily available in the name of the property and a single helper routine does the job:

Private Sub GetLetUDT(tPlaceHolder As UDT, ByVal pUDT As Long, tUDT As UDT, Optional bLet As Boolean)
    PutMem4 ByVal VarPtr(pUDT) - 4, pUDT
    If Not bLet Then tUDT = tPlaceHolder Else tPlaceHolder = tUDT
End Sub

Public Property Get CollectionItem(vIndexOrKey As Variant) As UDT
    GetLetUDT CollectionItem, ObjPtr(colUDT(vIndexOrKey)) + 8, CollectionItem
End Property

Public Property Let CollectionItem(vIndexOrKey As Variant, tRHS As UDT)
    GetLetUDT tRHS, ObjPtr(colUDT(vIndexOrKey)) + 8, tRHS, True
End Property

[taishan]

Very nice suggestion Olaf, cheers! It's not even necessary to declare the local "Dim ColPlaceHolder As UDT" since you already have such a placeholder readily available in the name of the property and a single helper routine does the job:

I'm certain I've come across a time when this would be strategically awesome. Maybe for sprites?

[VanGoghGaming]

Just updated the first post and added the possibility to iterate the UDT collection using the "For...Each" syntax in addition to the classic iteration by index.

Private Sub cmdIterateCollectionForEach_Click()
Dim colItem As Object
    For Each colItem In GetCollection
        With CollectionItem(colItem)
            If Weekday(.Date) = vbSunday Then
                Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .DateString
            End If
        End With
    Next colItem
    Debug.Print String$(110, 45)
End Sub

I'm certain I've come across a time when this would be strategically awesome. Maybe for sprites?

There are many scenarios where you could use this, imagination is the limit. The main advantages of a collection are that you can always remove an arbitrary item as well as add more items as needed. Also using the "Before" and "After" parameters you can keep the collection already sorted by always inserting items at the appropriate position.

Another pet peeve of mine is that you can't declare UDT parameters as "Optional". By packaging them as objects you can easily make them optional now:

Private Sub TestOptionalUDT(Optional vUDT As Variant)
    If Not IsMissing(vUDT) Then
        With CollectionItem(vUDT)
            Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .DateString
        End With
    End If
End Sub

[yokesee]

good job VanGoghGaming