Results 1 to 7 of 7

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
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,040

    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,102

    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
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,040

    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
    Addicted Member
    Join Date
    Jun 2016
    Location
    Espaņa
    Posts
    148

    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
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,040

    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
    Addicted Member
    Join Date
    Jun 2016
    Location
    Espaņa
    Posts
    148

    Re: project one workng with project2

    I test with dll events and currently serves me
    thank you

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