Announcement

Collapse
No announcement yet.

Object Windows

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Object Windows

    Here's a minimal object based GUI. To use it you include winobj.inc. This exposes two functions and four interfaces.

    Functions
    • GetApp - returns an instance of an iAppilcation object. In this case it happens to be a SimpleApplication object.
    • NewMessageBridge - returns an instance of an iMessageBridge. This is used to handle the transition from functions to objects.
    Interfaces
    • iMessageBridge - Bridge from functions to objects
    • iMessage - An interface that any "Windowing" object must implement. It has one function, the control proc.
    • iSimpleApplication - A sample reference application that allows access to predefined top window and child window classes as well as the message handline procedure.
    • iApplication - The interface for any application.
    winobj.inc
    Code:
    'Declare Function GetApp() Common As iApplication
    'Declare Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common As iMessageBridge
    '
    '===========================================================================
    'External interfaces
    '===========================================================================
    'Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
    '  Inherit IUnknown
    '  Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
    '  Method ClearBridge()
    'End Interface
    '
    'Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
    '  Inherit IUnknown
    '  Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
    'End Interface
    '
    'Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
    '  Inherit IUnknown
    '  Property Get WindowClassname() As WString
    '  Property Get ChildClassname() As WString
    '  Property Get BridgeProc() As Dword
    'End Interface
    '
    'Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
    '  Inherit IUnknown
    '  Property Get ActiveWindow() As Dword
    '  Property Set ActiveWindow( value As Dword )
    '  Method Run()
    'End Interface
     
     
    #Include Once "win32api.inc"
     
    $$APP_CLASS_NAME = "lcApp"
    $$CHILD_CLASS_NAME = "lcAppChild"
     
    ' Consider replacing this implementation with a dictionary of DWord, iMessage
    ' it will be slower but it will also be safer
    Class cMessages Guid$("{3c255bde-47a5-48d6-bcdb-c18815782418}") Common
      Instance objs_() As iMessage
      Instance cnt_ As Long
     
      Class Method Create()
      End Method
      Class Method Destroy()
        Local i As Long
        For i=0 To cnt_
          objs_(i) = Nothing
        Next
        Erase objs_()
      End Method
     
      Interface iMessages Guid$("{b1078b6f-ee69-4464-bd1f-cdc5dc6c282a}")
        Inherit IUnknown
     
        Method Add( obj As iMessage, ByVal hWnd As Dword )
          Local i As Long
          Local ub As Long
     
          If IsFalse IsInterface( obj, iMessage ) Then Exit Method
          If IsWindow( hWnd ) = 0 Then Exit Method
     
          For i=0 To cnt_-1
            If IsFalse IsObject( objs_(i) ) Then Exit For
          Next
          ub = UBound( objs_() )
          If i = cnt_ And cnt_ >= ub Then
            ReDim Preserve objs_( ub+10 )
          End If
          objs_(i) = obj
          SetWindowLong( hWnd, %GWL_USERDATA, i )
          If i=cnt_ Then Incr cnt_
        End Method
     
        Method Remove( obj As iMessage, ByVal hWnd As Dword )
          Local idx As Long
          If IsFalse IsInterface( obj, iMessage ) Then Exit Method
          If IsFalse IsWindow( hWnd ) Then Exit Method
          idx = GetWindowLong( hWnd, %GWL_USERDATA )
          If idx>=0 And idx<cnt_ Then objs_(idx) = Nothing
          SetWindowLong( hWnd, %GWL_USERDATA, -1 )
        End Method
     
        Property Get Item( ByVal hWnd As Dword ) As iMessage
          Local idx As Long
          idx = GetWindowLong( hWnd, %GWL_USERDATA )
          If idx>=0 And idx<cnt_ Then
            Property = objs_(idx)
          End If
        End Property
      End Interface
    End Class
     
    Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common Export As iMessageBridge
      Local obj As iMessageBridge
      obj = Class "cMessageBridge"
      obj.SetBridge( bridgeTo, hWnd )
      Function = obj
    End Function
     
    Global globalBridges_ As iMessages
    Global haveGlobalBridges_ As Long
     
    Class cMessageBridge Guid$("{4c07094b-1bea-4150-85ce-273934df9e22}") Common
      Instance bridgeTo_ As iMessage
      Instance hWnd_ As Dword
      Instance defProc As Dword
     
      Class Method Create()
        If IsFalse haveGlobalBridges_ Then
          globalBridges_ = Class "cMessages"
          If IsInterface( globalBridges_, iMessages ) Then haveGlobalBridges_ = -1 Else End
        End If
      End Method
     
      Class Method Destroy()
        Dim bridge As iMessageBridge
        bridge = Me
        bridge.ClearBridge()
      End Method
     
      Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
        Inherit IUnknown
     
        Property Get HWnd() As Long
          Property = hWnd_
        End Property
        Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
          Local bridge As iMessage
          Local mb As iMessageBridge
     
          mb = Me
     
          Call mb.ClearBridge()
     
          If IsFalse IsInterface( bridgeTo, iMessage ) Then Exit Method
          If IsFalse IsWindow( hWnd ) Then Exit Method
     
          hWnd_ = hWnd
     
          ' Sub-class if window didn't use our control proc
          defproc = GetWindowLong( hWnd, %GWL_WNDPROC)
          If defproc <> CodePtr(Bridge_ControlProc) Then
             SetWindowLong( hWnd, %GWL_WNDPROC, CodePtr(Bridge_ControlProc) )
          End If
     
          bridgeTo_ = bridgeTo
          bridge = Me
          globalBridges_.Add( bridge, hWnd )
        End Method
        Method ClearBridge()
          Local bridge As iMessage
     
          ' Reverse subclassing
          If IsInterface( bridgeTo_, iMessage ) Then
            If defproc And defproc <> CodePtr( Bridge_ControlProc ) Then
               SetWindowLong( hWnd_, %GWL_WNDPROC, defProc )
            End If
     
            bridge = Me
            globalBridges_.Remove( bridge, hWnd_ )
            bridgeTo_ = Nothing
          End If
        End Method
      End Interface
     
      ' Process messages
      Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        Inherit IUnknown
     
        Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
          If IsInterface( bridgeTo_, iMessage ) Then
            If IsFalse bridgeTo_.Proc( wMsg, wParam, lParam, ret ) Then
              If defProc And defProc <> CodePtr( Bridge_ControlProc ) Then
                ret = CallWindowProc( defProc, hWnd_, wMsg, wParam, lParam )
              Else
                ret = DefWindowProc( hWnd_, wMsg, wParam, lParam )
              End If
              Method = -1
            End If
          End If
        End Method
      End Interface
    End Class
     
    '==============================================================
    ' Bridge to class
    '==============================================================
    Function Bridge_ControlProc( ByVal hWnd As Dword, ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long) As Long
      Local obj As iMessage
      Local ret As Long
     
      If IsFalse haveGlobalBridges_ Then
        globalBridges_ = Class "cMessages"
        If IsInterface( globalBridges_, iMessages ) Then haveGlobalBridges_ = -1 Else End
      End If
      obj = globalBridges_.Item( hWnd )
      If IsInterface( obj, iMessage ) Then
        If obj.Proc( wMsg, wParam, lParam, ret ) Then
          Function = ret
          Exit Function
        End If
      End If
      Function = DefWindowProc( hWnd, wMsg, wParam, lParam )
    End Function
     
    '==============================================================
    ' Base application handling
    '==============================================================
    ' Single instance class
    Function GetApp() Common Export As iApplication
      Static app_ As iApplication
      Static haveApp_ As Long
     
      If IsFalse haveApp_ Then
        app_ = Class "cSimpleApplication"
        If Not IsObject( app_ ) Then
          End
        End If
        haveApp_ = -1
      End If
      Function = app_
    End Function
     
    Class cSimpleApplication Guid$("{17750903-c6c4-45cd-a9f6-19d6cfcca5fd}") Common
      Instance activeWindow_ As Dword
     
      Class Method Create()
        Call Me.RegisterClasses()
      End Method
     
      Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
        Inherit IUnknown
     
        Property Get WindowClassname() As WString
          Property = $$APP_CLASS_NAME
        End Property
        Property Get ChildClassname() As WString
          Property = $$CHILD_CLASS_NAME
        End Property
        Property Get BridgeProc() As Dword
          Property = CodePtr( Bridge_ControlProc )
        End Property
      End Interface
     
      Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
        Inherit IUnknown
     
        Property Get ActiveWindow() As Dword
          Property = activeWindow_
        End Property
        Property Set ActiveWindow( value As Dword )
          activeWindow_ = value
        End Property
     
        Method Run()
          Local msg As tagMSG
     
          Do While GetMessage( msg, %NULL, 0, 0 )>0
            If activeWindow_=0 Or IsDialogMessage( activeWindow_, msg ) = 0 Then
                TranslateMessage( msg )
                DispatchMessage( msg )
            End If
          Loop
        End Method
      End Interface
     
      Class Method RegisterClasses()
        Dim wc As WNDCLASSEX
        Dim className As WString
        Static gInit As Long
     
        If gInit Then Exit Method: ' Already initialized
        gInit=-1
        If GetClassInfoEx(%NULL, $$APP_CLASS_NAME, wc)=0 Then
          ' Register class for top window
          className = $$APP_CLASS_NAME
          wc.style = %CS_HREDRAW Or %CS_VREDRAW
          wc.cbsize = SizeOf(wc)
          wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
          wc.cbClsExtra = 0
          wc.cbWndExtra = 0
          wc.hInstance = GetModuleHandle( ByVal 0 )
          wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
          wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
          wc.hbrBackground = %COLOR_3DFACE+1: '%COLOR_WINDOW
          wc.lpszMenuName =  0
          wc.lpszClassName = StrPtr(className)
          If RegisterClassEx( wc )=0 Then
            MsgBox "Application RegisterClass failed"
            End
          End If
        End If
        If GetClassInfoEx(%NULL, $$CHILD_CLASS_NAME, wc)=0 Then
          ' Register class for top window
          className = $$CHILD_CLASS_NAME
          wc.style = 0
          wc.cbsize = SizeOf(wc)
          wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
          wc.cbClsExtra = 0
          wc.cbWndExtra = 0
          wc.hInstance = GetModuleHandle( ByVal 0 )
          wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
          wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
          wc.hbrBackground = %COLOR_WINDOW+1: ' %COLOR_3DFACE
          wc.lpszMenuName =  0
          wc.lpszClassName = StrPtr(className)
          If RegisterClassEx( wc )=0 Then
            MsgBox "Child RegisterClass failed"
            End
          End If
        End If
      End Method
    End Class
    Here's a sample application using the object windowing:
    Test.bas
    Code:
    #Compile Exe
    #Dim All
    #Compiler PBWin 10
    #Register All
     
    %UNICODE = 1
    #Include Once "win32api.inc"
    #Include Once "winobj.inc"
     
    #Include Once "MainWindow.inc"
    #Include Once "Textbox.inc"
    #Include Once "Support.inc"
     
    Function PBMain () As Long
      Local app As iApplication
      app = GetApp()
     
      Local win As iMainWindow
      win = NewMainWindow( "Test Classes", %CW_USEDEFAULT, %CW_USEDEFAULT, 320, 200 )
      win.Show()
     
      NewEditNumeric( "1", win.HWnd, 10, 10, 100, 23 )
      NewEditNumeric( "2", win.HWnd, 10, 40, 100, 23 )
      NewEditNumeric( "3", win.HWnd, 10, 70, 100, 23 )
     
      app.Run()
    End Function
    And here's a couple of sample windows and some support routines.
    MainWindow.inc
    Code:
    Function NewMainWindow( title As WString, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) Common Export As iMainWindow
      Local obj As iMainWindow
      obj = Class "cMainWindow"
      obj.CreateWindow( title, l, t, w, h )
      Function = obj
    End Function
     
    Class cMainWindow Guid$("{a319a1ad-11b0-4edb-8166-f5232ae95c1a}") Common
      Instance hWnd_ As Dword:            ' Handle to window
      Instance bridge_ As iMessageBridge: ' Message bridge
     
      Interface iMainWindow Guid$("{69bd9b9a-61f9-4cd2-a803-bd6cc364fd00}")
        Inherit IUnknown
     
        Method Show()
          ShowWindow( hWnd_, %SW_ShowNormal )
          UpdateWindow( hWnd_ )
        End Method
     
        Method CreateWindow( title As WString, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
          Local vmsg As iMessage: ' This function belongs in the Create method, but PB doesn't support parameterized constructors
          Local app As iSimpleApplication
          Local className As WString
     
          app = GetSimpleApp()
          className = app.WindowClassname()
     
          hWnd_ = CreateWindowEx( 0, ByVal StrPtr(className), ByVal StrPtr(title), %WS_OverlappedWindow Or %WS_ClipChildren, l, t, w, h, %NULL, %NULL, GetModuleHandle( ByVal 0 ), ByVal 0 )
          If IsWindow( hWnd_ ) = 0 Then End
     
          vmsg = Me
          bridge_ = NewMessageBridge( vmsg, hWnd_ ): ' hWnd needs to be valid before this is called
        End Method
        Property Get HWnd() As Dword
          Property = hWnd_
        End Property
      End Interface
     
      Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        Inherit IUnknown
     
        Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
          Method = -1: ' Default to handled, ret is already 0
          Select Case wMsg
            Case %WM_SysColorChange: Call Me.OnSysColorChange()
            Case %WM_EraseBkgnd: Exit Method
            Case %WM_MouseActivate:   Method = Me.OnActivate( Mak(Dword, %WA_ACTIVE, 0 )): Exit Method
            Case %WM_Activate:        Call Me.OnActivate( wParam ): Exit Method
            Case %WM_Destroy:         PostQuitMessage(0): Exit Method
          End Select
          Method = 0: ' If we exit this way, we didn't handle message
        End Method
      End Interface
     
      Class Method OnActivate( ByVal wParam As Long ) As Long
        Local app As iApplication
        app = GetApp()
        app.ActiveWindow = IIf&(wParam, hWnd_, 0 )
        If Lo(Word, wParam) <> %WA_INACTIVE Then SetFocus( hWnd_ )
        Method = %MA_ACTIVATE
      End Method
     
      Class Method OnSysColorChange()
        Call EnumChildWindows( hWnd_,  CodePtr( MainWindow_SysColorChange ), 0 ): ' Ensure child controls know of change
      End Method
    End Class
     
    Function MainWindow_SysColorChange(ByVal hWnd As Dword, ByVal lParam As Long ) As Long
      SendMessage( hWnd, %WM_SYSCOLORCHANGE, 0, 0 )
      Function = %TRUE
    End Function
    Textbox.inc
    Code:
    Function NewEditNumeric( title As WString, ByVal hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) Common Export As iMainWindow
      Local obj As iEditNumeric
      obj = Class "cEditNumeric"
      obj.CreateWindow( title, hParent, l, t, w, h )
      Function = obj
    End Function
     
    Class cEditNumeric Guid$("{30CE371E-4115-4FF2-94CE-E0AA6704252F}") Common
      Instance hWnd_ As Dword:            ' Handle to window
      Instance bridge_ As iMessageBridge: ' Message bridge
     
      Interface iEditNumeric Guid$("{75c4658b-57fb-4979-83a2-2c6cceddc6d6}")
        Inherit IUnknown
        Method CreateWindow( text As WString, hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
          Dim vmsg As iMessage: ' This function belongs in the Create method, but PB doesn't support parameterized constructors
          Local vStyle As Dword
     
          vStyle = %WS_Child Or %WS_Visible Or %WS_TabStop Or %WS_Border
     
          hWnd_ = CreateWindowEx( 0, "EDIT", ByVal StrPtr(Text), vStyle, l, t, w, h, hParent, %NULL, GetModuleHandle( ByVal 0 ), ByVal 0 )
     
          vmsg = Me
          bridge_ = NewMessageBridge( vmsg, hWnd_): ' hWnd needs to be valid before this is called
        End Method
     
        Property Get Text() As WString
          Local ln As Long
          Local buf As WStringZ*2
          ln = GetWindowText( hWnd_, buf, 1 )
          Local tx As WString
          tx = Space$(ln+1)
          GetWindowText( hWnd_, ByVal StrPtr(tx), ln )
          Property = tx
        End Property
        Property Set Text( value As WString )
          SetWindowText( hWnd_, ByVal StrPtr(value) )
        End Property
     
        Method Move(ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
          MoveWindow( hWnd_, l, t, w, h, %FALSE )
        End Method
      End Interface
     
      Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        Inherit IUnknown
     
        Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
          Method = -1: ' Default to handled, ret is already 0
          Select Case wMsg
            Case %WM_Char: If InStr("0123456789" +$Bs, Chr$(wParam))=0 Then Exit Method
          End Select
          Method = 0: ' If we exit this way, we didn't handle message
        End Method
      End Interface
    End Class
    Support.inc
    Code:
    Function GetSimpleApp() As iSimpleApplication
    Dim app As iApplication
    Dim simp As iSimpleApplication
    app = GetApp()
    
    simp = app
    Function = simp
    End Function
    
    Function SystemError() Common Export As WString
    Local errorCode As Dword
    Static buffer As WStringZ * 512
    errorCode = GetLastError()
    FormatMessage( %FORMAT_MESSAGE_FROM_SYSTEM, ByVal %NULL, errorCode, %NULL, buffer, SizeOf(buffer), ByVal %NULL )
    Function = buffer
    End Function
    LarryC
    Website
    Sometimes life's a dream, sometimes it's a scream

  • #2
    In this case it happens to be a SimpleApplication object
    OK, this has got to be the year's dumbest question: what is the source of information that tells me such things as a "SimpleApplication object" exists?

    I'm trying to make the transition to Objects, and I don't have a starting point.

    Can you direct me to a book or website that reveals where all these object structures live, what they're for, and maybe even how to use them? Like when I left DOS, people pointed me to Win32 books and the SDK.

    I appreciate any guidance!

    Also, although it may take me a weekend, I will play with your code and learn from it. Thank you!

    -John

    Comment


    • #3
      Source code . At the top of winobj.inc there comments listing the functions and interfaces that I provided to use externally. Documentation, still a dream, might be a scream...

      Depending on your needs you could also just put everything in the iApplication interface. A better organization might have been to put the iApplication / iSimpleApplication interfaces at the top of the source code since they would like change depending on the application needs.

      Keep in mind that PB only natively provides a handful of interfaces and objects. The PB objects/interfaces can be found in the PB help. see:
      INTERFACE, Built-in Interfaces
      Object
      Power Collection (Most of the collections available on this page)
      POWERARRAY
      PowerThread
      PowerTime

      Might be missing a few. The rest of the interfaces / objects you would be writting.
      LarryC
      Website
      Sometimes life's a dream, sometimes it's a scream

      Comment


      • #4
        Updated winobj to use a PowerCollection to map hWnd to classes. It's slower but safer than using USERDATA. Apparently the common control IPAddress uses USERDATA, so if you try to stuff and address in there, things go BOOM.

        winobj.inc
        Code:
        'Declare Function GetApp() Common As iApplication
        'Declare Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common As iMessageBridge
        '
        '===========================================================================
        'External interfaces
        '===========================================================================
        'Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
        '  Inherit IUnknown
        '
        '  Property Get HWnd() As Long
        '  Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
        '  Method ClearBridge()
        'End Interface
        '
        'Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        '  Inherit IUnknown
        '  Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
        'End Interface
        '
        'Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
        '  Inherit IUnknown
        '  Property Get WindowClassname() As WString
        '  Property Get ChildClassname() As WString
        '  Property Get BridgeProc() As Dword
        'End Interface
        '
        'Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
        '  Inherit IUnknown
        '  Property Get ActiveWindow() As Dword
        '  Property Set ActiveWindow( value As Dword )
        '  Method Run()
        'End Interface
         
         
        #Include Once "win32api.inc"
         
        $$APP_CLASS_NAME = "lcApp"
        $$CHILD_CLASS_NAME = "lcAppChild"
         
        ' Consider replacing this implementation with a dictionary of DWord, iMessage
        ' it will be slower but it will also be safer
        Global msgMap_ As IPowerCollection
        Global haveMsgMap_ As Long
         
        Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common Export As iMessageBridge
          Local obj As iMessageBridge
          obj = Class "cMessageBridge"
          obj.SetBridge( bridgeTo, hWnd )
          Function = obj
        End Function
         
        Class cMessageBridge Guid$("{4c07094b-1bea-4150-85ce-273934df9e22}") Common
          Instance bridgeTo_ As iMessage
          Instance handle_ As Dword
          Instance defProc As Dword
         
          Class Method Create()
            If IsFalse haveMsgMap_ Then
              msgMap_ = Class "PowerCollection"
              If IsInterface( msgMap_, IPowerCollection ) Then haveMsgMap_ = -1 Else End
            End If
          End Method
         
          Class Method Destroy()
            Dim bridge As iMessageBridge
            bridge = Me
            bridge.ClearBridge()
          End Method
         
          Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
            Inherit IUnknown
         
            Property Get Handle() As Long
              Property = handle_
            End Property
            Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
              Local bridge As iMessage
              Local mb As iMessageBridge
         
              mb = Me
         
              Call mb.ClearBridge()
         
              If IsFalse IsInterface( bridgeTo, iMessage ) Then Exit Method
              If IsFalse IsWindow( hWnd ) Then Exit Method
         
              handle_ = hWnd
         
              ' Sub-class if window didn't use our control proc
              defproc = GetWindowLong( hWnd, %GWL_WNDPROC)
              SetWindowLong( hWnd, %GWL_WNDPROC, CodePtr(Bridge_ControlProc) )
         
              bridgeTo_ = bridgeTo
              bridge = Me
              Local key As WString
              key = Format$( hWnd, "0")
              msgMap_.Add( key, bridge )
            End Method
            Method ClearBridge()
              Local bridge As iMessage
         
              ' Reverse subclassing
              If IsInterface( bridgeTo_, iMessage ) Then
                SetWindowLong( handle_, %GWL_WNDPROC, defProc )
         
                bridge = Me
                Local key As WString
                key = Format$( handle_, "0")
                msgMap_.Remove( key )
                bridgeTo_ = Nothing
              End If
            End Method
          End Interface
         
          ' Process messages
          Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
            Inherit IUnknown
         
            Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
              If IsInterface( bridgeTo_, iMessage ) Then
                If IsFalse bridgeTo_.Proc( wMsg, wParam, lParam, ret ) Then
                  If defProc And defProc <> CodePtr( Bridge_ControlProc ) Then
                    ret = CallWindowProc( defProc, handle_, wMsg, wParam, lParam )
                  Else
                    ret = DefWindowProc( handle_, wMsg, wParam, lParam )
                  End If
                  Method = -1
                End If
              End If
            End Method
          End Interface
        End Class
         
        '==============================================================
        ' Bridge to class
        '==============================================================
        Function Bridge_ControlProc( ByVal hWnd As Dword, ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long) As Long
          Local obj As iMessage
          Local ret As Long
          Local v As Variant
         
          Local key As WString
          key = Format$( hWnd, "0")
          v = msgMap_.Item( key )
          obj = v
          If IsInterface( obj, iMessage ) Then
            If obj.Proc( wMsg, wParam, lParam, ret ) Then
              Function = ret
              Exit Function
            End If
          End If
          Function = DefWindowProc( hWnd, wMsg, wParam, lParam )
        End Function
         
        '==============================================================
        ' Base application handling
        '==============================================================
        ' Single instance class
        Function GetApp() Common Export As iApplication
          Static app_ As iApplication
          Static haveApp_ As Long
         
          If IsFalse haveApp_ Then
            If IsFalse haveMsgMap_ Then
              msgMap_ = Class "PowerCollection"
              If IsInterface( msgMap_, IPowerCollection ) Then haveMsgMap_ = -1 Else End
            End If
         
            app_ = Class "cSimpleApplication"
            If Not IsObject( app_ ) Then
              End
            End If
            haveApp_ = -1
          End If
          Function = app_
        End Function
         
        Class cSimpleApplication Guid$("{17750903-c6c4-45cd-a9f6-19d6cfcca5fd}") Common
          Instance activeWindow_ As Dword
         
          Class Method Create()
            Call Me.RegisterClasses()
          End Method
         
          Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
            Inherit IUnknown
         
            Property Get WindowClassname() As WString
              Property = $$APP_CLASS_NAME
            End Property
            Property Get ChildClassname() As WString
              Property = $$CHILD_CLASS_NAME
            End Property
            Property Get BridgeProc() As Dword
              Property = CodePtr( Bridge_ControlProc )
            End Property
          End Interface
         
          Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
            Inherit IUnknown
         
            Property Get ActiveWindow() As Dword
              Property = activeWindow_
            End Property
            Property Set ActiveWindow( value As Dword )
              activeWindow_ = value
            End Property
         
            Method Run()
              Local msg As tagMSG
         
              Do While GetMessage( msg, %NULL, 0, 0 )>0
                If activeWindow_=0 Or IsDialogMessage( activeWindow_, msg ) = 0 Then
                    TranslateMessage( msg )
                    DispatchMessage( msg )
                End If
              Loop
            End Method
          End Interface
         
          Class Method RegisterClasses()
            Dim wc As WNDCLASSEX
            Dim className As WString
            Static gInit As Long
         
            If gInit Then Exit Method: ' Already initialized
            gInit=-1
            If GetClassInfoEx(%NULL, $$APP_CLASS_NAME, wc)=0 Then
              ' Register class for top window
              className = $$APP_CLASS_NAME
              wc.style = %CS_HREDRAW Or %CS_VREDRAW
              wc.cbsize = SizeOf(wc)
              wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
              wc.cbClsExtra = 0
              wc.cbWndExtra = 0
              wc.hInstance = GetModuleHandle( ByVal 0 )
              wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
              wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
              wc.hbrBackground = %COLOR_3DFACE+1: '%COLOR_WINDOW
              wc.lpszMenuName =  0
              wc.lpszClassName = StrPtr(className)
              If RegisterClassEx( wc )=0 Then
                MsgBox "Application RegisterClass failed"
                End
              End If
            End If
            If GetClassInfoEx(%NULL, $$CHILD_CLASS_NAME, wc)=0 Then
              ' Register class for top window
              className = $$CHILD_CLASS_NAME
              wc.style = 0
              wc.cbsize = SizeOf(wc)
              wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
              wc.cbClsExtra = 0
              wc.cbWndExtra = 0
              wc.hInstance = GetModuleHandle( ByVal 0 )
              wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
              wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
              wc.hbrBackground = %COLOR_WINDOW+1: ' %COLOR_3DFACE
              wc.lpszMenuName =  0
              wc.lpszClassName = StrPtr(className)
              If RegisterClassEx( wc )=0 Then
                MsgBox "Child RegisterClass failed"
                End
              End If
            End If
          End Method
        End Class
        LarryC
        Website
        Sometimes life's a dream, sometimes it's a scream

        Comment

        Working...
        X