Announcement

Collapse
No announcement yet.

Windows message bridge to classes

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

  • Windows message bridge to classes

    I wanted to reduce the effort needed to implement handling Windows messages in a class. I came up with the following file that can either be included or linked as an SLL. It requires 31 lines to use. 28 are copy and paste with two changes for your class/interface name. 2 lines have a sample that blocks numberic entry in a text box. 1 lines calls the method that creates the window.

    Message.bas
    Code:
    #If Not %Def( %INCLUDE )
    #Compile SLL "Message.sll"
    #Dim All
    #Compiler PBWin 10.03
    #EndIf
     
    #Include Once "win32api.inc"
     
    Function NewMessageTrack() Common Export As iMessageTrack
      Local obj As iMessageTrack
      obj = Class "cMessageTrack"
      Function = obj
    End Function
     
    ' Consider replacing this implementation with a dictionary of DWord, iMessage
    ' it will be slower but it will also be safer
    Class cMessageTrack 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 iMessageTrack Guid$("{b1078b6f-ee69-4464-bd1f-cdc5dc6c282a}")
        Inherit IUnknown
     
        Method Add( obj As iMessage )
          Local i As Long
          Local ub As Long
     
          If IsFalse IsInterface( obj, iMessage ) Then Exit Method
          If IsWindow( obj.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( obj.HWnd, %GWL_USERDATA, i )
          If i=cnt_ Then Incr cnt_
        End Method
     
        Method Remove( obj As iMessage )
          Local idx As Long
          If IsFalse IsInterface( obj, iMessage ) Then Exit Method
          idx = GetWindowLong( obj.HWnd, %GWL_USERDATA )
          If idx>=0 And idx<cnt_ Then objs_(idx) = Nothing
        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
     
    Global gbrTrack As iMessageTrack
     
    Function NewMessageBridge(bridgeTo As iMessage) Common Export As iMessageBridge
      Local obj As iMessageBridge
      obj = Class "cMessageBridge"
      obj.SetBridge( bridgeTo )
      Function = obj
    End Function
     
    Class cMessageBridge Guid$("{4c07094b-1bea-4150-85ce-273934df9e22}") Common
      Instance bridgeTo_ As iMessage
      Instance defProc As Dword
     
      Class Method Create()
        ' Ensure class tracking conversion from functions to classes exists
        If IsFalse IsInterface( gbrTrack, iMessageTrack ) Then gbrTrack = NewMessageTrack()
      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
     
        Method SetBridge( bridgeTo As iMessage )
          Local bridge As iMessage
          Local mb As iMessageBridge
     
          mb = Me
     
          Call mb.ClearBridge()
     
          If IsFalse IsInterface( bridgeTo, iMessage ) Then Exit Method
     
          ' Sub-class if window didn't use our control proc
          defproc = GetWindowLong( bridgeTo.HWnd, %GWL_WNDPROC)
          If defproc <> CodePtr(Bridge_ControlProc) Then
             SetWindowLong(bridgeTo.HWnd, %GWL_WNDPROC, CodePtr(Bridge_ControlProc) )
          End If
     
          bridgeTo_ = bridgeTo
          bridge = Me
          gbrTrack.Add( bridge )
        End Method
        Method ClearBridge()
          Local bridge As iMessage
     
          ' Reverse subclassing
          If IsInterface( bridgeTo_, iMessage ) Then
            If defproc And defproc <> CodePtr( Bridge_ControlProc ) Then
               SetWindowLong(bridgeTo_.HWnd, %GWL_WNDPROC, defProc )
            End If
     
            bridge = Me
            gbrTrack.Remove( bridge )
            bridgeTo_ = Nothing
          End If
        End Method
      End Interface
     
      ' Process messages
      Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        Inherit IUnknown
     
        Property Get HWnd() As Long
          Property = bridgeTo_.HWnd
        End Property
        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, bridgeTo_.HWnd, wMsg, wParam, lParam )
              Else
                ret = DefWindowProc( bridgeTo_.HWnd, wMsg, wParam, lParam )
              End If
              Method = -1
            End If
          End If
        End Method
      End Interface
    End Class
     
    '==============================================================
    ' Bridge to class
    '==============================================================
    Function Bridge_ControlProc_Address() Export Common As Dword
      Function = CodePtr( Bridge_ControlProc )
    End Function
     
    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 IsObject( gbrTrack ) Then Exit Function
      obj = gbrTrack.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

    Here's an example class that uses the above classes to deliver messages.
    ChildWindow.inc
    Code:
    Class cChildWindow Guid$("{a48a64eb-d92d-479a-ab26-f37a0153e1c5}") Common
      Instance hWnd_ As Dword:            ' Handle to window
      Instance bridge_ As iMessageBridge: ' Message bridge
     
      Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
        Inherit IUnknown
     
        Property Get HWnd() As Long
          Property = hWnd_: ' Return window handle
        End Property
     
        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", Chr$(wparam))>0 Then Exit Method: ' Suppress numeric entry, ret=0 EXAMPLE
          End Select
          Method = 0: ' If we exit this way, we didn't handle message
        End Method
      End Interface
     
      Interface iChildWindow Guid$("{6856addd-9a21-440b-b360-4337b4cf182a}")
        Inherit IUnknown
        Method SetWindow( 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
     
          hWnd_ = Me.CreateChildWindow( hParent, l, t, w, h ): ' Implementation Specific
          vmsg = Me
          bridge_ = NewMessageBridge( vmsg ): ' hWnd needs to be valid before this is called
        End Method
      End Interface
     
      ' ========================================================
      ' From here down is implementation specific stuff
      Class Method CreateChildWindow( hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) As Dword
        Static childId_ As Long
        Local vStyle As Dword
     
        ' Get the next sequential child id
        childId_ = Min( 1000, (childId_ + 1) Mod 32767 )
     
        ' Create the window
        vStyle = %WS_TabStop Or %WS_Border Or %WS_Child Or %WS_Visible
        Method = CreateWindowEx( 0, "EDIT", "Sample1", vStyle, l, t, w, h, hParent, childId_, GetModuleHandle( ByVal 0 ), ByVal 0 )
      End Method
    End Class
     
    Function NewChildWindow( hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) Common Export As iChildWindow
      Local obj As iChildWindow
      obj = Class "cChildWindow"
      obj.SetWindow( hParent, l, t, w, h )
      Function = obj
    End Function
    And here's a sample app that shows using both a standard window and class based message handling.
    TestBridge.bas
    Code:
    #Compile Exe "TestBridge.exe"
    #Dim All
    #Compiler PBWin 10.03
    #Register All
     
    %INCLUDE=1
    #Include Once "win32api.inc"
    #If %Def( %INCLUDE )
    #Include "Message.bas"
    #Else
    #Link "Message.sll"
    #EndIf
     
    #Include "ChildWindow.inc"
     
    $TESTBRIDGE_CLASS = "lcTestBridge"
     
    Function PBMain () As Long
      Local hTestBridge As Dword
      Local hChild As iChildWindow
      Local vStyle As Dword
     
      hTestBridge = TestBridge_CreateWindow()
     
      ' Class processing (no numeric input)
      hChild = NewChildWindow( hTestBridge, 10, 10, 100, 23 )
     
      ' Standard Edit BOX
      vStyle = %WS_TabStop Or %WS_Border Or %WS_Child Or %WS_Visible
      CreateWindowEx( 0, "EDIT", "Sample2", vStyle, 10, 43, 100, 23, hTestBridge, 101, GetModuleHandle( ByVal 0 ), ByVal 0 )
     
      ShowWindow( hTestBridge, %SW_ShowNormal )
      UpdateWindow( hTestBridge )
     
      Call TestBridge_Run( hTestBridge )
    End Function
     
    Function TestBridge_WndProc( ByVal hTestBridge As Dword, ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long) As Long
      Function = 0
      Select Case As Const wMsg
        Case %WM_Activate:        Function = TestBridge_OnActivate( hTestBridge, wParam ): Exit Function
        Case %WM_SysColorChange:  Call TestBridge_OnSysColorChange( hTestBridge )
        Case %WM_EraseBkgnd:      Exit Function
        Case %WM_Destroy:         PostQuitMessage( 0 ): Exit Function
      End Select
      Function = DefWindowProc( hTestBridge, wMsg, wParam, lParam )
    End Function
     
    Function TestBridge_OnActivate( ByVal hTest As Dword, ByVal wParam As Long ) As Long
      Call SetAppActiveWindow( IIf&(wParam, hTest, 0 ) )
      Function = %MA_ACTIVATE
    End Function
     
    Sub TestBridge_OnSysColorChange( ByVal hTestBridge As Dword )
      Call EnumChildWindows( hTestBridge,  CodePtr( TestBridge_SysColorChange ), 0 ): ' Ensure child controls know of change
    End Sub
     
    Function TestBridge_SysColorChange( ByVal hWnd As Dword, ByVal lParam As Long ) As Long
      SendMessage( hWnd, %WM_SYSCOLORCHANGE, 0, 0 )
      Function = %TRUE: ' Continue enumeration
    End Function
     
    Sub TestBridge_RegisterClasses()
      Local wc As WNDCLASSEX
      Local className As StringZ*20
      Static gInit As Long
     
      If gInit Then Exit Sub: ' Already registered
      gInit = -1
      If GetClassInfoEx(%NULL, $TESTBRIDGE_CLASS, wc) Then Exit Sub: ' Already registered (another app)
     
      ' Register class for Overlapped window
      className = $TESTBRIDGE_CLASS
      wc.cbsize = SizeOf(wc)
      wc.style = %CS_HREDRAW Or %CS_VREDRAW
      wc.lpfnWndProc = CodePtr( TestBridge_WndProc )
      wc.cbClsExtra = 0
      wc.cbWndExtra = 0: ' No window data
      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
      wc.lpszMenuName =  0
      wc.lpszClassName = VarPtr(className)
      If RegisterClassEx( wc )=0 Then
        MsgBox "RegisterClass for TestBridge failed"
        End
      End If
    End Sub
     
    Function TestBridge_CreateWindow() Common As Dword
      Local hTestBridge As Dword
     
      Call TestBridge_RegisterClasses()
      hTestBridge = CreateWindowEx( 0, $TESTBRIDGE_CLASS, "Test Bridge", %WS_OverlappedWindow Or %WS_ClipChildren, %CW_USEDEFAULT, %CW_USEDEFAULT, %CW_USEDEFAULT, %CW_USEDEFAULT, %NULL, %NULL, GetModuleHandle( ByVal 0 ), ByVal 0 )
      Function = hTestBridge
    End Function
     
    Global hawnd As Dword
    Sub SetAppActiveWindow( ByVal hWnd As Dword )
      hawnd = hWnd
    End Sub
     
    Function TestBridge_Run(ByVal hTestBridge As Long) As Long
      Local msg As tagMSG
     
      Do While GetMessage( msg, %NULL, 0, 0 )>0
        If hawnd=0 Or IsDialogMessage( hawnd, msg ) = 0 Then
            TranslateMessage( msg )
            DispatchMessage( msg )
        End If
      Loop
    End Function
    You can get a zip file here.
    LarryC
    Website
    Sometimes life's a dream, sometimes it's a scream
Working...
X