Results 1 to 7 of 7

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

  1. #1

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,539

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

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

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

  2. #2

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,539

    Talking Re: VB6 - Add/Modify UDTs (User Defined Types) to/from a VB6 Collection (No ActiveX D

    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.

  3. #3
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,289

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

    If you add the two following Private Helper-Routines to your module...
    Code:
    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):
    Code:
    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

  4. #4

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,539

    Red face Re: VB6 - Add/Modify UDTs (User Defined Types) to/from a VB6 Collection (No ActiveX D

    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:

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

  5. #5
    Addicted Member
    Join Date
    Feb 2022
    Posts
    189

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

    Quote Originally Posted by VanGoghGaming View Post
    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?

  6. #6

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,539

    Talking Re: VB6 - Add/Modify UDTs (User Defined Types) to/from a VB6 Collection (No ActiveX D

    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.

    Code:
    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
    Quote Originally Posted by taishan View Post
    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:

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

  7. #7
    Fanatic Member
    Join Date
    Jun 2016
    Location
    EspaƱa
    Posts
    514

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

    good job VanGoghGaming

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width