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
Last edited by Elroy; Nov 21st, 2018 at 10:43 AM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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.
Last edited by Elroy; Nov 21st, 2018 at 11:58 AM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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.
Last edited by DllHell; Nov 21st, 2018 at 12:13 PM.
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
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...
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.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Last edited by Schmidt; Nov 21st, 2018 at 08:21 PM.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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.
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.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
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.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
@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!
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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.
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
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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?
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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++.
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
Last edited by Elroy; Nov 30th, 2018 at 11:19 AM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
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.
Last edited by The trick; Dec 1st, 2018 at 03:15 AM.
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 :-))
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.
Reply With Quote
Originally Posted by DllHell
