Results 1 to 11 of 11

Thread: project one workng with project2

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Aug 2019
    Posts
    194

    project one workng with project2

    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

  2. #2
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    4,483

    Re: project one workng with project2

    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:
    1. Option Explicit
    2.  
    3. Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
    4. Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName As Long, pResult As IUnknown) As Long
    5. 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
    6.  
    7. Private m_lCookie As Long
    8.  
    9. Private Sub Form_Load()
    10.     List1.AddItem "test"
    11.     List1.AddItem Now
    12.     m_lCookie = PutObject(Me, "MySpecialProject.Form1")
    13. End Sub
    14.  
    15. Private Sub Form_Unload(Cancel As Integer)
    16.     RevokeObject m_lCookie
    17. End Sub
    18.  
    19. Public Function PutObject(oObj As Object, sPathName As String, Optional ByVal Flags As Long) As Long
    20.     Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    21.     Const IDX_REGISTER  As Long = 3
    22.     Dim hResult         As Long
    23.     Dim pROT            As IUnknown
    24.     Dim pMoniker        As IUnknown
    25.    
    26.     hResult = GetRunningObjectTable(0, pROT)
    27.     If hResult < 0 Then
    28.         Err.Raise hResult, "GetRunningObjectTable"
    29.     End If
    30.     hResult = CreateFileMoniker(StrPtr(sPathName), pMoniker)
    31.     If hResult < 0 Then
    32.         Err.Raise hResult, "CreateFileMoniker"
    33.     End If
    34.     DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE Or Flags, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
    35. End Function
    36.  
    37. Public Sub RevokeObject(ByVal lCookie As Long)
    38.     Const IDX_REVOKE    As Long = 4
    39.     Dim hResult         As Long
    40.     Dim pROT            As IUnknown
    41.    
    42.     hResult = GetRunningObjectTable(0, pROT)
    43.     If hResult < 0 Then
    44.         Err.Raise hResult, "GetRunningObjectTable"
    45.     End If
    46.     DispCallByVtbl pROT, IDX_REVOKE, lCookie
    47. End Sub
    48.  
    49. Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    50.     Const CC_STDCALL    As Long = 4
    51.     Dim lIdx            As Long
    52.     Dim vParam()        As Variant
    53.     Dim vType(0 To 63)  As Integer
    54.     Dim vPtr(0 To 63)   As Long
    55.     Dim hResult         As Long
    56.    
    57.     vParam = A
    58.     For lIdx = 0 To UBound(vParam)
    59.         vType(lIdx) = VarType(vParam(lIdx))
    60.         vPtr(lIdx) = VarPtr(vParam(lIdx))
    61.     Next
    62.     hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    63.     If hResult < 0 Then
    64.         Err.Raise hResult, "DispCallFunc"
    65.     End If
    66. End Function
    Start new VBIDE w/ a new empty Std-EXE Project2, add two buttons -- Command1 and Command2 -- and paste this code

    thinBasic Code:
    1. Option Explicit
    2.  
    3. Private m_oForm1 As Object
    4.  
    5. Private Sub Form_Load()
    6.     Set m_oForm1 = GetObject("MySpecialProject.Form1")
    7. End Sub
    8.  
    9. Private Sub Command1_Click()
    10.     m_oForm1.List1.AddItem "Test " & Now
    11. End Sub
    12.  
    13. Private Sub Command2_Click()
    14.     m_oForm1.List1.RemoveItem 0
    15. 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>

  3. #3
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,543

    Re: project one workng with project2

    If project1 and project2 are each compiled, you may want to do some self-learning. Research the topic: Interprocess communication
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  4. #4
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    4,483

    Re: project one workng with project2

    Quote Originally Posted by yokesee
    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:
    1. Option Explicit
    2.  
    3. Private Declare Function GetRunningObjectTable Lib "ole32" (ByVal dwReserved As Long, pResult As IUnknown) As Long
    4. Private Declare Function CreateFileMoniker Lib "ole32" (ByVal lpszPathName As Long, pResult As IUnknown) As Long
    5. 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
    6.  
    7. Private m_lCookie As Long
    8.  
    9. Private Sub Form_Click()
    10.     Me.Font.Size = Me.Font.Size + 1
    11. End Sub
    12.  
    13. Private Sub Form_Load()
    14.     m_lCookie = PutObject(Me.Font, "MySpecialProject.Font")
    15. End Sub
    16.  
    17. Private Sub Form_Unload(Cancel As Integer)
    18.     RevokeObject m_lCookie
    19. End Sub
    20.  
    21. Public Function PutObject(oObj As Object, sPathName As String, Optional ByVal Flags As Long) As Long
    22.     Const ROTFLAGS_REGISTRATIONKEEPSALIVE As Long = 1
    23.     Const IDX_REGISTER  As Long = 3
    24.     Dim hResult         As Long
    25.     Dim pROT            As IUnknown
    26.     Dim pMoniker        As IUnknown
    27.    
    28.     hResult = GetRunningObjectTable(0, pROT)
    29.     If hResult < 0 Then
    30.         Err.Raise hResult, "GetRunningObjectTable"
    31.     End If
    32.     hResult = CreateFileMoniker(StrPtr(sPathName), pMoniker)
    33.     If hResult < 0 Then
    34.         Err.Raise hResult, "CreateFileMoniker"
    35.     End If
    36.     DispCallByVtbl pROT, IDX_REGISTER, ROTFLAGS_REGISTRATIONKEEPSALIVE Or Flags, ObjPtr(oObj), ObjPtr(pMoniker), VarPtr(PutObject)
    37. End Function
    38.  
    39. Public Sub RevokeObject(ByVal lCookie As Long)
    40.     Const IDX_REVOKE    As Long = 4
    41.     Dim hResult         As Long
    42.     Dim pROT            As IUnknown
    43.    
    44.     hResult = GetRunningObjectTable(0, pROT)
    45.     If hResult < 0 Then
    46.         Err.Raise hResult, "GetRunningObjectTable"
    47.     End If
    48.     DispCallByVtbl pROT, IDX_REVOKE, lCookie
    49. End Sub
    50.  
    51. Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    52.     Const CC_STDCALL    As Long = 4
    53.     Dim lIdx            As Long
    54.     Dim vParam()        As Variant
    55.     Dim vType(0 To 63)  As Integer
    56.     Dim vPtr(0 To 63)   As Long
    57.     Dim hResult         As Long
    58.    
    59.     vParam = A
    60.     For lIdx = 0 To UBound(vParam)
    61.         vType(lIdx) = VarType(vParam(lIdx))
    62.         vPtr(lIdx) = VarPtr(vParam(lIdx))
    63.     Next
    64.     hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    65.     If hResult < 0 Then
    66.         Err.Raise hResult, "DispCallFunc"
    67.     End If
    68. End Function
    And this in Project2

    thinBasic Code:
    1. Option Explicit
    2.  
    3. Private WithEvents m_oFont As StdFont
    4.  
    5. Private Sub Form_Load()
    6.     Set m_oFont = GetObject("MySpecialProject.Font")
    7. End Sub
    8.  
    9. Private Sub m_oFont_FontChanged(ByVal PropertyName As String)
    10.     Debug.Print "PropertyName=" & PropertyName, Timer
    11. 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.

  5. #5
    Hyperactive Member
    Join Date
    Jun 2016
    Location
    Espaņa
    Posts
    367

    Re: project one workng with project2

    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.
    greetings, sorry for the language

  6. #6
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    4,483

    Re: project one workng with project2

    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>

  7. #7
    Hyperactive Member
    Join Date
    Jun 2016
    Location
    Espaņa
    Posts
    367

    Re: project one workng with project2

    I test with dll events and currently serves me
    thank you

  8. #8
    Fanatic Member
    Join Date
    Jun 2015
    Posts
    848

    Re: project one workng with project2

    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

    Code:
     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..
    Last edited by dz32; Nov 16th, 2022 at 07:50 PM.

  9. #9
    Fanatic Member
    Join Date
    Jun 2015
    Posts
    848

    Re: project one workng with project2

    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
    Last edited by dz32; Nov 17th, 2022 at 12:41 PM.

  10. #10
    Fanatic Member
    Join Date
    Jun 2015
    Posts
    848

    Re: project one workng with project2

    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
    Attached Files Attached Files
    Last edited by dz32; Nov 17th, 2022 at 08:32 PM.

  11. #11
    Fanatic Member
    Join Date
    Jun 2015
    Posts
    848

    Re: project one workng with project2

    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)
    Last edited by dz32; Nov 19th, 2022 at 06:39 PM.

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