Create class for instantiation at runtime

I'm really just spit-balling here, but this is something I'd use if I could do it.

Is there a way to dynamically (at runtime) create a class that could then be used for instantiating objects?

Sure, I know it'd be exceedingly difficult to compile code at runtime. However, I'm just thinking of an object that just has some simple properties, no real code.

Said differently, I'm wondering if we can take a simple UDT and turn it into a class at runtime. It seems like we should be able to stick a standard IUnknown header on it (QueryInterface, AddRef, Release, and a RefCount somewhere) and create a class. Sure, it might take a bit of a thunk, but this doesn't seem huge, if it's nothing but simple properties.

For this one, I'm not even exactly sure where to start. Or maybe it's a bigger project than I'm thinking.

Thanks,
Elroy

Why not just convert the UDTs to classes?

Hi DllHell,

Well, I suppose more than anything, I just hate the idea of cluttering my project with all those class modules. And it's frustrating that we can't write "in-line" classes like many other languages can.

If these runtime classes are possible, we'd effectively have the ability to create these in-line classes.

Regards,
Elroy

EDIT1: Also, I just did a rough count (searching for "Private Type" and "Public Type") in my primary project, and I've got about 200 UDTs in it. I'd hate to see all of those in my main project window.

I've done something similar using disconnected recordsets.

1. All the definitions\factory functions can be in a single module\node on your project tree
2. Fields are typed and you can use Null if you need to
3. Easy adding and removing of records
4. Easy filtering, searching, sorting
5. Easy serialization and deserialization

The biggest problem for me was dealing with nested UDTs but you can deal using a fk column or stuffing a memo field with a serialized recordset (beware performance for large objects).

edit: you could also put them into a dll and ref that in your project.

So basically like an IDispatch/Object class with dynamic latebound only members that wrap a UDT maybe describe by an Typelib via IRecordInfo?

Disconnected Recordsets is a good option, and is what I would probably use though.

Quote:

---

Originally Posted by DllHell

The biggest problem for me was dealing with nested UDTs but you can deal using a fk column or stuffing a memo field with a serialized recordset (beware performance for large objects).

---

You can use the Data Shaping Provider to fabricate hierarchical Recordsets without ever connecting them to a Data Provider (database, text files, etc.). These can be persisted just like a flat Recordset.

Code:

---

    Set rsShapedData = New ADODB.Recordset
    With rsShapedData
        .ActiveConnection = "Provider=MSDataShape;Data Provider=None;"

        .Open "SHAPE APPEND " _
            & "NEW adInteger AS [MessageID], " _
            & "NEW adUnsignedTinyInt AS [Some Info], " _
            & "NEW adUnsignedTinyInt AS [Other Info], " _
            & "NEW adLongVarWChar AS [Blah Blah Blah], " _
            & "((" _
            & "SHAPE APPEND " _
            & "NEW adInteger AS [ParentID], " _
            & "NEW adUnsignedTinyInt AS [W], " _
            & "NEW adUnsignedTinyInt AS [X], " _
            & "NEW adUnsignedTinyInt AS [Y], " _
            & "NEW adLongVarWChar AS [Word] " _
            & ") RELATE [MessageID] TO [ParentID]" _
            & ") AS [Words]", _
              , adOpenStatic, adLockOptimistic

        'Add sample records to the parent recordset.
        For I = 1 To 10
            .AddNew Array("MessageID", "Some Info", "Other Info", "Blah Blah Blah"), _
                    Array(I, 3 * I, 5 * I, "blah-blah" & CStr(I))

            'Now add sample child records related to the original
            'parent's record.
            Set rsWords = !Words.Value
            With rsWords
                For J = 1 To 5
                    rsWords.AddNew Array("ParentID", "W", "X", "Y", "Word"), _
                                  Array(I, J Mod 5, 3 * J, 5 * J, "junk" & CStr(I + J))
                Next
                .Close
            End With
        Next
    End With

---

Do you mean the lightweight-object or?

Quote:

---

Originally Posted by dilettante

You can use the Data Shaping Provider to fabricate hierarchical Recordsets without ever connecting them to a Data Provider (database, text files, etc.). These can be persisted just like a flat Recordset.

---

Thanks for sharing this, it will be handy in the future.

At the place where I work, we're using (in the meantime) more and more VBScript-Classes inside our larger App
(mostly to achieve much easier to maintain BusinessLayer-CodeModules, which change often -
changes on those Classes are then easy to "update and rollout without any recompiling" via a simple online-update -
(all the VBScript Class-Definitions are landed in a Webserver-side-DB first - and will be downloaded from there into the Customers local DBServer).

These VBScript-Classes can be instantiated into normal LateBound ( "As Object" defined) VB-Class-Variables,
and then used from there within normal VB6-Code.

Here's a very simple example:

Code:

---

Option Explicit

Private SC As Object ' As cActiveScript
Private C1 As Object, C2 As Object

Private Sub Form_Load()
  'Set SC = New_c.ActiveScript("VBScript")
  Set SC = CreateObject("MSScriptControl.ScriptControl"): SC.Language = "VBScript"

      SC.AddCode "Class Class1: Public A, B, C : End Class"
      SC.AddCode "Class Class2: Public x, y, z : End Class"
     
  Set C1 = SC.Eval("New Class1") 'get a new Class1-Instance from the ScriptEngine
      C1.A = "foo"
      C1.B = "bar"
      C1.C = "baz"
 
  Set C2 = SC.Eval("New Class2") 'get a new Class2-Instance from the ScriptEngine
      C2.x = 1
      C2.y = 2
      C2.z = 3
End Sub

Private Sub Form_Click() 'read-out of the VBScript-generated ClassVariables-Contents
  AutoRedraw = True: Cls
  Print C1.A, C1.B, C1.C
  Print C2.x, C2.y, C2.z
End Sub

---

Just changed the above Code from the RC5-SC-Engine to the MS-ScriptControl, which is sufficient for that simple example...

Olaf

Hmmm, well, the idea of a disconnected recordset is certainly interesting, but I'm thinking the lightweight object is more what I'm after.

But, before discarding the disconnected recordset, I tweaked on Dilettante's code (removing the one-to-many relationship, and just generally simplified it), and came up with the following:

Code:

---


Option Explicit
'
' Microsoft ActiveX Data Objects 6.1 Library <---- used as the ADO reference.
Dim rsShapedData As New ADODB.Recordset
'

Private Sub Form_Load()
    Dim i As Long, j As Long
    '
    ' Create and open disconnected recordset.
    rsShapedData.ActiveConnection = "Provider=MSDataShape;Data Provider=None;"
    rsShapedData.Open "SHAPE APPEND NEW adInteger AS [Field1], NEW adUnsignedTinyInt AS [Field2], NEW adLongVarWChar AS [Field3]", , adOpenStatic, adLockOptimistic
    '
    ' Add some records.
    For i = 1 To 10
        rsShapedData.AddNew Array("Field1", "Field2", "Field3"), Array(i, 3 * i, "blah-blah" & CStr(i))
    Next
    '
    ' Dump the records.
    rsShapedData.MoveFirst
    Do
        Debug.Print rsShapedData![Field1], rsShapedData![Field2], rsShapedData![Field3]
        rsShapedData.MoveNext
    Loop While Not rsShapedData.EOF
    '
End Sub



---

That code is quite interesting, and certainly provides a way to track UDT-like array data in memory. Also, if Dilettante's one-to-many relationship were re-instated, it could handle UDT-like arrays nested in other UDT-like records, accomplishing (functionally) about everything UDTs will do with the added advantage of having all the ADO navigation procedures for "array" iteration. Also, as a straight-up object, these ADO recordsets could easily be put into Variants and/or passed anyway we like.
That, in and of itself, makes this thread worthwhile.

-----------------------

However, I think a lightweight object was more what I was thinking. Also, it'll give me the opportunity to learn more about COM objects. I found this post by Dex and this post by Trick. I'd really like to do it without the need for a TypeLib, so I studied Dex's ideas. However, Dex isn't creating the interface from scratch. Rather, he's showing us how to create a lightweight object using the IEnumVARIANT interface.

On the other hand, Trick is creating the interface and the object. But he's using a TypeLib to get it done. I'm going to further study Dex's approach, but I'm hoping there's a way to create the interface and instantiate the object without the need for a TypeLib.

Y'all Take Care,
Elroy

EDIT1: Ahhh, sorry Olaf. I took forever to compose my post, and didn't see yours until after I posted mine.

Here's another interesting aspect of these "on the fly creatable" Scripting-generated COM-Classes:

They "die fast".

Not sure whether you've ever tried to create "a ton of smaller Class-Instances" (as e.g. Points or Vectors) in the range of > 100Tsd in VB6?
Well - prepare for a surprise, as soon as you try to delete the Array(s) or Collection(s) which held that amount.

Here is a performance-comparison:

Code:

---

Option Explicit

Private SC As Object, CO As Object
 
Private Sub Form_Load()
  Set SC = CreateObject("MSScriptControl.ScriptControl"): SC.Language = "VBScript"
    'create a Vector-Class with 3 Members (x, y, z)
      SC.AddCode "Class cVector: Public x, y, z : End Class"
     
    'create a Constructor-Function for fast(er) instancing via SC.CodeObject
      SC.AddCode "Function NewVector(x, y, z) " & vbCrLf & _
                    "Set  NewVector = New cVector" & vbCrLf & _
                    "With NewVector: .x=x: .y=y: .z=z: End With" & vbCrLf & _
                "End Function"

    Set CO = SC.CodeObject 'the CodeObject allows direct latebound-access to Script-Functions
End Sub

Private Sub Command1_Click() 'a larger amount of VBScript-generated Class-Instances will "die" much faster...
  Static Col As New Collection, T!, i&
  T = Timer
    If Col.Count = 0 Then
      For i = 1 To 150000: Col.Add CO.NewVector(i, i, i): Next
    Else
      Set Col = Nothing
    End If
  Caption = Timer - T & "sec for " & IIf(Col.Count, "con", "de") & "struction"
End Sub

Private Sub Command2_Click() 'whilst normal VB6-Classes "take forever", when there's more than 100000 instances of them
  Static Col As New Collection, T!, i&
  Dim C1 As Class1 '<- this Class1-Type needs to be created on your own (with Public Members x, y and z)
  T = Timer
    If Col.Count = 0 Then
      For i = 1 To 150000
          Set C1 = New Class1: C1.x = i: C1.y = i: C1.z = i
          Col.Add C1
      Next
    Else
      Set Col = Nothing
    End If
  Caption = Timer - T & "sec for " & IIf(Col.Count, "con", "de") & "struction"
End Sub

---

Olaf

Well Olaf, I must admit, your use of the MSScriptControl engine is quite interesting. You seem to have shown us how to easily create and instantiate "in-line" classes with very little effort.

It's also interesting that the fundamental variable type in VBScript is a Variant. I've never messed with VBScript that much, but I'm assuming that these Variants give us all the glory that a VB6 Variant gives us, which would mean that we could easily do VBScript object nesting. Also, it seems that arrays are easy, and that the Variants will also hold arrays (all quite similar to VB6).

I'm tempted to take this approach and write a procedure named VBScriptCreateObject with some ParamArrays for specifying the property names. It all almost seems too easy.

I'll test, but I'm wondering how these VBScript classes perform in comparison to VB6 instantiated classes (say, late-bound for a fair comparison). In other words, do we take a hit for them having been created through the MSScriptControl? Or, once their created, do they perform as well as a VB6 object? Again, I'm just thinking about fetching and saving simple property values (much like items in a UDT).

Thanks for the Idea,
Elroy

Quote:

---

Originally Posted by Elroy

It's also interesting that the fundamental variable type in VBScript is a Variant. I've never messed with VBScript that much, but I'm assuming that these Variants give us all the glory that a VB6 Variant gives us

---

in vbs, variant is the only data type. And it really sucks trying to figure out how a string got into a variable that should only have numbers :)

WOW, I don't get it. VBScript is about 3 times faster than native VB6. And that's compiled, with the Optimized for Fast Code turned on, and all the Advanced Optimizations checked.

Attachment 163299

I ran it several times. Also, the VB6 numbers are about the same regardless of whether it's compiled or not.

Here's the code in the Form1. I also attached an entire project (with the TimerEx) so you can try it yourself.

Code:

---


Option Explicit
'
Dim VBScript As Object
'
Dim oVBS As Object
Dim oVB6 As Object
'
Const Iterations As Long = 1000000
'

Private Sub Form_Activate()

    Me.AutoRedraw = True

    VBScriptClassFactory "VBS_Class1", "A"
    Set oVBS = VBScriptCreateObject("VBS_Class1")
    oVBS.A = "VBS"

    Set oVB6 = New Class1
    oVB6.A = "VB6"

    Print "---------------------"
    Print TimerEx; " just to instantiate the timer"

    VBS_Test
    VB6_Test

End Sub

Private Sub VBS_Test()
    Dim i As Long
    Dim s As String
    Dim dStart As Double
    Dim dEnd As Double
    '
    dStart = TimerEx
    For i = 1 To Iterations
        s = oVBS.A
    Next
    dEnd = TimerEx

    Print "VBS Time: "; dEnd - dStart
End Sub

Private Sub VB6_Test()
    Dim i As Long
    Dim s As String
    Dim dStart As Double
    Dim dEnd As Double
    '
    dStart = TimerEx
    For i = 1 To Iterations
        s = oVB6.A
    Next
    dEnd = TimerEx

    Print "VB6 Time: "; dEnd - dStart
End Sub


Public Sub VBScriptClassFactory(sClassName As String, ParamArray vPropertyNames() As Variant)
    ' This is used to create a class using the MSScriptControl.
    ' All of the Properties are Variants with no code.
    ' This is ideal for converting UDTs to classes.
    ' The vPropertyNames() must be all Strings, and have at least one property (and this isn't validated).
    ' Don't forget that VBScript has only ONE fundamental data type, Variant.
    '
    ' The VBScript object must stay instantiated the entire time there are any of its objects in use.
    If VBScript Is Nothing Then Set VBScript = CreateObject("MSScriptControl.ScriptControl"): VBScript.Language = "VBScript"
    '
    Dim s As String
    Dim v As Variant
    s = "Class " & sClassName & ": Public "    ' Get things started.
    For Each v In vPropertyNames                ' Iterate through our desired properties.
        s = s & v & ", "
    Next
    s = Left$(s, Len(s) - 2)                    ' Strip the last ", " off.
    s = s & " : End Class"                      ' Close the class.
    VBScript.AddCode s                          ' Add the class to the MSScriptControl engine.
End Sub

Public Function VBScriptCreateObject(sClassName As String) As Object
    ' Be sure the class is created with VBScriptClassFactory before this is called.
    '
    Set VBScriptCreateObject = VBScript.eval("New " & sClassName)
End Function


---

Here's all that's in the Class1:

Code:

---


Option Explicit

Public A As Variant



---

Puzzled,
Elroy

EDIT1: I also swapped the VBS_Test and VB6_Test ... it made no difference.

Quote:

---

Originally Posted by DllHell

in vbs, variant is the only data type. And it really sucks trying to figure out how a string got into a variable that should only have numbers :)

---

One can always use explicit Property-Defs in a VBScript-Class (instead of the "Short-Notation"),
to enforce what a Class-internal Variant contains - or later gets "handed-out-as".

Example for VBScript-ClassCode:

Code:

---

Class cVectorDbl

  Private m_x, m_y, m_z 'Private Members in m-Notation
 
  Private Sub Class_Initialize()
    m_x = CDbl(0): m_y = CDbl(0): m_z = CDbl(0) 'switch initial Empty-content to explicit zero-Double-content
  End Sub

  Public Property Get x(): x = m_x :End Property
  Public Property Get y(): y = m_y :End Property
  Public Property Get z(): z = m_z :End Property

  Public Property Let x(RHS): m_x = CDbl(RHS) :End Property
  Public Property Let y(RHS): m_y = CDbl(RHS) :End Property
  Public Property Let z(RHS): m_z = CDbl(RHS) :End Property

End Class

---

HTH

Olaf

I had 5 minutes, and found this thread.
Interesting info.
Thanks.

But doing this, using dynamic VBScript, is it not an open door for virus, trojan...
And doing this, is it not flagged by anti-virus as a virus?

Btw, it's possible to generate such COM classes at run-time with the Runtime Tiny C Compiler, although not as easy as w/ the script control because the gory IUnknown/IDispatch impl has to be generated in the limited C subset supported by the VbRtcc.

For IDispatch the generator can produce the early-bound interface only, along with enough ITypeInfo to use DispInvoke to do the heavy lifting to/from Variant params/retvals for late-bound calls.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

Btw, it's possible to generate such COM classes at run-time with the Runtime Tiny C Compiler

---

This also looks like cool stuff. If I could throw in two-cents, I'd sure like to see the line comments "//" as well as the += (and family) on the ToDo list. :) Maybe it's me returning to my VB6 roots, but I almost always use line comments when coding in C, although I do enjoy having the += (etc) syntax.

Best Regards,
Elroy

Quote:

---

Originally Posted by Thierry69

But doing this, using dynamic VBScript, is it not an open door for virus, trojan...

---

You know, Thierry, I've been thinking about your comment. Personally, I see using VBScript in my VB6 program as something entirely different from allowing VBScripts to run in my browser. Regarding browsing, I go to at least 100s (if not 1000s) of web pages a day, with me having no idea of who wrote the code for the vast majority of them. Therefore, sure, if I allowed VBScripts to run in my browser, that may open a door for some danger.

However, with respect to my own program, I certain trust that it has no viruses in it (and I hope my clients trust that as well) ... and that's entirely independent of any VBScript code. Therefore, when I call up the MSScriptControl object for writing some VBScript code, I've still got total control of that code. So, there shouldn't be any increased risk.

I suppose we could suggest that the MSScriptControl library could be infected. But, if that's the case, they've probably already got bigger problems than anything my program did.

Best Regards,
Elroy

Elroy, I mainly think for applications that are distributed to thousands of clients (like mine), and sometimes, they are blocked by some antivirus. Of course always false alerts, but distributing this could maybe increase the number of alerts.

I'll try to investigate if I could find an interest in my applications

You can create IDispatch implementation using CreateStdDispatch function:

Code:

---

' //
' // IDispatch implementation of light-weight COM object
' // By The trick 2018
' //

Option Explicit

Private Const E_INVALIDARG            As Long = &H80070057
Private Const E_NOINTERFACE          As Long = &H80004002

Private Const CC_STDCALL              As Long = 4
Private Const VT_BYREF                As Long = &H4000&

Private Const DISPATCH_PROPERTYPUT    As Long = 4
Private Const DISPATCH_METHOD        As Long = 1
Private Const DISPATCH_PROPERTYGET    As Long = 2
Private Const LOCALE_SYSTEM_DEFAULT  As Long = &H800
Private Const HEAP_ZERO_MEMORY        As Long = &H8
Private Const FADF_AUTO              As Long = 1

Private Type SAFEARRAYBOUND
    cElements  As Long
    lLBound    As Long
End Type

Private Type SAFEARRAY
    cDims      As Integer
    fFeatures  As Integer
    cbElements  As Long
    cLocks      As Long
    pvData      As Long
    Bounds      As SAFEARRAYBOUND
End Type

Private Type UUID
    Data1      As Long
    Data2      As Integer
    Data3      As Integer
    Data4(7)    As Byte
End Type

Private Type PARAMDATA
    pszName    As String
    vt          As Integer
End Type

Private Type METHODDATA
    pszName    As String
    ppdata      As Long
    dispid      As Long
    iMeth      As Long
    cc          As Long
    cArgs      As Long
    wFlags      As Integer
    vtReturn    As Integer
End Type

Private Type INTERFACEDATA
    pmethdata  As Long
    cMembers    As Long
End Type

Private Enum eIUnknownMethods
    METH_IUNKNOWN_QI
    METH_IUNKNOWN_ADDREF
    METH_IUNKNOWN_RELEASE
    METH_IUNKNOWN_COUNT
End Enum

Private Enum eISumDiffMethods
    METH_ISUMDIFF_SETVAL
    METH_ISUMDIFF_GETVAL
    METH_ISUMDIFF_SUM
    METH_ISUMDIFF_DIFF
    METH_ISUMDIFF_COUNT
End Enum

Private Type tIUnknownVTable
    pfn(METH_IUNKNOWN_COUNT - 1)    As Long
End Type

Private Type tISumDiffVtable
    tUnk                            As tIUnknownVTable
    pfn(METH_ISUMDIFF_COUNT - 1)    As Long
End Type

Private Type CBaseClass
    pVtbl                          As Long
    lRefCounter                    As Long
    pDisp                          As Long            ' // Inner object
End Type

' // CSumDiff class
Private Type CSumDiff
    CBase                          As CBaseClass
    lVal1                          As Long
    lVal2                          As Long
End Type

Private Const SIZEOF_CSUMDIFF      As Long = &H14

Private Declare Function CreateDispTypeInfo Lib "OleAut32" ( _
                        ByRef pidata As INTERFACEDATA, _
                        ByVal lcid As Long, _
                        ByRef pptinfo As IUnknown) As Long
Private Declare Function CreateStdDispatch Lib "OleAut32" ( _
                        ByRef punkOuter As Any, _
                        ByRef pvThis As Any, _
                        ByVal ptinfo As IUnknown, _
                        ByRef ppunkStdDisp As Any) As Long
Private Declare Function IsEqualGUID Lib "ole32" ( _
                        ByRef rguid1 As UUID, _
                        ByRef rguid2 As UUID) As Long
Private Declare Function vbaObjSetAddref Lib "MSVBVM60.DLL" _
                        Alias "__vbaObjSetAddref" ( _
                        ByRef dstObject As Any, _
                        ByRef srcObjPtr As Any) As Long
Private Declare Function vbaObjSet Lib "MSVBVM60.DLL" _
                        Alias "__vbaObjSet" ( _
                        ByRef dstObject As Any, _
                        ByRef srcObjPtr As Any) As Long
Private Declare Function vbaCastObj Lib "MSVBVM60.DLL" _
                        Alias "__vbaCastObj" ( _
                        ByRef dstObject As Any, _
                        ByRef pIID As UUID) As Long
Private Declare Function HeapAlloc Lib "kernel32" ( _
                        ByVal hHeap As Long, _
                        ByVal dwFlags As Long, _
                        ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" ( _
                        ByVal hHeap As Long, _
                        ByVal dwFlags As Long, _
                        ByVal lpMem As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                        ByRef src As Any, _
                        ByRef dst As Any) As Long
Private Declare Sub MoveArray Lib "msvbvm60" _
                    Alias "__vbaAryMove" ( _
                    ByRef Destination() As Any, _
                    ByRef Source As Any)
Private Declare Sub IIDFromString Lib "ole32" ( _
                    ByVal lpsz As Long, _
                    ByRef lpiid As UUID)

Sub Main()
    Dim cObj    As Object
   
    ' // Restrictions:
    ' // You should destroy the object before ending
   
    Set cObj = CreateSumDiffObject(10, 20)
   
    cObj(0) = 54
    cObj(1) = 20
   
    Debug.Print cObj.Sum
    Debug.Print cObj.Diff
   
    cObj.Value(0) = 1231
    cObj.Value(1) = 2000
   
    Debug.Print cObj(0)
    Debug.Print cObj.Value(1)
   
    Set cObj = Nothing

End Sub
 
' // Create SumDiff object
Public Function CreateSumDiffObject( _
                ByVal lVal1 As Long, _
                ByVal lVal2 As Long) As IUnknown
    Static tInterfaceInfo  As INTERFACEDATA    ' // Global data
    Static cTypeInfo        As IUnknown
   
    Dim tObj()      As CSumDiff
    Dim pObj        As Long
    Dim tArrDesk    As SAFEARRAY
    Dim hr          As Long
    Dim cUnkDisp    As IUnknown
   
    ' // Get the interface data and create TypeInfo
    If tInterfaceInfo.pmethdata = 0 Then
       
        tInterfaceInfo = CSumDiff_InterfaceData()
       
        hr = CreateDispTypeInfo(tInterfaceInfo, LOCALE_SYSTEM_DEFAULT, cTypeInfo)
        If hr < 0 Then Exit Function
   
    End If
   
    ' // Alloc memory for the object and map it to the array item
    pObj = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, SIZEOF_CSUMDIFF)
   
    tArrDesk.cDims = 1
    tArrDesk.Bounds.cElements = 1
    tArrDesk.fFeatures = FADF_AUTO          ' // Don't free memory after destroying of array
    tArrDesk.pvData = pObj
    tArrDesk.cbElements = SIZEOF_CSUMDIFF
   
    MoveArray tObj, VarPtr(tArrDesk)
   
    ' // Call constructor
    If CSumDiff_CSumDiff(tObj(0)) = 0 Then
        HeapFree GetProcessHeap(), 0, ByVal pObj
        Exit Function
    End If
   
    ' // Initial values
    tObj(0).lVal1 = lVal1
    tObj(0).lVal2 = lVal2
   
    ' // Create aggregated IDispatch
    hr = CreateStdDispatch(tObj(0), tObj(0), cTypeInfo, tObj(0).CBase.pDisp)
   
    If hr < 0 Then
        HeapFree GetProcessHeap(), 0, ByVal pObj
        Exit Function
    End If

    vbaObjSetAddref CreateSumDiffObject, ByVal pObj
   
    Debug.Print "Object CSumDiff created at 0x" & Hex$(pObj)
   
End Function

Private Function FAR_PROC( _
                ByVal lValue As Long) As Long
    Dim bIsInIDE    As Boolean
   
    ' // AddressOf statement actually returns the pointer to the small thunk which checks if code is running or not
    ' // When you see an object variable in the Watch window the code is stopped. We need to avoid that behavior
    ' // because some interfaces returns the HRESULT value and it'll cause unexpected behavior (return S_OK)
   
    Debug.Assert MakeTrue(bIsInIDE)
   
    If bIsInIDE Then
        GetMem4 ByVal lValue + &H16, FAR_PROC  ' // Skip thunk
    Else
        FAR_PROC = lValue
    End If
   
End Function

Private Function MakeTrue( _
                ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function

' // Base class constructor
Private Function CBaseClass_CBaseClass( _
                ByRef tObj As CBaseClass) As Long
    Static tVtable  As tIUnknownVTable
   
    tObj.lRefCounter = 0
    tObj.pVtbl = VarPtr(tVtable)
   
    If tVtable.pfn(METH_IUNKNOWN_QI) = 0 Then
       
        tVtable.pfn(METH_IUNKNOWN_QI) = FAR_PROC(AddressOf CBaseClass_QueryInterface)
        tVtable.pfn(METH_IUNKNOWN_ADDREF) = FAR_PROC(AddressOf CBaseClass_AddRef)
        tVtable.pfn(METH_IUNKNOWN_RELEASE) = FAR_PROC(AddressOf CBaseClass_Release)
       
    End If
   
    CBaseClass_CBaseClass = 1
   
End Function

' // Base class methods
Private Function CBaseClass_QueryInterface( _
                ByRef tObj As CBaseClass, _
                ByRef tiid As UUID, _
                ByRef pOut As Long) As Long
    Static tIUnk    As UUID, tIDisp    As UUID
   
    If tIUnk.Data1 = 0 Then
       
        IIDFromString StrPtr("{00000000-0000-0000-C000-000000000046}"), tIUnk
        IIDFromString StrPtr("{00020400-0000-0000-C000-000000000046}"), tIDisp

    End If
       
    Select Case True
    Case IsEqualGUID(tiid, tIUnk)
       
        pOut = VarPtr(tObj)
       
        CBaseClass_AddRef tObj
       
    Case IsEqualGUID(tiid, tIDisp)
       
        ' // Return aggregable object
        pOut = vbaCastObj(ByVal tObj.pDisp, tIDisp)

    Case Else
   
        pOut = 0:  CBaseClass_QueryInterface = E_NOINTERFACE
        Exit Function
       
    End Select
   
End Function

Private Function CBaseClass_AddRef( _
                ByRef tObj As CBaseClass) As Long
   
    tObj.lRefCounter = tObj.lRefCounter + 1
    CBaseClass_AddRef = tObj.lRefCounter
   
End Function

Private Function CBaseClass_Release( _
                ByRef tObj As CBaseClass) As Long
   
    tObj.lRefCounter = tObj.lRefCounter - 1
    CBaseClass_Release = tObj.lRefCounter
   
    If CBaseClass_Release = 0 Then
       
        vbaObjSet tObj.pDisp, ByVal 0&
       
        ' // Destructor
        HeapFree GetProcessHeap(), 0, VarPtr(tObj)
       
        Debug.Print "Object was destroyed at 0x" & Hex$(VarPtr(tObj))
       
    End If
   
End Function

' // CSumDiff constructor
Private Function CSumDiff_CSumDiff( _
                ByRef tObj As CSumDiff) As Long
    Static tVtable  As tISumDiffVtable
   
    If CBaseClass_CBaseClass(tObj.CBase) = 0 Then Exit Function
   
    tObj.CBase.pVtbl = VarPtr(tVtable)
    tObj.lVal1 = 0
    tObj.lVal2 = 0
   
    If tVtable.pfn(METH_ISUMDIFF_SETVAL) = 0 Then
       
        tVtable.tUnk.pfn(METH_IUNKNOWN_QI) = FAR_PROC(AddressOf CBaseClass_QueryInterface)
        tVtable.tUnk.pfn(METH_IUNKNOWN_ADDREF) = FAR_PROC(AddressOf CBaseClass_AddRef)
        tVtable.tUnk.pfn(METH_IUNKNOWN_RELEASE) = FAR_PROC(AddressOf CBaseClass_Release)
        tVtable.pfn(METH_ISUMDIFF_SETVAL) = FAR_PROC(AddressOf CSumDiff_SetVal)
        tVtable.pfn(METH_ISUMDIFF_GETVAL) = FAR_PROC(AddressOf CSumDiff_GetVal)
        tVtable.pfn(METH_ISUMDIFF_SUM) = FAR_PROC(AddressOf CSumDiff_Sum)
        tVtable.pfn(METH_ISUMDIFF_DIFF) = FAR_PROC(AddressOf CSumDiff_Diff)
       
    End If
                   
    CSumDiff_CSumDiff = 1
                   
End Function

' // CSumDiff methods
Private Function CSumDiff_SetVal( _
                ByRef tObj As CSumDiff, _
                ByVal lIndex As Long, _
                ByVal lValue As Long) As Long
   
    Select Case lIndex
    Case 0:    tObj.lVal1 = lValue
    Case 1:    tObj.lVal2 = lValue
    Case Else:  CSumDiff_SetVal = E_INVALIDARG
    End Select
   
End Function

Private Function CSumDiff_GetVal( _
                ByRef tObj As CSumDiff, _
                ByVal lIndex As Long) As Long
   
    Select Case lIndex
    Case 0:    CSumDiff_GetVal = tObj.lVal1
    Case 1:    CSumDiff_GetVal = tObj.lVal2
    Case Else:  Err.Raise 5
    End Select
   
End Function

' // Calculate sum
Private Function CSumDiff_Sum( _
                ByRef tObj As CSumDiff) As Long
   
    CSumDiff_Sum = tObj.lVal1 + tObj.lVal2
   
End Function

' // Calculate difference
Private Function CSumDiff_Diff( _
                ByRef tObj As CSumDiff) As Long
   
    CSumDiff_Diff = tObj.lVal1 - tObj.lVal2
   
End Function

' // CSumDiff interface data
Private Function CSumDiff_InterfaceData() As INTERFACEDATA
    Static tData        As INTERFACEDATA
    Static tMembers()  As METHODDATA
    Static tParams0()  As PARAMDATA
    Static tParams1()  As PARAMDATA
    Static tParams2()  As PARAMDATA
   
    If tData.pmethdata = 0 Then
       
        ReDim tMembers(METH_ISUMDIFF_COUNT - 1)

        tData.cMembers = METH_ISUMDIFF_COUNT
        tData.pmethdata = VarPtr(tMembers(0))
       
        ' // [DEFAULT] HRESULT CSumDiff.Value (Byval Index As Long, Byval Value as Long)
        tParams0 = SetParamData("Index", vbLong, "Value", vbLong)
        tMembers(METH_ISUMDIFF_SETVAL) = SetMethodData("Value", 0, 3, vbError, DISPATCH_PROPERTYPUT, tParams0())
       
        ' // [DEFAULT] Long CSumDiff.Value (Byval Index As Long)
        tParams1 = SetParamData("Index", vbLong)
        tMembers(METH_ISUMDIFF_GETVAL) = SetMethodData("Value", 0, 4, vbLong, DISPATCH_PROPERTYGET Or DISPATCH_METHOD, tParams1())
   
        ' // Long CSumDiff.Sum ()
        tMembers(METH_ISUMDIFF_SUM) = SetMethodData("Sum", 3, 5, vbLong, DISPATCH_METHOD, tParams2())
       
        ' // Long CSumDiff.Diff ()
        tMembers(METH_ISUMDIFF_DIFF) = SetMethodData("Diff", 4, 6, vbLong, DISPATCH_METHOD, tParams2())
       
    End If
   
    CSumDiff_InterfaceData = tData
   
End Function

' // Fast creation
Private Function SetParamData( _
                ParamArray vData() As Variant) As PARAMDATA()
    Dim vIndex  As Variant
    Dim lIndex  As Long
    Dim tRet()  As PARAMDATA
   
    ReDim tRet(UBound(vData) \ 2)
   
    For Each vIndex In vData
       
        If VarType(vIndex) = vbString Then
            tRet(lIndex).pszName = vIndex
        Else
            tRet(lIndex).vt = vIndex
            lIndex = lIndex + 1
        End If
       
    Next
   
    SetParamData = tRet
   
End Function

' // Fast creation
Private Function SetMethodData( _
                ByRef sName As String, _
                ByVal lDispID As Long, _
                ByVal lMethIndex As Long, _
                ByVal lRetValType As Long, _
                ByVal lFlags As Long, _
                ByRef tParams() As PARAMDATA) As METHODDATA
   
    With SetMethodData
       
        .cc = CC_STDCALL
        .dispid = lDispID
        .iMeth = lMethIndex
        .pszName = sName
        .vtReturn = lRetValType
        .wFlags = lFlags
       
        If Not Not tParams Then
           
            .ppdata = VarPtr(tParams(0))
            .cArgs = UBound(tParams) + 1
           
        End If
       
    End With
   
End Function

---

Well Trick, that's certainly interesting as well. You certainly created a class and instantiated it without having any CLS module in sight. I'm wondering how the GUIDs are handled if I wanted to use it to create several classes, but I need to study your code.

I'm running out of time today, being Thanksgiving and all. I do believe it has possibilities, and it's a bit more "pure" than using the MSScriptControl library.

Thanks for outlining that, and I'll be taking a closer look soon.

Take Care,
Elroy

@Elroy - for the record, my lightweight COM object example _does_ use a typelib. It just uses one that's already included in new projects. That's why I suggested IDispatch / latebound.

@Trick - that was a lot easier than I envisioned. well done.
Also that needs to be in the codebank!

Say Trick,

Why do you have the note in there about "You should destroy the object before ending"?

I tested, and it seems to call the CBaseClass_Release without explicitly un-instantiating (i.e., set to Nothing). I'm just wondering why you have that note.

Thanks,
Elroy

Because both compiled process tear-down and IDE tear-down are non-deterministic. If you have a global As Object reference and a global UDT, how do you specify which one gets cleared first?

For CreateStdDispatch created IDispatch you need the typelib data being available at any time methods on pDisp get called for whatever reason (incl. releasing with Set pDisp = Nothing). This means the static structs holding the ad hoc typelib (tData, tMembers(), tParams0(), etc.) have to outlive pDisp otherwise the moment it's set to nothing it's impl will AV.

Typelib data being available past CreateDispTypeInfo call is actually not documented. I'm curious if manipulating tMembers past CreateDispTypeInfo can change the IDispatch methods being implemented. That would be pretty cool, think of JSON parser that exposes object members as regular properties on a such dynamic IDispatch.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

That would be pretty cool, think of JSON parser that exposes object members as regular properties on a such dynamic IDispatch.

---

Advanced stuff like that is all covered in my vbFriendly-COM-Interfaces-approach, which is explained in detail here:
http://www.vbforums.com/showthread.p...BaseInterfaces
(it is based on a "manually" implemented IDispatch, which was enhanced with hook-like delegation, so that all the
difficult interfaces are reachable from normal VB6-code - "kinda like with normal SubClassing".

For the topic of "dynamic Property-Creation and usage at runtime" in particular, a dedicated Project exists in the TutorialApps-Folder:
\7 - Dynamic usage of vbIDispatch

HTH

Olaf

Elroy, for example, if you add that object to Watch window it'll destroy after code is uninitialized.

Ok, got it. :) Thanks to all.

I'm still studying this, seeing how feasible it'll be to make some general purpose procedures out of them. And teaching myself about IUnknown, IDispatch, and general COM stuff as I go.

My goal is still pretty much as stated, create a class (not necessarily at runtime, but definitely without using a CLS module), and then have that class for instantiation at runtime. At least for now, I'll stick with variable properties with no code behind them (such as what we'd have for UDT conversion to a class).

After I get it generalized, I'll then study how difficult nesting will be. With late-binding and just having an Object variable as one of the properties, I don't really see nesting as a problem at all.

Again, I guess it'll always have the caveat of explicit reversed teardown.

Thanks,
Elroy

Ok, the SIZEOF_CSUMDIFF constant is a bit of a stumbling block to generalize this thing. Trick, you created that constant because you didn't always have a variable declared with the CSumDiff UDT, correct? And, if I wanted, I could use a temporary variable, dimensioned with CSumDiff and then use LenB(), correct?

Quote:

---

Trick, you created that constant because you didn't always have a variable declared with the CSumDiff UDT, correct?

---

Yes. I allocated the memory for the object and manipulated the one using the array but during object's being created i don't have an element to write Len(tObj(0)).

Okay, another question, if you don't mind. You've got your tIUnknownVTable UDT, and you're using it twice.

First, you're using it in CBaseClass_CBaseClass for the Static tVtable.

Second, you're using it in the CSumDiff UDT.

Now, when CreateSumDiffObject is called, it calls CSumDiff_CSumDiff with tObj(0) (which is CSumDiff). And then CSumDiff_CSumDiff calls CBaseClass_CBaseClass with tObj.CBase (which is tIUnknownVTable).

So, to summarize, CBaseClass_CBaseClass creates your IUnknown VTable, and also sets your lRefCounter to zero. And then CSumDiff_CSumDiff creates your CSumDiff VTable which has another instance of the IUnknown VTable in it.

Also, when you're done with CSumDiff_CSumDiff, you set the tObj.CBase.pVtbl = VarPtr(tVtable), changing it from what CBaseClass_CBaseClass set it to.

So, I'm thinking that, other than setting the lRefCounter to zero, we don't need the call to CBaseClass_CBaseClass. After CSumDiff_CSumDiff changes tObj.CBase.pVtbl to point at the new VTable, the old tIUnknownVTable is orphaned.

Is my thinking somehow wrong?

Thanks,
Elroy

You should try implementing both methods - CreateStdDispatch and manually creating IDispatch. If you do it manually, you really don't even need type info. Handling GetIDsOfNames() and Invoke() is enough to make the latebound calls work.
That way you don't have the overhead of having CreateStdDispatch create a second wrapper object, dependent on typelib data.
It is possible CreateStdDispatch might be faster if it generates call stubs based on the typeinfo but I doubt it.

A benchmark on the overhead of each method would be a good idea :)

Elroy, it shows the implementation inheritance. For example, you can create an other class inherited from the CBaseClass class. When you create a child class you should call the constructor of the base class and then the child class constructor - it's just the rule like in the C++ classes. The same behavior you'll see if you create the such hierarchy in C++:

Code:

---

class CBase {
public:
        virtual int Test() {return 7;};
        volatile int mx, my;        // 'volatile' to avoid optimizations
        CBase(int x, int y) {mx = x; my = y;}
};

class CChild : CBase {
public:
        int Test() {return 8;};        // Override
        volatile int mz;
        CChild(int x, int y, int z) : CBase(x, y) {mz = z;}
};

void __cdecl _tmain(int argc, TCHAR *argv[])
{
        CChild cTest(1, 2, 3);
        return;
}

---

That code'll compiled to:

Code:

---

CChild::Test PROC
        push        8
        pop        eax
        ret        0
CChild::Test ENDP

CBase::CBase PROC
; _this$ = eax
        mov        DWORD PTR [eax], OFFSET CBase_vTable
        mov        DWORD PTR [eax+4], 1
        mov        DWORD PTR [eax+8], 2
        ret        0
CBase::CBase ENDP                                       

CBase::Test PROC
; _this$ = ecx
        push        7
        pop        eax
        ret        0
CBase::Test ENDP                               

CChild::CChild PROC
; _this$ = esi
        mov        eax, esi
        call        CBase::CBase                       
        mov        DWORD PTR [esi], OFFSET CChild_vTable
        mov        DWORD PTR [esi+12], 3
        mov        eax, esi
        ret        0
CChild::CChild ENDP

_wmain        PROC                                               
        push        ebp
        mov        ebp, esp
        sub        esp, 16                                       
        push        esi
        lea        esi, DWORD PTR _cTest$[ebp]
        call        CChild::CChild
        xor        eax, eax
        pop        esi
        leave
        ret        0
_wmain        ENDP

---

You can see the CChild::CChild proc calls the CBase::CBase which place the CBase_vTable to the vTable member and then CChild::CChild replaces it (overrides) to the CChild_vTable.
It doesn't matter in the current implementation but you can expand the base class (for example add the other data) and you'll need to call it anyway. For example if you'll create a class (let it be CMul) based on the CSumDiff you need to call the constructor of the CSumDiff which'll call the constructor of CBaseClass like in C++.

@Trick: Thank You!

For my own edification, I went ahead and eliminated it.

I've been madly refactoring your code so I can better understand it. I apologize for bending it around to code I'm more used to looking at. I just had to do that to keep my sanity. I know we all have our own coding styles and conventions. :)


I think I'm done refactoring. I'll be staring at it to see about generalizing it next. But here's what I've currently got (for a BAS module):

Code:

---


Option Explicit
'
Private Const E_INVALIDARG          As Long = &H80070057
Private Const E_NOINTERFACE          As Long = &H80004002
'
Private Const CC_STDCALL            As Long = 4&
Private Const VT_BYREF              As Long = &H4000&
'
Private Const DISPATCH_METHOD        As Long = 1&
Private Const DISPATCH_PROPERTYGET  As Long = 2&
Private Const DISPATCH_PROPERTYPUT  As Long = 4&
'
Private Const LOCALE_SYSTEM_DEFAULT  As Long = &H800&
Private Const HEAP_ZERO_MEMORY      As Long = &H8&
Private Const FADF_AUTO              As Long = 1&
'
Private Type tSafeArray1D
    cDims      As Integer
    fFeatures  As Integer
    cbElements As Long
    cLocks    As Long    ' Not used for class creation.
    pvData    As Long
    cElements  As Long
    lLBound    As Long    ' Left at 0 for class creation.
End Type
'
Private Type tUUID
    Data1      As Long
    Data2      As Integer
    Data3      As Integer
    Data4(7)  As Byte
End Type
'
Private Type tParamData
    pszName    As String
    vt        As Integer
End Type
Private Type tMethodData
    pszName    As String
    ppdata    As Long
    dispid    As Long
    iMeth      As Long
    cc        As Long
    cArgs      As Long
    wFlags    As Integer
    vtReturn  As Integer
End Type
Private Type tInterfaceData
    pMethData  As Long
    cMembers  As Long
End Type
'
Private Type tIUnknownVTable
    pQueryInterface                As Long
    pAddRef                        As Long
    pRelease                      As Long
End Type
Private Type tBaseClass
    pVTable                        As Long
    lRefCounter                    As Long
    pDisp                          As Long    ' Inner object.
End Type
'
Private Declare Function CreateDispTypeInfo Lib "OleAut32" (ByRef pidata As tInterfaceData, ByVal lcid As Long, ByRef pptinfo As IUnknown) As Long
Private Declare Function CreateStdDispatch Lib "OleAut32" (ByRef punkOuter As Any, ByRef pvThis As Any, ByVal ptinfo As IUnknown, ByRef ppunkStdDisp As Any) As Long
'
Private Declare Function IsEqualGUID Lib "ole32" (ByRef rguid1 As tUUID, ByRef rguid2 As tUUID) As Long
Private Declare Sub IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As tUUID)
'
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
Private Declare Function vbaObjSet Lib "msvbvm60" Alias "__vbaObjSet" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
Private Declare Function vbaCastObj Lib "msvbvm60" Alias "__vbaCastObj" (ByRef dstObject As Any, ByRef pIID As tUUID) As Long
Private Declare Sub MoveArray Lib "msvbvm60" Alias "__vbaAryMove" (ByRef Destination() As Any, ByRef Source As Any)
'
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
'
' Stuff specific to our class.
'
Private Enum eITheClassMethods
    Method_ITheClass_Setval
    Method_ITheClass_Getval
    Method_ITheClass_Sum
    Method_ITheClass_Diff
    Method_ITheClass_Count        ' To be a count, this must be last.
End Enum
#If False Then
    Dim Method_ITheClass_Setval, Method_ITheClass_Getval, Method_ITheClass_Sum, Method_ITheClass_Diff, Method_ITheClass_Count
#End If
Private Type tTheClassVTable
    uIUnknownVTable                    As tIUnknownVTable
    pFn(Method_ITheClass_Count - 1&)  As Long
End Type
Private Type tTheClass
    uBase                              As tBaseClass
    ' Properties listed below.
    lVal1                              As Long
    lVal2                              As Long
End Type
Private Const SIZEOF_tTheClass        As Long = &H14
'

Public Function CreateTheObject() As IUnknown
    ' IDispatch implementation of light-weight COM object.
    ' Original code and concepts by The Trick 2018.
    ' Substantial refactoring and reworking by Elroy.
    '
    ' CAVEAT:  Using this means we MUST take responsibility for destroying our own object, and in the correct order.
    '
    Dim lRet              As Long
    '
    ' Class creation variables.
    Static uInterfaceData  As tInterfaceData      ' Global data.
    Static uMembers()      As tMethodData
    Static uParamsEmpty()  As tParamData
    Static uParamsPut()    As tParamData
    Static uParamsGet()    As tParamData
    '
    Static oIUnknown      As IUnknown
    Static uVtable          As tTheClassVTable
    '
    ' Object instantiation variables.
    Dim uObj()              As tTheClass            ' We just use the 0th dimension.
    Dim pObj              As Long
    Dim uSafeArray          As tSafeArray1D
    '
    ' Get the interface data, create TypeInfo, and setup VTable.
    ' Basically, this creates the CLASS, from which objects can be instantiated.
    ' This only needs to be done once, and then as many objects can be instantiated as we like.
    If uInterfaceData.pMethData = 0& Then                                          ' On first time through.
        '
        ' Interface data.
        ReDim uMembers(Method_ITheClass_Count - 1&)
        '
        uParamsPut = SetParamData("Index", vbLong, "Value", vbLong)
        uMembers(Method_ITheClass_Setval) = SetMethodData("Value", 0&, 3&, vbError, DISPATCH_PROPERTYPUT, uParamsPut())
        '
        uParamsGet = SetParamData("Index", vbLong)
        uMembers(Method_ITheClass_Getval) = SetMethodData("Value", 0&, 4&, vbLong, DISPATCH_PROPERTYGET Or DISPATCH_METHOD, uParamsGet())
        '
        uMembers(Method_ITheClass_Sum) = SetMethodData("Sum", 3&, 5&, vbLong, DISPATCH_METHOD, uParamsEmpty())
        uMembers(Method_ITheClass_Diff) = SetMethodData("Diff", 4&, 6&, vbLong, DISPATCH_METHOD, uParamsEmpty())
        '
        uInterfaceData.cMembers = Method_ITheClass_Count
        uInterfaceData.pMethData = VarPtr(uMembers(0&))
        '
        ' Create TypeInfo.
        lRet = CreateDispTypeInfo(uInterfaceData, LOCALE_SYSTEM_DEFAULT, oIUnknown) ' Create simplified type information to implement IDispatch.
        If lRet < 0 Then Exit Function                                              ' Check for error.
        '
        ' Set IUnknown VTable.
        uVtable.uIUnknownVTable.pQueryInterface = AddressOfEx(AddressOf BaseClass_QueryInterface)
        uVtable.uIUnknownVTable.pAddRef = AddressOfEx(AddressOf BaseClass_AddRef)
        uVtable.uIUnknownVTable.pRelease = AddressOfEx(AddressOf BaseClass_Release)
        '
        ' Set our specific VTable.
        uVtable.pFn(Method_ITheClass_Setval) = AddressOfEx(AddressOf TheObject_SetVal)
        uVtable.pFn(Method_ITheClass_Getval) = AddressOfEx(AddressOf TheObject_GetVal)
        uVtable.pFn(Method_ITheClass_Sum) = AddressOfEx(AddressOf TheObject_Sum)
        uVtable.pFn(Method_ITheClass_Diff) = AddressOfEx(AddressOf TheObject_Diff)
    End If
    '
    ' Alloc memory for the object and map it to the uObj(0&) array item.
    ' SafeArray is just used as a convenience.
    pObj = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, SIZEOF_tTheClass)
    uSafeArray.cDims = 1 ' Integer                                                  ' Dimensions.
    uSafeArray.cElements = 1&                                                      ' Bytes per element.
    uSafeArray.fFeatures = FADF_AUTO                                                ' Don't free memory after destroying array.
    uSafeArray.pvData = pObj                                                        ' Pointer to array data.
    uSafeArray.cbElements = SIZEOF_tTheClass                                        ' Total size of array data.
    MoveArray uObj(), VarPtr(uSafeArray)                                            ' And now, uObj is our Byte array.  At this point, pObj == VarPtr(uObj(0&).uBase).
    '
    ' Make sure this instantiation is initialized correctly.
    uObj(0&).uBase.lRefCounter = 0&
    uObj(0&).uBase.pVTable = VarPtr(uVtable)
    uObj(0&).lVal1 = 0&
    uObj(0&).lVal2 = 0&
    '
    ' Implement IDispatch, put pointer into function, and increment reference count.
    lRet = CreateStdDispatch(uObj(0&), uObj(0&), oIUnknown, uObj(0&).uBase.pDisp)  ' Create standard implementation of IDispatch interface through a single function call.
    If lRet < 0& Then                                                              ' Check for error.
        HeapFree GetProcessHeap(), 0&, pObj
        Exit Function
    End If
    vbaObjSetAddref CreateTheObject, ByVal pObj                                    ' Put object pointer into function name and increment reference to 1.
    '
    ' Cleanup.
    Erase uObj                                                                      ' The data remains because of FADF_AUTO.  But the SafeArray header is destroyed.
End Function

Private Function TheObject_SetVal(ByRef uTheObject As tTheClass, ByVal lIndex As Long, ByVal lValue As Long) As Long
    Select Case lIndex
    Case 0&:        uTheObject.lVal1 = lValue
    Case 1&:        uTheObject.lVal2 = lValue
    Case Else:      TheObject_SetVal = E_INVALIDARG
    End Select
End Function

Private Function TheObject_GetVal(ByRef uTheObject As tTheClass, ByVal lIndex As Long) As Long
    Select Case lIndex
    Case 0&:        TheObject_GetVal = uTheObject.lVal1
    Case 1&:        TheObject_GetVal = uTheObject.lVal2
    Case Else:      Err.Raise 5&
    End Select
End Function

Private Function TheObject_Sum(ByRef uTheObject As tTheClass) As Long
    TheObject_Sum = uTheObject.lVal1 + uTheObject.lVal2
End Function

Private Function TheObject_Diff(ByRef uTheObject As tTheClass) As Long
    TheObject_Diff = uTheObject.lVal1 - uTheObject.lVal2
End Function





Private Function SetParamData(ParamArray vData() As Variant) As tParamData()
    Dim vIndex As Variant
    Dim lIndex As Long
    Dim uRet()  As tParamData
    '
    ReDim uRet(UBound(vData) \ 2&)
    For Each vIndex In vData
        If VarType(vIndex) = vbString Then
            uRet(lIndex).pszName = vIndex
        Else
            uRet(lIndex).vt = vIndex
            lIndex = lIndex + 1&
        End If
    Next
    SetParamData = uRet
End Function

Private Function SetMethodData(ByRef sName As String, ByVal lDispID As Long, ByVal lMethIndex As Long, ByVal lRetValType As Long, ByVal lFlags As Long, ByRef tParams() As tParamData) As tMethodData
    SetMethodData.cc = CC_STDCALL
    SetMethodData.dispid = lDispID
    SetMethodData.iMeth = lMethIndex
    SetMethodData.pszName = sName
    SetMethodData.vtReturn = lRetValType
    SetMethodData.wFlags = lFlags
    If Not Not tParams Then            ' Make sure we've got a SafeArray header.
        SetMethodData.ppdata = VarPtr(tParams(0&))
        SetMethodData.cArgs = UBound(tParams) + 1&
    End If
End Function





Private Function BaseClass_QueryInterface(ByRef uBaseClass As tBaseClass, ByRef tiid As tUUID, ByRef pOut As Long) As Long
    Static uIUnk    As tUUID
    Static uIDisp  As tUUID
    '
    If uIUnk.Data1 = 0& Then
        IIDFromString StrPtr("{00000000-0000-0000-C000-000000000046}"), uIUnk
        IIDFromString StrPtr("{00020400-0000-0000-C000-000000000046}"), uIDisp
    End If
    '
    Select Case True
    Case IsEqualGUID(tiid, uIUnk)
        pOut = VarPtr(uBaseClass)
        BaseClass_AddRef uBaseClass
    Case IsEqualGUID(tiid, uIDisp)
        pOut = vbaCastObj(ByVal uBaseClass.pDisp, uIDisp)
    Case Else
        pOut = 0&
        BaseClass_QueryInterface = E_NOINTERFACE
    End Select
End Function

Private Function BaseClass_AddRef(ByRef uBaseClass As tBaseClass) As Long
    uBaseClass.lRefCounter = uBaseClass.lRefCounter + 1&
    BaseClass_AddRef = uBaseClass.lRefCounter
End Function

Private Function BaseClass_Release(ByRef uBaseClass As tBaseClass) As Long
    uBaseClass.lRefCounter = uBaseClass.lRefCounter - 1&
    BaseClass_Release = uBaseClass.lRefCounter
    If uBaseClass.lRefCounter = 0& Then
        vbaObjSet uBaseClass.pDisp, ByVal 0&
        HeapFree GetProcessHeap(), 0&, VarPtr(uBaseClass)
    End If
End Function



---

And I'm still basically using your test code in Form1:

Code:

---

Option Explicit

Private Sub Form_Click()
    Dim Obj    As Object
   
    Set Obj = CreateTheObject()
   
    Obj(0) = 54
    Obj(1) = 20
   
    Debug.Print Obj.Sum
    Debug.Print Obj.Diff
   
    Obj.Value(0) = 1231
    Obj.Value(1) = 2000
   
    Debug.Print Obj(0)
    Debug.Print Obj.Value(1)
   
    Debug.Print Obj.Diff
   
    Set Obj = Nothing

End Sub


---

Frighteningly, I think I'm beginning to get some basic understandings of this stuff. At least I've managed to not break your code while refactoring. I love not having to worry about the code-order of any of the procedures.

For generalization, I'm thinking of some kind of strided ParamArray. But I haven't worked out all the details just yet.

I'll Be Back,
Elroy

Ahhh, I almost forgot. I pulled a couple of functions out into a more general BAS module. Here those are:

Code:

---


Option Explicit
'
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef src As Any, ByRef dst As Any) As Long
'

Public Function AddressOfEx(ByVal lProcAddress As Long) As Long
    ' AddressOf statement actually returns the pointer to the small thunk which checks if code is running or not.
    ' When you see an object variable in the Watch window the code is stopped. We need to avoid that behavior
    ' because some interfaces return the HRESULT value and it'll cause unexpected behavior (return S_OK).
    '
    Dim bIsInIDE  As Boolean
    Debug.Assert MakeTrue(bIsInIDE)
    If bIsInIDE Then
        GetMem4 ByVal lProcAddress + &H16, AddressOfEx  ' Skip thunk.
    Else
        AddressOfEx = lProcAddress
    End If
End Function

Public Function MakeTrue(ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function


---

Ok, another question. The DispID value that's in METHODDATA, those are just arbitrarily assigned so that IDispatch knows what to do? And, you seem to use the same DispID for the "Get" and "Put" of the same property. And also, a 0 DispID seems to be what's used as the "default" property.

I looked a bit for some documentation, but I didn't find anything definitive, so I thought I'd just ask.

-------------------------
And just some general thoughts about this:


I'm just playing around with it, modifying the class to have multiple non-array properties. That seems to work great.

I can see my way through to generalizing it, but I'm not totally sure what I'll have when I do. The fact that we must be so careful about teardown makes it seem more complex than just creating more CLS modules. If I don't teardown before hitting the IDE's "stop" button, it sometimes crashes the IDE, much like subclassing does.

It's been interesting to learn about this stuff, especially the way IDispatch allows us to create our procedure/method names, and then attach them to actual procedures (not necessarily with the same name).

But I'm just not sure of the true utility for VB6 projects. I suppose separate modules for VB6 classes is just a fact-of-life.

Best Regards,
Elroy

Quote:

---

Ok, another question. The DispID value that's in METHODDATA, those are just arbitrarily assigned so that IDispatch knows what to do?

---

Yes, excepting the some values.

Quote:

---

The fact that we must be so careful about teardown makes it seem more complex than just creating more CLS modules.

---

You just need to create the some precompiled-thunks for the IUnknown implementation which check if the code is running and delegate the call to the code if need. There is other thing. You can't just replace an UDT with an Object because that's the different entities. For example, when you assign a object variable to other one it just calls AddRef (or QI if different interface); when you do the same with an UDT it copies all the members of the UDT to another one.

I think one can augment project's private UDTs by inserting a lpVTable As Long as first member so that such UDTs can be conveniently shape-shifted into light-weight classes w/o changing data layout.

The question is besides additional dwRefCount and probably pDisp what is the minimum additional data a UDT needs to mutate into a usable lightweight-class? Theoretically only a single Long for the lpVTable but w/o ref-counting and IDispatch impl such class will not be very usable IMO.

Good discussion about the genesis of COM here, with some franken-UDTs and all :-))

cheers,
</wqw>

wqweto, i'd just use a type lib with early bounding as the first step. Why do you need to use the slow and big late-bounding?
Other aspects are depending on the situation. For example you can use no reference counter if you don't need to control the lifetime of the object.

Deleted ...

Quote:

---

Originally Posted by Elroy

@Tric

Code:

---

Option Explicit

Private Sub Form_Click()
    Dim Obj    As Object
   
    Set Obj = CreateTheObject()
   
    Obj(0) = 54
    Obj(1) = 20
   
    Debug.Print Obj.Sum
    Debug.Print Obj.Diff
   
    Obj.Value(0) = 1231
    Obj.Value(1) = 2000
   
    Debug.Print Obj(0)
    Debug.Print Obj.Value(1)
   
    Debug.Print Obj.Diff
   
    Set Obj = Nothing

End Sub


---

Frighteningly, I think I'm beginning to get some basic understandings of this stuff. At least I've managed to not break your code while refactoring. I love not having to worry about the code-order of any of the procedures.

For generalization, I'm thinking of some kind of strided ParamArray. But I haven't worked out all the details just yet.

I'll Be Back,
Elroy

---

can't run it,why?

[已更新]DyCOMHelper--让您在VB6下实现真正意义的继承。-CSDN社区
https://bbs.csdn.net/topics/350177926