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
thinBasic 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
Start new VBIDE w/ a new empty Std-EXE Project2, add two buttons -- Command1 and Command2 -- and paste this code
thinBasic 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>
Last edited by wqweto; Oct 13th, 2019 at 03:39 AM.
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
thinBasic 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 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.
wqweto hi, thanks for answering.
very good information but I have problems with the classes that are no longer defined example.
project 1:
Class1:
Code:
Public Event testevent()
Public Sub test()
RaiseEvent testevent
End Sub
form:
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 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:
Code:
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.
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..
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
Code:
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
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.
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)
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)
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.
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.
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.
if you created an activex dll or tlb and registered it on system, then used Implements in the class, then in client used
Code:
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.
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