Results 1 to 15 of 15

Thread: Implements (light weight object)

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    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.

  2. #2
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    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

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

    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

  4. #4

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    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
    Last edited by AngelV; Jun 9th, 2022 at 05:03 PM.

  5. #5
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    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
    Last edited by Schmidt; Jun 10th, 2022 at 02:03 AM.

  6. #6
    PowerPoster Zvoni's Avatar
    Join Date
    Sep 2012
    Location
    To the moon and then left
    Posts
    4,418

    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
    Last edited by Zvoni; Tomorrow at 31:69 PM.
    ----------------------------------------------------------------------------------------

    One System to rule them all, One Code to find them,
    One IDE to bring them all, and to the Framework bind them,
    in the Land of Redmond, where the Windows lie
    ---------------------------------------------------------------------------------
    People call me crazy because i'm jumping out of perfectly fine airplanes.
    ---------------------------------------------------------------------------------
    Code is like a joke: If you have to explain it, it's bad

  7. #7

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    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)
    True. I missed that one ... I've now changed it.

    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
    Name:  Sans tihjghtre.jpg
Views: 378
Size:  18.9 KB


    With TypeOf operator
    Name:  Sans tjkitre.jpg
Views: 471
Size:  22.1 KB
    Last edited by AngelV; Jun 10th, 2022 at 04:14 AM.

  8. #8
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Implements (light weight object)

    Quote Originally Posted by AngelV View Post
    With TypeName function
    Name:  Sans tihjghtre.jpg
Views: 378
Size:  18.9 KB


    With TypeOf operator
    Name:  Sans tjkitre.jpg
Views: 471
Size:  22.1 KB
    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

  9. #9

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    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 ?

  10. #10

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    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

  11. #11
    New Member
    Join Date
    Jun 2022
    Posts
    1

    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.

  12. #12
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    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

  13. #13

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    Re: Implements (light weight object)

    Quote Originally Posted by HubVolsian View Post
    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.

  14. #14

    Thread Starter
    Addicted Member
    Join Date
    Jun 2022
    Posts
    239

    Re: Implements (light weight object)

    Quote Originally Posted by Schmidt View Post
    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
    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.

  15. #15
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: Implements (light weight object)

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

Posting Permissions

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



Click Here to Expand Forum to Full Width