Would be nice if Purebasic supported this directly.
Update v0.03
- Remove NewMap and Mutex
- Change to gadget properties
Update v0.04
- Added option to set the callback to the parent control. A callback that has already been set is replaced!
Update v0.05.1
- Fix: Remove property at destroy
Important notice.
The parent option of SetGadgetCallback replaces the previously directly set gadgdet callback from the parent gadget or parent window.
For example, from a directly set container gadget callback from a set client gadget callback with parent option.
Code: Select all
;-TOP
; Comment : Module SetGadgetCallback (Windows Only)
; Author : mk-soft
; Version : v0.05.2
; Created : 10.06.2018
; Updated : 26.05.2023
; Link : https://www.purebasic.fr/english/viewtopic.php?f=12&t=70842
;
; Description
; - A callback that has already been set is replaced by the new callback!
;
; - Syntax Callback:
; Procedure GadgetCB(hWnd,uMsg,wParam,lParam)
; Select uMsg
; ;TODO
; EndSelect
; ; Call previous gadget procedure
; ProcedureReturn CallGadgetProc(hWnd,uMsg,wParam,lParam)
; EndProcedure
;
; *****************************************************************************
DeclareModule GadgetCallback
Declare SetGadgetCallback(Gadget, *lpNewFunc, Parent = #False)
Declare CallGadgetProc(hWnd, uMsg, wParam, lParam)
EndDeclareModule
Module GadgetCallback
EnableExplicit
; ---------------------------------------------------------------------------
Procedure SetGadgetCallback(Gadget, *lpNewFunc, Parent = #False)
Protected hWnd, *lpPrevFunc
hWnd = GadgetID(Gadget)
If Parent
hwnd = GetParent_(hwnd)
EndIf
*lpPrevFunc = GetProp_(hWnd, "PB_PrevFunc")
; Remove exists Callback
If *lpPrevFunc
SetWindowLongPtr_(hWnd, #GWL_WNDPROC, *lpPrevFunc)
RemoveProp_(hWnd, "PB_PrevFunc")
EndIf
; Set new Callback
If *lpNewFunc
*lpPrevFunc = SetWindowLongPtr_(hWnd, #GWL_WNDPROC, *lpNewFunc)
SetProp_(hWnd, "PB_PrevFunc", *lpPrevFunc)
ProcedureReturn *lpPrevFunc
EndIf
ProcedureReturn 0
EndProcedure
; ---------------------------------------------------------------------------
Procedure CallGadgetProc(hWnd, uMsg, wParam, lParam)
Protected result, *lpPrevFunc
If uMsg = #WM_NCDESTROY
*lpPrevFunc = RemoveProp_(hWnd, "PB_PrevFunc")
Else
*lpPrevFunc = GetProp_(hWnd, "PB_PrevFunc")
EndIf
If *lpPrevFunc
result = CallWindowProc_(*lpPrevFunc, hWnd, uMsg, wParam, lParam)
EndIf
ProcedureReturn result
EndProcedure
EndModule
; *****************************************************************************
CompilerIf #PB_Compiler_IsMainFile
;- Example
EnableExplicit
UseModule GadgetCallback
Define hBrushG = CreateSolidBrush_(RGB(0, 255, 0))
Define hBrushR = CreateSolidBrush_(RGB(255, 0, 0))
Define hBrushB = CreateSolidBrush_(RGB(0, 0, 255))
; ----
Procedure GadgetColorCallback(hWnd, uMsg, wParam, lParam)
Shared hBrushG, hBrushR, hBrushB
Select uMsg
Case #WM_CTLCOLORBTN
;Debug GetDlgCtrlID_(lParam)
Select lParam
Case GadgetID(1)
ProcedureReturn hBrushG
Case GadgetID(2)
ProcedureReturn hBrushR
Case GadgetID(4)
ProcedureReturn hBrushB
Case GadgetID(5)
ProcedureReturn hBrushR
EndSelect
EndSelect
ProcedureReturn CallGadgetProc(hWnd,uMsg,wParam,lParam)
EndProcedure
; ----
Procedure GadgetMouseCallback(hWnd, uMsg, wParam, lParam)
Protected Gadget
Select uMsg
Case #WM_RBUTTONUP
Gadget = GetProp_(hwnd, "PB_ID")
PostEvent(#PB_Event_Gadget, GetActiveWindow(), Gadget, #PB_EventType_RightClick)
EndSelect
ProcedureReturn CallGadgetProc(hWnd,uMsg,wParam,lParam)
EndProcedure
; ----
Procedure Main()
If OpenWindow(0, 10, 10, 320, 200, "Window", #PB_Window_SystemMenu)
PanelGadget(0, 0, 0, 320, 100)
AddGadgetItem (0, -1, "Panel 1")
ButtonGadget(1, 5, 10, 100, 20, "Button 1")
AddGadgetItem (0, -1, "Panel 2")
ButtonGadget(2, 5, 10, 100, 20, "Button 2")
CloseGadgetList()
ContainerGadget(3, 5, 110, 310, 40, #PB_Container_Single)
ButtonGadget(4, 5, 10, 100, 20, "Button 4")
CloseGadgetList()
ButtonGadget(5, 10, 160, 100, 20, "Button 5")
; MSDN: Some message is sent to the parent window
SetGadgetCallback(1, @GadgetColorCallback(), #True) ; Parent is Item 1 from PanelGadget
SetGadgetCallback(2, @GadgetColorCallback(), #True) ; Parent is Item 2 from PanelGadget
SetGadgetCallback(3, @GadgetColorCallback()) ; Contrainer
;SetGadgetCallback(4, @GadgetColorCallback(), #True) ; Parent is Contrainer
SetGadgetCallback(5, @GadgetColorCallback(), #True) ; Parent is Window
SetGadgetCallback(1, @GadgetMouseCallback())
SetGadgetCallback(2, @GadgetMouseCallback())
SetGadgetCallback(4, @GadgetMouseCallback())
SetGadgetCallback(5, @GadgetMouseCallback())
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
Break
Case #PB_Event_Gadget
Select EventGadget()
Case 1
Select EventType()
Case #PB_EventType_LeftClick
Debug "Left Click Button 1"
Case #PB_EventType_RightClick
Debug "Right Click Button 1"
EndSelect
Case 2
Select EventType()
Case #PB_EventType_LeftClick
Debug "Left Click Button 2"
Case #PB_EventType_RightClick
Debug "Right Click Button 2"
EndSelect
Case 4
Select EventType()
Case #PB_EventType_LeftClick
Debug "Left Click Button 4"
Case #PB_EventType_RightClick
Debug "Right Click Button 4"
EndSelect
Case 5
Select EventType()
Case #PB_EventType_LeftClick
Debug "Left Click Button 5"
Case #PB_EventType_RightClick
Debug "Right Click Button 5"
EndSelect
EndSelect
EndSelect
ForEver
EndIf
EndProcedure : Main()
DeleteObject_(hBrushG)
DeleteObject_(hBrushR)
DeleteObject_(hBrushB)
CompilerEndIf
