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
Printable View
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
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
Start new VBIDE w/ a new empty Std-EXE Project2, add two buttons -- Command1 and Command2 -- and paste this codethinBasic Code:
First start Project1 to register MySpecialProject.Form1 in ROT, then run Project2 and test add/remove items from the ListBox in the first executable.thinBasic Code:
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>
If project1 and project2 are each compiled, you may want to do some self-learning. Research the topic: Interprocess communication
There is no problem receiving events from objects in ROT, try this in Project1Quote:
Originally Posted by yokesee
And this in Project2thinBasic Code:
Notice how clicking on the form in Project1 raises FontChanged event in Project2.thinBasic Code:
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:
form:Code:Public Event testevent()
Public Sub test()
RaiseEvent testevent
End Sub
project 2: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
the project2 gives me the error that mismatch.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
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
greetings, sorry for the languageQuote:
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.
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>
I test with dll events and currently serves me
thank you
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
will have to look into what to do while running in the IDE and if there are any side effects but quick test worked anywayCode: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
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..
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.
sample project attached. or git: https://github.com/dzzie/tests/tree/master/rot_test
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?Quote:
Originally Posted by dz32
rot test 3 attached
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.
ROT BY FORM1,FRM OR class1.cls,can't withevents on client getobject(**)?
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.
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())
if you created an activex dll or tlb and registered it on system, then used Implements in the class, then in client used
this would probably work.Code:dim obj as object
dim withevents eface as externalInterface
set obj = getobject(**)
set eface = obj
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
Don't be lazy, you can test it yourself! :-))Quote:
Originally Posted by xiaoyao
Edit: Bet every client is notified, i.e. acting like regular events in COM/VB6.
cheers,
</wqw>
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
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.Code: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
Attachment 192623
Here's the demo project: Attachment 192624
how to use GetObject by api?