Implements (light weight object)
Hi all,
FYI, I am the smae member as JAAFAR. I forgot the forum password but couldn't recover it because I also lost the email account I first registered with .So i had to register under this new name.
Anyways, I am just trying to adapt the code from here. I was unable to post in the original thread.
Basically I have this class module named IMyInterface:
Code:
Option Explicit
Public Function AddTwoLongs(ByVal x As Long, ByVal y As Long) As Long
'
End Function
Then, I have this code in a bas module to create the light weight object based on the above class module (IMyInterface):
Code:
Option Explicit
Private Type tMyCOMcompatibleVTable
'Space for the 3 Function-Pointers of the IUnknown-Interface
QueryInterface As Long
AddRef As Long
Release As Long
'followed by Space for the single Function-Pointer of our concrete Method
AddTwoLongs As Long
End Type
Private Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As Long
RefCount As Long
End Type
Private mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare Function CoTaskMemAlloc Lib "ole32" (ByVal sz As Long) As Long
Declare Sub CoTaskMemFree Lib "ole32" (ByVal pMem As Long)
Declare Sub Assign Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal CB& = 4)
Public Function VTablePtr() As Long 'the only Public Function here (later called from modMyClassFactory)
If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function
Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
mVTable.QueryInterface = VBA.CLngLng(AddressOf QueryInterface)
mVTable.AddRef = VBA.CLngLng(AddressOf AddRef)
mVTable.Release = VBA.CLngLng(AddressOf Release)
mVTable.AddTwoLongs = VBA.CLngLng(AddressOf AddTwoLongs)
End Sub
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function CreateInstance() As Class1 '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
MyObj.pVTable = VTablePtr 'whilst filling its members (as e.g. pVTable here)
MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"
Dim pMem As Long
pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
Assign ByVal pMem, MyObj, LenB(MyObj)
Assign CreateInstance, pMem 'copy-over the Data from our local MyObj-UDT-Variable
End Function
'IUnknown-Implementation
Public Function QueryInterface(This As tMyObject, ByVal pReqIID As Long, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004002 'E_NOINTERFACE, just for safety reasons ... but there will be no casts in our little Demo
End Function
Public Function AddRef(This As tMyObject) As Long
MsgBox "addref"
' This.RefCount = This.RefCount + 1
' AddRef = This.RefCount
End Function
Public Function Release(This As tMyObject) As Long
' This.RefCount = This.RefCount - 1
' Release = This.RefCount
' If This.RefCount = 0 Then CoTaskMemFree VarPtr(This) '<- here's the dynamic part again, when a Class-instance dies
'
MsgBox "releaseref"
End Function
'IMyClass-implementation (IMyClass only contains this single method)
Public Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
' MsgBox Result
End Function
Now. When I run the following Test Sub , it successfully creates a new instance of IMyInterface but crashes at the call of AddTwoLongs Method:
Code:
Sub Test()
Dim x As IMyInterface
Set x = CreateInstance
MsgBox x.AddTwoLongs(2, 8)
End Sub
Can anybody please see if the logic of I am doing is wrong and if not why does the code crashes when it reaches the AddTwoLongs Method call ?
Regards.
Re: Implements (light weight object)
Got it to work in the following *.bas module ...
(in a VB6-Project which starts from Sub Main, only the properly named IMyInterface-Class is needed in addition).
Code:
Option Explicit
Private Type tMyCOMcompatibleVTable
'Space for the 3 Function-Pointers of the IUnknown-Interface
QueryInterface As Long
AddRef As Long
Release As Long
IDispatchDummy(1 To 4) As Long
'followed by Space for the single Function-Pointer of our concrete Method
AddTwoLongs As Long
End Type
Private Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As Long
RefCount As Long
End Type
Private mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable
Declare Function CoTaskMemAlloc Lib "ole32" (ByVal sz As Long) As Long
Declare Sub CoTaskMemFree Lib "ole32" (ByVal pMem As Long)
Declare Sub Assign Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal CB& = 4)
Sub Main() 'test it
Dim x As IMyInterface
Set x = getInstanceOf_IMyInterface
MsgBox x.AddTwoLongs(2, 8)
End Sub
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function getInstanceOf_IMyInterface() As IMyInterface '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
MyObj.pVTable = VTablePtr 'whilst filling its members (as e.g. pVTable here)
MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"
Dim pMem As Long
pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
Assign ByVal pMem, MyObj, LenB(MyObj)
Assign getInstanceOf_IMyInterface, pMem 'copy-over the Data from our local MyObj-UDT-Variable
End Function
Private Function VTablePtr() As Long 'the only Public Function here (later called from modMyClassFactory)
If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function
Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
mVTable.QueryInterface = VBA.CLng(AddressOf QueryInterface)
mVTable.AddRef = VBA.CLng(AddressOf AddRef)
mVTable.Release = VBA.CLng(AddressOf Release)
mVTable.AddTwoLongs = VBA.CLng(AddressOf AddTwoLongs)
End Sub
'IUnknown-Implementation
Private Function QueryInterface(This As tMyObject, ByVal pReqIID As Long, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004002 'E_NOINTERFACE, just for safety reasons ... but there will be no casts in our little Demo
End Function
Private Function AddRef(This As tMyObject) As Long
MsgBox "addref"
End Function
Private Function Release(This As tMyObject) As Long
MsgBox "releaseref"
End Function
'IMyClass-implementation (IMyClass only contains this single method)
Private Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
End Function
Have marked the two main-changes in red above...
HTH
Olaf
Re: Implements (light weight object)
Just for completeness, the two AddRef and Release-routines above -
should better implement proper RefCounting, to not cause Memory leaks:
Code:
Private Function AddRef(This As tMyObject) As Long
This.RefCount = This.RefCount + 1
MsgBox "AddRef reached: " & This.RefCount
AddRef = This.RefCount
End Function
Private Function Release(This As tMyObject) As Long
This.RefCount = This.RefCount - 1
MsgBox "Release reached: " & This.RefCount
If This.RefCount = 0 Then CoTaskMemFree VarPtr(This)
Release = This.RefCount
End Function
With these two changes, the module could already serve as a template
(for other interface-implementations).
Olaf
Re: Implements (light weight object)
Thanks Olaf for responding.
It still crashes at the call of AddTwoLongs !
Can it be that it crashes because I am running thie code in VBA x64 bit ?
I have made sure all pointers are LongLong including the added 4*4 extra bytes for the IDispatch Interface Methods as suggested.
Following is the actual entire code that I am using (changes to your code are in red in order to work on x64bit)
1- Class Module named (IMyInterface)
Code:
Option Explicit
Public Function AddTwoLongs(ByVal x As Long, ByVal y As Long) As Long
'
End Function
2- Bas Module x64bit
Code:
Option Explicit
Private Type tMyCOMcompatibleVTable
'Space for the 3 Function-Pointers of the IUnknown-Interface
QueryInterface As LongLong
AddRef As LongLong
Release As LongLong
IDispatchDummy(1 To 4) As LongLong
'followed by Space for the single Function-Pointer of our concrete Method
AddTwoLongs As LongLong
End Type
Private Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As LongLong
RefCount As Long
End Type
Private mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable
Declare PtrSafe Function CoTaskMemAlloc Lib "ole32" (ByVal sz As Long) As LongLong
Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pMem As LongLong)
Declare PtrSafe Sub Assign Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal CB = 8)
Sub Main() 'test it
Dim x As IMyInterface
Set x = getInstanceOf_IMyInterface
MsgBox x.AddTwoLongs(2, 8)
End Sub
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function getInstanceOf_IMyInterface() As IMyInterface '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
MyObj.pVTable = VTablePtr 'whilst filling its members (as e.g. pVTable here)
MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"
Dim pMem As LongLong
pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
Assign ByVal pMem, MyObj, LenB(MyObj)
Assign getInstanceOf_IMyInterface, pMem 'copy-over the Data from our local MyObj-UDT-Variable
End Function
Private Function VTablePtr() As LongLong 'the only Public Function here (later called from modMyClassFactory)
If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function
Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
mVTable.QueryInterface = VBA.CLngLng(AddressOf QueryInterface)
mVTable.AddRef = VBA.CLngLng(AddressOf AddRef)
mVTable.Release = VBA.CLngLng(AddressOf Release)
mVTable.AddTwoLongs = VBA.CLngLng(AddressOf AddTwoLongs)
End Sub
'IUnknown-Implementation
Private Function QueryInterface(This As tMyObject, ByVal pReqIID As LongLong, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004002 'E_NOINTERFACE, just for safety reasons ... but there will be no casts in our little Demo
End Function
Private Function AddRef(This As tMyObject) As Long
This.RefCount = This.RefCount + 1
MsgBox "AddRef reached: " & This.RefCount
AddRef = This.RefCount
End Function
Private Function Release(This As tMyObject) As Long
This.RefCount = This.RefCount - 1
MsgBox "Release reached: " & This.RefCount
If This.RefCount = 0 Then CoTaskMemFree VarPtr(This)
Release = This.RefCount
End Function
'IMyClass-implementation (IMyClass only contains this single method)
Private Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
End Function
Re: Implements (light weight object)
You've forgot the TypeSpecifier for CB in your Assign-Declaration above:
(it's currently Variant - and should be Long)
Code:
Declare PtrSafe Sub Assign Lib "kernel32" Alias "RtlMoveMemory" _
(Dst As Any, Src As Any, Optional ByVal CB As LongLong = 8)
Maybe that fixes it already...
If not, then you might want to make an attempt to return E_POINTER in QueryInterface -
(has shown better Debug-Step-behaviour via <F8> in the VB6-IDE).
Edit: changed it to LongLong, because in most C/C++-Compilers, a SIZE_T (as it is defined in the MSDN) -
follows the "bitness of the target" - so in C/C++ the define is in all likelihood an int64, which has its match in LongLong.
Code:
Private Function QueryInterface(This As tMyObject, ByVal pReqIID As LongLong, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004003 'E_POINTER, for safety reasons in Debug-Mode
End Function
Otherwise - with regards to 64Bit-compatibility - the thing looks good to me -
(I only have a 32Bit Office-version for testing here, so have to guess...)
HTH
Olaf
Re: Implements (light weight object)
In Office VBA there is a DataType called "LongPtr", which in 32-Bit is 4 Bytes, in 64-Bit is 8 Bytes
Remember: The Bitness of the Office-Product is what's important here, not the Bitness of Windows
https://docs.microsoft.com/en-us/off...gptr-data-type
2 Attachment(s)
Re: Implements (light weight object)
Quote:
You've forgot the TypeSpecifier for CB in your Assign-Declaration above:
(it's currently Variant - and should be Long)
True. I missed that one ... I've now changed it.
Quote:
Edit: changed it to LongLong, because in most C/C++-Compilers, a SIZE_T (as it is defined in the MSDN) -
follows the "bitness of the target" - so in C/C++ the define is in all likelihood an int64, which has its match in LongLong
That was actually changed from the start in the code in post#4.... And I am now returning E_POINTER in QueryInterface as suggested.
Still no joy . In fact when I check the type of the X object I get the following errors despite a call to ObjPtr(x) returning what seems to be a valid pointer and despite the IUnknwon AddRef and Release funcs being executed when the code reaches: 'Msgbox ObjPtr(x)' :
With TypeName function
Attachment 185065
With TypeOf operator
Attachment 185064
Re: Implements (light weight object)
Quote:
Originally Posted by
AngelV
Of course...
You shouldn't do that with a lightweight Object -
(because these Methods require properly implemented "Extra-Interfaces" -
you delegate to in QueryInterface, and also a basic IIDispatch-implementation IIRC).
The trick has this sitting in a demo somewhere -
but easier is, to "just work with the sole interface" of this lightweight Object
(and because it will always remain of type IMyInterface, there will never be a need to "ask for its type",
or to cast it to some other type).
HTH
Olaf
Re: Implements (light weight object)
Code:
Option Explicit
Private Type tMyCOMcompatibleVTable
'Space for the 3 Function-Pointers of the IUnknown-Interface
QueryInterface As LongLong
AddRef As LongLong
Release As LongLong
IDispatchDummy(1 To 4) As LongLong
'followed by Space for the single Function-Pointer of our concrete Method
AddTwoLongs As LongLong
End Type
Private Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As LongLong
RefCount As Long
End Type
Private mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable
Declare PtrSafe Function CoTaskMemAlloc Lib "ole32" (ByVal sz As Long) As LongLong
Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pMem As LongLong)
Declare PtrSafe Sub Assign Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal CB As LongLong = 8)
Sub Main() 'test it
Dim x As IMyInterface
Set x = getInstanceOf_IMyInterface
MsgBox x.AddTwoLongs(2, 8)
End Sub
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function getInstanceOf_IMyInterface() As IMyInterface '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
MyObj.pVTable = VTablePtr 'whilst filling its members (as e.g. pVTable here)
MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"
Dim pMem As LongLong
pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
Assign ByVal pMem, MyObj, LenB(MyObj)
Assign getInstanceOf_IMyInterface, pMem 'copy-over the Data from our local MyObj-UDT-Variable
End Function
Private Function VTablePtr() As LongLong 'the only Public Function here (later called from modMyClassFactory)
If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function
Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
mVTable.QueryInterface = VBA.CLngLng(AddressOf QueryInterface)
mVTable.AddRef = VBA.CLngLng(AddressOf AddRef)
mVTable.Release = VBA.CLngLng(AddressOf Release)
mVTable.AddTwoLongs = VBA.CLngLng(AddressOf AddTwoLongs)
End Sub
'IUnknown-Implementation
Private Function QueryInterface(This As tMyObject, ByVal pReqIID As LongLong, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004003 'E_POINTER, for safety reasons in Debug-Mode
End Function
Private Function AddRef(This As tMyObject) As Long
This.RefCount = This.RefCount + 1
MsgBox "AddRef reached: " & This.RefCount
AddRef = This.RefCount
End Function
Private Function Release(This As tMyObject) As Long
This.RefCount = This.RefCount - 1
MsgBox "Release reached: " & This.RefCount
If This.RefCount = 0 Then CoTaskMemFree VarPtr(This)
Release = This.RefCount
End Function
'IMyClass-implementation (IMyClass only contains this single method)
Private Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
End Function
Still no luck . The code keeps crashing at the call of the AddTwoLongs Function.
I really don't know what the problem is. The code looks correct to me ... I have tried many things but without any success.
Anyone ?
Re: Implements (light weight object)
Ok . I have managed to make the AddTwoLongs Method of the light weight object work in x64 using two different approaches:
1- Approach one using CallWindowProc. 2 - Approach two using DispCallFunc.
Here is the code in case anyone is interested.
Note: In case anyone wants to quickly test the code below in vb6 (ie:=x32bit), please, just replace all instances of LongLong with Long
In a bas module :
Code:
Option Explicit
Type tMyCOMcompatibleVTable
'Space for the 3 Function-Pointers of the IUnknown-Interface
QueryInterface As LongLong
AddRef As LongLong
Release As LongLong
'followed by Space for the single Function-Pointer of our concrete Method
AddTwoLongs As LongLong
End Type
Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As LongLong
RefCount As Long
End Type
Dim mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable
Declare PtrSafe Function CoTaskMemAlloc Lib "ole32" (ByVal sz As LongLong) As LongLong
Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pMem As LongLong)
Declare PtrSafe Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongLong, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongLong, ByVal hWnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As Long
Sub Main() 'test it
Const IDX_CLASSMETHOD As Long = 3 '<==Skip IUnknown methods
Const PTR_SIZE = 8 'x64bit
Dim oLWObjInstance As IUnknown
Dim lParam1 As Long, lParam2 As Long
Dim lFuncResult As Long
Set oLWObjInstance = getInstanceOf_IMyInterface
If Not oLWObjInstance Is Nothing Then
'CallWindowProc Approach.
Dim lpVtbl As LongLong
lpVtbl = DeRef(ObjPtr(oLWObjInstance))
lParam1 = -10: lParam2 = 8000
Call CallWindowProc(ByVal DeRef(lpVtbl + PTR_SIZE * IDX_CLASSMETHOD), ObjPtr(oLWObjInstance), lParam1, lParam2, VarPtr(lFuncResult))
MsgBox lFuncResult
'DispCallFunc Approach.
lParam1 = 1: lParam2 = 2
Call DispCallByVtbl(ObjPtr(oLWObjInstance), IDX_CLASSMETHOD, lParam1, lParam2, VarPtr(lFuncResult))
MsgBox lFuncResult
End If
End Sub
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function getInstanceOf_IMyInterface() As IUnknown 'IMyInterface '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
MyObj.pVTable = VTablePtr 'whilst filling its members (as e.g. pVTable here)
MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"
Dim pMem As LongLong
pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
CopyMemory ByVal pMem, MyObj, LenB(MyObj)
CopyMemory getInstanceOf_IMyInterface, pMem, LenB(pMem) 'copy-over the Data from our local MyObj-UDT-Variable
End Function
Private Function VTablePtr() As LongLong 'the only Public Function here (later called from modMyClassFactory)
If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function
Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
mVTable.QueryInterface = VBA.CLngLng(AddressOf QueryInterface)
mVTable.AddRef = VBA.CLngLng(AddressOf AddRef)
mVTable.Release = VBA.CLngLng(AddressOf Release)
mVTable.AddTwoLongs = VBA.CLngLng(AddressOf AddTwoLongs)
End Sub
'IUnknown-Implementation
Private Function QueryInterface(This As tMyObject, ByVal pReqIID As LongLong, ppObj As stdole.IUnknown) As Long '<- HResult
QueryInterface = &H80004003 'E_POINTER, for safety reasons in Debug-Mode
End Function
Private Function AddRef(This As tMyObject) As Long
This.RefCount = This.RefCount + 1
Debug.Print "AddRef reached: " & This.RefCount
AddRef = This.RefCount
End Function
Private Function Release(This As tMyObject) As Long
This.RefCount = This.RefCount - 1
Debug.Print "Release reached: " & This.RefCount
If This.RefCount = 0 Then CoTaskMemFree VarPtr(This)
Release = This.RefCount
End Function
'IMyClass-implementation (IMyClass only contains this single method)
Private Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
End Function
Private Function DispCallByVtbl(ByVal pUnk As LongLong, ByVal lIndex As Long, ParamArray Arr() As Variant) As Variant
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As LongLong
Dim hResult As Long
Const CC_STDCALL As Long = &H4&
vParam = Arr
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(pUnk, lIndex * 8, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
Private Property Get DeRef(ByVal Address As LongLong) As LongLong
CopyMemory DeRef, ByVal Address, LenB(Address)
End Property
BTW, unlike before, I didn't need to have a seperate IMyInterface code module... I have just worked on a minimal light object structure ( ie:= just IUnknown + AddTwoLongs Func... No IDispatch)
Despite having made this work, I still can't understand why the code kindly offered by Olaf in post#2 only works in x32.
Is that due to the different memory alignement of obj and vtble structures in x64 ? I even padded the tMyObjec structure with an extra Long but no luck.
Code:
Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
pVTable As LongLong
RefCount As Long
#If Win64 Then
Padding As Long
#End If
End Type
Re: Implements (light weight object)
Your first 64bit version worked as expected with twinBasic but was crashing in Excel. The cause is probably due to some bug in VBA IDE. The kind reported on SO here You should post the issue there.
Re: Implements (light weight object)
FWIW, here's a new approach to all that (just uploaded into the CodeBank):
https://www.vbforums.com/showthread....weight-Classes
Maybe it will behave better in VBA-64Bit, compared to my original version.
Olaf
Re: Implements (light weight object)
Quote:
Originally Posted by
HubVolsian
Your first 64bit version worked as expected with twinBasic but was crashing in Excel. The cause is probably due to some bug in VBA IDE. The kind reported on SO
here You should post the issue there.
Looks interesting ... I will study it.
Thanks for answering HubVolsian.
Re: Implements (light weight object)
Quote:
Originally Posted by
Schmidt
Thanks Olaf.
That's well over my head to properly understand the code at this stage... I have howewer adapted it to x64 but kept crashing at the first call of z.SomeStr and z.SomeLng.
Re: Implements (light weight object)
Quote:
Originally Posted by
AngelV
Ok . I have managed to make the AddTwoLongs Method of the light weight object work in x64 using two different approaches:
Is that due to the different memory alignement of obj and vtble structures in x64 ? I even padded the tMyObjec structure with an extra Long but no luck.
THIS CODE NO error on vba x64
it's no IMyInterface?
only IUnknown + AddTwoLongs Func?
i use to make a IUnknown callback for edge webview2,thank you
