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
Here's an example class that uses the above classes to deliver messages.
ChildWindow.inc
And here's a sample app that shows using both a standard window and class based message handling.
TestBridge.bas
You can get a zip file here.
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
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