Tweet
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