Windows message bridge to classes

[Larry Charlton]

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

#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

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

#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.