[RESOLVED] objptr alternative

[JAAFAR]

Here is an implementation of PutObject (the opposite of the built-in GetObject) w/ no external typelibs.

Option Explicit
 
Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName As Long, pResult As IUnknown) As Long
Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, 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
 
Private Sub Form_Load()
    Dim lCookie     As Long
    Dim oCol        As Collection
    Dim lColCookie  As Long
    
    lCookie = PutObject(Me, "MyMoniker")
    Debug.Print TypeName(GetObject("MyMoniker"))    '--- returns Form1
    '--- warning: "MyMoniker" path is "stacked"
    Set oCol = New Collection
    lColCookie = PutObject(oCol, "MyMoniker")
    Debug.Print TypeName(GetObject("MyMoniker"))    '--- still Form1
    '--- "pops" Form1
    RevokeObject lCookie
    Debug.Print TypeName(GetObject("MyMoniker"))    '--- returns Collection now
    RevokeObject lColCookie
End Sub
 
Private Function PutObject(oObj As Object, sPathName As String) As Long
    Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    Const IDX_REGISTER  As Long = 3
    Dim pROT            As IUnknown
    Dim pMoniker        As IUnknown
    
    Call GetRunningObjectTable(0, pROT)
    Call CreateFileMoniker(StrPtr(sPathName), pMoniker)
    DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
End Function
 
Private Sub RevokeObject(ByVal lCookie As Long)
    Const IDX_REVOKE    As Long = 4
    Dim pROT            As IUnknown
    
    Call GetRunningObjectTable(0, pROT)
    DispCallByVtbl pROT, IDX_REVOKE, lCookie
End Sub
 
Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    Const CC_STDCALL    As Long = 4
    Dim lIdx            As Long
    Dim vParam()        As Variant
    Dim vType(0 To 63)  As Integer
    Dim vPtr(0 To 63)   As Long
    Dim hResult         As Long
    
    vParam = A
    For lIdx = 0 To UBound(vParam)
        vType(lIdx) = VarType(vParam(lIdx))
        vPtr(lIdx) = VarPtr(vParam(lIdx))
    Next
    hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    If hResult < 0 Then
        Err.Raise hResult
    End If
End Function

You get RevokeObject too to test ROT registration at will.

Also note that you would probably need to use "MyMoniker" & App.hInstance just to be safe with these moniker paths cross-process "interferences".

cheers,
</wqw>

Hi wqweto,

Nice code. Thanks.

I want to add a new file moniker name to an item already existing in the Running Object Table so I can then Use GetObject("NEW MONIKER PATHNAME")

It works only if PutObject is executed from within the Process where the object being registered resides\lives... It doesn't work and I get an NULL cookie if PutObject is ran from different Application\Process.

This is what I am doing from a different process.

Set Obj= GetObject ("Exising Moniker PathName")
PutObject Obj, "New Moniker PathName"
then
Set Obj= GetObject ("New Moniker PathName") <= error - not registered in ROT.

Is there a way of using PutObject from a different process ?

Regards.