project one workng with project2

[doberman2002]

project 1 has list1
has items random or any for the sake of test.

project2.
can you delete list1 items on project1.
also click a button,add item

[wqweto]

Here is a sample PutObject function that uses ROT (Running Objects Table) to register forms from one project as file monikers and then uses built-in GetObject function to retrieve reference to these forms in another executable.

Start w/ an empty Std-EXE Project1, add a List1 in Form1 and paste this code

Option Explicit
 
Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName 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 m_lCookie As Long
 
Private Sub Form_Load()
    List1.AddItem "test"
    List1.AddItem Now
    m_lCookie = PutObject(Me, "MySpecialProject.Form1")
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    RevokeObject m_lCookie
End Sub
 
Public Function PutObject(oObj As Object, sPathName As String, Optional ByVal Flags As Long) As Long
    Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    Const IDX_REGISTER  As Long = 3
    Dim hResult         As Long
    Dim pROT            As IUnknown
    Dim pMoniker        As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    hResult = CreateFileMoniker(StrPtr(sPathName), pMoniker)
    If hResult < 0 Then
        Err.Raise hResult, "CreateFileMoniker"
    End If
    DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE Or Flags, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
End Function
 
Public Sub RevokeObject(ByVal lCookie As Long)
    Const IDX_REVOKE    As Long = 4
    Dim hResult         As Long
    Dim pROT            As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    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, "DispCallFunc"
    End If
End Function

Start new VBIDE w/ a new empty Std-EXE Project2, add two buttons -- Command1 and Command2 -- and paste this code

Option Explicit
 
Private m_oForm1 As Object
 
Private Sub Form_Load()
    Set m_oForm1 = GetObject("MySpecialProject.Form1")
End Sub
 
Private Sub Command1_Click()
    m_oForm1.List1.AddItem "Test " & Now
End Sub
 
Private Sub Command2_Click()
    m_oForm1.List1.RemoveItem 0
End Sub

First start Project1 to register MySpecialProject.Form1 in ROT, then run Project2 and test add/remove items from the ListBox in the first executable.

Clicking buttons on Form1 is as easy as m_oForm1.Command1.Value = True

Edit: Another options is to register VB.Global.Forms collection so Project2 can enumerate *all* forms from Project1 and pick which one it needs to manipulate remotely.

cheers,
</wqw>

[LaVolpe]

If project1 and project2 are each compiled, you may want to do some self-learning. Research the topic: Interprocess communication

[wqweto]

wqweto hello.
sorry for bothering.
in this post you published a very useful for my code.
http://www.vbforums.com/showthread.p...=1#post5422507
my question is can get the object and the events as "Private WithEvents as Object test" for example.

and other questions.
You can be obtained all procedures, functions and properties within the object with parameters

Greetings, sorry for the language

There is no problem receiving events from objects in ROT, try this in Project1

Option Explicit
 
Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName 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 m_lCookie As Long
 
Private Sub Form_Click()
    Me.Font.Size = Me.Font.Size + 1
End Sub
 
Private Sub Form_Load()
    m_lCookie = PutObject(Me.Font, "MySpecialProject.Font")
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    RevokeObject m_lCookie
End Sub
 
Public Function PutObject(oObj As Object, sPathName As String, Optional ByVal Flags As Long) As Long
    Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    Const IDX_REGISTER  As Long = 3
    Dim hResult         As Long
    Dim pROT            As IUnknown
    Dim pMoniker        As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    hResult = CreateFileMoniker(StrPtr(sPathName), pMoniker)
    If hResult < 0 Then
        Err.Raise hResult, "CreateFileMoniker"
    End If
    DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE Or Flags, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
End Function
 
Public Sub RevokeObject(ByVal lCookie As Long)
    Const IDX_REVOKE    As Long = 4
    Dim hResult         As Long
    Dim pROT            As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    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, "DispCallFunc"
    End If
End Function

And this in Project2

Option Explicit
 
Private WithEvents m_oFont As StdFont
 
Private Sub Form_Load()
    Set m_oFont = GetObject("MySpecialProject.Font")
End Sub
 
Private Sub m_oFont_FontChanged(ByVal PropertyName As String)
    Debug.Print "PropertyName=" & PropertyName, Timer
End Sub

Notice how clicking on the form in Project1 raises FontChanged event in Project2.

But there is a problem receiving events from VB forms (e.g. Form1) and VB controls (e.g. List1) in this way probably because VB6 is creating control wrappers (real interfaces are hard to access) which actually get registered in ROT - yikes!

Also there is the ADODB.Recordset beast which implements custom marshaling (implements IMarshal or similar interface), so once in ROT you get a *separate* deep copy of the data with GetObject call in Project2 and thus the events are not raised/relevant accross the processes.

For your second question you should ask in the forums if someone else can chime in how to do it.

cheers,
</wqw>
p.s. Replied here because PMs are limited to 2000 chars.

[yokesee]

wqweto hi, thanks for answering.
very good information but I have problems with the classes that are no longer defined example.

project 1:
Class1:

Public Event testevent()
Public Sub test()
    RaiseEvent testevent
End Sub

form:

Option Explicit
 
Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName 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 m_lCookie As Long
Private m_class As Long
Private test_class As Object
Private Sub Form_Click()
    Me.Font.Size = Me.Font.Size + 10
    Me.Cls
    Me.Print "hola"
    test_class.test
End Sub
 
Private Sub Form_Load()
    Set test_class = New Class1
    m_lCookie = PutObject(Me.Font, "MySpecialProject.Font")
    m_class = PutObject(test_class, "MySpecialProject.class")
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    RevokeObject m_lCookie
    RevokeObject m_class
End Sub
 
Public Function PutObject(oObj As Object, sPathName As String, Optional ByVal Flags As Long) As Long
    Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    Const IDX_REGISTER  As Long = 3
    Dim hResult         As Long
    Dim pROT            As IUnknown
    Dim pMoniker        As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    hResult = CreateFileMoniker(StrPtr(sPathName), pMoniker)
    If hResult < 0 Then
        Err.Raise hResult, "CreateFileMoniker"
    End If
    DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE Or Flags, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
End Function
 
Public Sub RevokeObject(ByVal lCookie As Long)
    Const IDX_REVOKE    As Long = 4
    Dim hResult         As Long
    Dim pROT            As IUnknown
    
    hResult = GetRunningObjectTable(0, pROT)
    If hResult < 0 Then
        Err.Raise hResult, "GetRunningObjectTable"
    End If
    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, "DispCallFunc"
    End If
End Function

project 2:

Option Explicit
 
Private WithEvents m_oFont As StdFont
Private WithEvents m_class As Class1
Private Sub Form_Load()
    Set m_oFont = GetObject("MySpecialProject.Font")
    Set m_class = GetObject("MySpecialProject.class")
End Sub
 
Private Sub m_oFont_FontChanged(ByVal PropertyName As String)
    Debug.Print "PropertyName=" & PropertyName, Timer
End Sub

the project2 gives me the error that mismatch.
is this what you mean it does not work on all interfaces.

the project2 gives me the error that mismatch.
is this what you mean it does not work on all interfaces.

Could you explain better this or have any examples

Also there is the ADODB.Recordset beast which implements custom marshaling (implements IMarshal or similar interface), so once in ROT you get a *separate* deep copy of the data with GetObject call in Project2 and thus the events are not raised/relevant accross the processes.

greetings, sorry for the language

[wqweto]

Yes, this is another limitation -- cannot use private classes from the Std-EXE for no apparent reason, that's why I'm using forms instances usually.

Object types have to be publicly visible ones probably w/ proper typelib for OLE Automation marshalling to succeed.

cheers,
</wqw>

[yokesee]

I test with dll events and currently serves me
thank you

[dz32]

looks like you can make this work with private classes once compiled if you change the Object.ObjectType to 0x118803

these are bitfields so this is crude could break stuff, better to set the appropriate bit

 0001 0001 1000 0000 0000 0011 --> 0x118003  - private exe class normal 
 0001 0001 1000 1000 0000 0011 --> 0x118803  - public class
 0000 0000 0000 1000 0000 0000 --> 0x000800 -  ocx/dll

will have to look into what to do while running in the IDE and if there are any side effects but quick test worked anyway

bitfields:
https://github.com/VBGAMER45/Semi-VB...obals.bas#L280

actually these would be pretty easy to patch in memory, just create one live instances of the class, get the objPtr -> vtable -4 for objInfo then get object then patch..same patcher should work in IDE and compiled just run it once per object..

[dz32]

soooo patching it in memory after loaded by the runtime was a fail, has to be patched on disk or reach deeper into the runtime

misc note, the error code does not appear in the vbruntime itself
Error: 0x62 - A property or method call cannot include a reference to a private object, either as an argument or as a return value

  Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long
    Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
    Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Const RWE = &H40

    Function dbg(x)
        Debug.Print x
        List2.AddItem x
        'MsgBox x
    End Function
    
    Function patchClassType(obj As Object, Optional andPatch As Boolean = True) As Boolean
    
        Dim pVTbl As Long, pObjInfo As Long, pObj As Long, objType As Long, oldMemProt As Long, r As Long
        
        Const flag = &H800 '1000 0000 0000
        
        dbg "Typename(obj) = " & TypeName(obj)
        
        GetMem4 ByVal ObjPtr(obj), pVTbl                 ' Pointer to vTable.
        'dbg "pVTbl=" & Hex(pVTbl)
        
        GetMem4 ByVal pVTbl - 4&, pObjInfo              ' Pointer to tObjectInfo structure.
        'dbg "pObjInfo =" & Hex(pObjInfo)
         
        GetMem4 ByVal pObjInfo + &H18&, pObj            ' Pointer to tObject     structure.
        'dbg "pObj=" & Hex(pObj)
         
        GetMem4 ByVal pObj + &H28&, objType             ' objType value
        
        dbg "Current ObjType: " & Hex(objType)
        
        If andPatch Then
            If (objType And flag) = 0 Then 
                
                objType = objType Xor flag
                
                If VirtualProtect(ByVal (pObj + &H28), 4, RWE, oldMemProt) <> 0 Then
                    dbg "Patching to: " & Hex(objType)
                    PutMem4 ByVal pObj + &H28&, objType
                    'dbg "Patched"
                
                    GetMem4 ByVal pObj + &H28&, objType
                    dbg "Sanity Check: " & Hex(objType)
                    
                    patchClassType = True
                    VirtualProtect ByVal (pObj + &H28), 4, oldMemProt, r
                Else
                    dbg "virt prot failed"
                End If
                
            Else
                dbg "Cant patch flag already set?"
            End If
        End If
    
    End Function

[dz32]

ok, actually this patching in memory does work, I just missed a small detail.

we need the first live instance of the class to easily get to the object structure.
however this first class was already created with the original flags.

Any subsequent class created after this will be created using the new objType and
will be accessible through the ROT, this includes direct access to classes.

sample project attached. or git: https://github.com/dzzie/tests/tree/master/rot_test

[dz32]

and just to be thorough, an easy way to patch all classes in the project, starting from any random (internal) class instance

https://github.com/dzzie/tests/blob/...Scriptable.cls

edit: added this to a large project and seems to be working well. note parent and child have to be running at same privilege level
(both as admin or both not)

[xiaoyao]

and just to be thorough, an easy way to patch all classes in the project, starting from any random (internal) class instance

https://github.com/dzzie/tests/blob/...scriptable.cls

edit: Added this to a large project and seems to be working well. Note parent and child have to be running at same privilege level
(both as admin or both not)

wher is download url?

[dz32]

rot test 3 attached

[xiaoyao]

Perhaps a private class could be declared using a TLB file.
Because the class of VB6 has no type library information after compilation. He just belongs to the virtual table. There is no way to use late bound method operations.

This may be one reason why the rot object cannot be registered.

[dz32]

Different things. Classes can be late bound no problem through idispatch this is how all scripting clients work. Tlb is only type information. I didn’t research exactly what the flags change for object creation, just observed the effects.

[xiaoyao]

ROT BY FORM1,FRM OR class1.cls,can't withevents on client getobject(**)?

[dz32]

I dont think events on late bound objects is possible by default in vb. pywin32 had some way to sink events for late bound objects and forward them on to a script client but I did not study it. The ms script control can do it too I believe but that is not open source for study.

[xiaoyao]

activexe.exe rot
exe+activex dll(with rot)
with Events can be set in the above two schemes.

Or two rot projects can reference each other and generate cross-process events.
project1.exe put object rot1.class
project12exe put object rot2.class

Trigger each other where you need time.
project1.exe call rot2.fireevent(eventname,argList())

[dz32]

if you created an activex dll or tlb and registered it on system, then used Implements in the class, then in client used

dim obj as object
dim withevents eface as externalInterface
set obj = getobject(**)
set eface = obj

this would probably work.

manually registering internal classes in the ROT isnt something I would normally do. its not a normal technique. I do not recommend it unless you are certain it appropriate.

[xiaoyao]

com dll class for rot
dim withevents eface as externalInterface
set eface= getobject(**)

That's all right.
it's like activex.exe

I even doubt it. If a main program starts the service, 10 client programs, ah, get the object.If an event is triggered, each client gets an event response.


This becomes a notification-like trigger mechanism.

Or, as with windows events, perhaps only one client will get a response.

The createevents API has a main program with multiple clients waiting for signals at the same time.

If the signal is set to him, only one client will get a response.
If each client wants to get the message response, it must send the signal n times.
call setevents

[wqweto]

Or, as with windows events, perhaps only one client will get a response.

Don't be lazy, you can test it yourself! :-))

Edit: Bet every client is notified, i.e. acting like regular events in COM/VB6.

cheers,
</wqw>

[VanGoghGaming]

It turns out you could register a VB6 form in the Running Objects Table without any monikers just by using the RegisterActiveObject / GetActiveObject API functions. In this example I used the form's IID as the registration identifier to avoid passing any command line parameters.

The project contains just a Form with a TextBox on it and all the code goes into the "Sub Main" of a BAS module. Only run the project in compiled form (EXE) because the form's IID is not the same between running in IDE and the executable:

Module1.bas

Option Explicit

Private Type tIID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Enum HRESULT
    S_OK
    S_FALSE
End Enum

Private Enum ACTIVE_OBJECT_FLAGS
    ACTIVEOBJECT_STRONG
    ACTIVEOBJECT_WEAK
End Enum

Private Declare Function GetActiveObject Lib "oleaut32" Alias "#35" (ByVal rCLSID As Long, Optional ByVal pvReserved As Long, Optional ppUnk As IUnknown) As HRESULT
Private Declare Function RegisterActiveObject Lib "oleaut32" Alias "#33" (ByVal pUnk As IUnknown, ByVal rCLSID As Long, Optional ByVal dwFlags As ACTIVE_OBJECT_FLAGS = ACTIVEOBJECT_WEAK, Optional pdwRegister As Long) As HRESULT
Private Declare Function ArrPtr Lib "msvbvm60" Alias "#390" (vArray As Variant) As Long
Private Declare Sub CopyBytes Lib "msvbvm60" Alias "#183" (ByVal Length As Long, Destination As Any, Source As Any)
Private Declare Sub GetMem4 Lib "msvbvm60" Alias "#301" (Ptr As Any, RetVal As Long)

Public Sub Main()
Dim pSA As Long, objCopy As Object, arrForm(0 To 0) As Form1, FormIID As tIID
    GetMem4 ByVal ArrPtr(arrForm), pSA
    CopyBytes LenB(FormIID), ByVal VarPtr(FormIID), ByVal pSA - LenB(FormIID)
    If GetActiveObject(VarPtr(FormIID), , objCopy) = S_OK Then
        objCopy.Text1 = "Hello from ThreadID: " & App.ThreadID
    Else
        Form1.Caption = "ThreadID: " & App.ThreadID: Form1.Show
        If RegisterActiveObject(Form1, VarPtr(FormIID)) = S_OK Then Shell App.Path & "\" & App.Title
    End If
End Sub

The program first checks if the form has been previously registered in the ROT and if not then it registers it and spawns another instance of itself which writes some text in the main instance's TextBox. You could use randomly generated GUIDs as the registration identifier but then you'd need to pass them as command line parameters to the spawned instance.



Here's the demo project: RegisterActiveObject.zip

[xiaoyao]

how to use GetObject by api?