Problem with new version PB6.02

[Lord]

How must the following code be changed to work again with the new PB v6.02 (both back ends)?

Code: Select all

EnableExplicit

Define hBrushG = CreateSolidBrush_(RGB(0, 255, 0))
Define hBrushR = CreateSolidBrush_(RGB(255, 0, 0))
Define Event

Procedure Callback(hWnd, uMsg, wParam, lParam)
  Shared hBrushG, hBrushR
  Select uMsg
    Case #WM_CTLCOLORBTN
      Select lParam
        Case GadgetID(1)
          ProcedureReturn hBrushG
        Case GadgetID(2)
          ProcedureReturn hBrushR
      EndSelect
  EndSelect
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure


If OpenWindow(0, 10, 10, 320, 200, "Window", #PB_Window_SystemMenu)
  ContainerGadget(0, 0, 0, 320, 200)
  ButtonGadget(1, 10, 10, 100, 20, "Button 1")
  ButtonGadget(2, 10, 40, 100, 20, "Button 2")
  CloseGadgetList()
  SetWindowCallback(@Callback(), 0)
  
  Repeat
    Event=WaitWindowEvent()
    Select Event
      Case #PB_Event_CloseWindow
        Break
    EndSelect
  ForEver
EndIf
DeleteObject_(hBrushG)
DeleteObject_(hBrushR)

[Axolotl]

may be this can help

Code: Select all

 
EnableExplicit

Global ContainerGadget_PrevFunc = 0   ; keep the original function pointer 


Define hBrushG = CreateSolidBrush_(RGB(0, 255, 0))
Define hBrushR = CreateSolidBrush_(RGB(255, 0, 0))
Define Event

Procedure Callback(hWnd, uMsg, wParam, lParam)
  Shared hBrushG, hBrushR
  Select uMsg
    Case #WM_CTLCOLORBTN
      Select lParam
        Case GadgetID(1)
          ProcedureReturn hBrushG
        Case GadgetID(2)
          ProcedureReturn hBrushR
      EndSelect
  EndSelect
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

; new subclass function of the container ... 
Procedure ContainerGadget_Callback(hWnd, uMsg, wParam, lParam) 
  Shared hBrushG, hBrushR
  Select uMsg 
    Case #WM_CTLCOLORBTN
      Select lParam
        Case GadgetID(1)
          ProcedureReturn hBrushG
        Case GadgetID(2)
          ProcedureReturn hBrushR
      EndSelect

  EndSelect 

  ProcedureReturn CallWindowProc_(ContainerGadget_PrevFunc, hWnd, uMsg, wParam, lParam) 
EndProcedure



If OpenWindow(0, 10, 10, 320, 200, "Window", #PB_Window_SystemMenu | #PB_Window_ScreenCentered) 
  StickyWindow(0, 1) 

  ContainerGadget(0, 0, 0, 320, 200)
  ButtonGadget(1, 10, 10, 100, 20, "Button 1")
  ButtonGadget(2, 10, 40, 100, 20, "Button 2")
  CloseGadgetList()


  ; set the callback for the gadget 
  ContainerGadget_PrevFunc = SetWindowLongPtr_(GadgetID(0), #GWL_WNDPROC, @ContainerGadget_Callback()) 

  SetWindowCallback(@Callback(), 0)

  
  Repeat
    Event=WaitWindowEvent()
    Select Event
      Case #PB_Event_CloseWindow
        Break
      Case #PB_Event_Gadget 
        Debug "you clicked on Button " + EventGadget() 
    EndSelect 
  ForEver
EndIf
DeleteObject_(hBrushG)
DeleteObject_(hBrushR)
[/code-purebasic]

[mk-soft]

The same as here: viewtopic.php?t=81681

The events no longer all arrive at the main window, but at the gadget control or, depending on the events, at the parent control

Update

Code: Select all

;-TOP

; Comment : Module SetGadgetCallback (Windows Only)
; Author  : mk-soft
; Version : v0.03
; Created : 10.06.2018
; Updated : 22.05.2023
; Link    : https://www.purebasic.fr/english/viewtopic.php?f=12&t=70842
;
; 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
    
    *lpPrevFunc = GetProp_(hWnd, "PB_PrevFunc")
    If *lpPrevFunc
      result = CallWindowProc_(*lpPrevFunc, hWnd, uMsg, wParam, lParam)
    EndIf
    ProcedureReturn result
  EndProcedure
EndModule

; *****************************************************************************


EnableExplicit

UseModule GadgetCallback

Define hBrushG = CreateSolidBrush_(RGB(0, 255, 0))
Define hBrushR = CreateSolidBrush_(RGB(255, 0, 0))
Define hBrushB = CreateSolidBrush_(RGB(0, 0, 255))

Define Event

Procedure GadgetCallback(hWnd, uMsg, wParam, lParam)
  Shared hBrushG, hBrushR, hBrushB
  Select uMsg
    Case #WM_CTLCOLORBTN
      Select lParam
        Case GadgetID(1)
          Debug "Gadget 1"
          ProcedureReturn hBrushG
        Case GadgetID(2)
          Debug "Gadget 2"
          ProcedureReturn hBrushR
        Case GadgetID(3)
          Debug "Gadget 3"
          ProcedureReturn hBrushB
      EndSelect
  EndSelect
  ProcedureReturn CallGadgetProc(hWnd,uMsg,wParam,lParam)
EndProcedure


If OpenWindow(0, 10, 10, 320, 200, "Window", #PB_Window_SystemMenu)
  ContainerGadget(0, 0, 0, 320, 150)
  ButtonGadget(1, 10, 10, 100, 20, "Button 1")
  ButtonGadget(2, 10, 40, 100, 20, "Button 2")
  CloseGadgetList()
  ButtonGadget(3, 10, 160, 100, 20, "Button 3")
  
  ; SetGadgetCallback(1, @GadgetCallback(), #True) ; Parent is Container
  ; SetGadgetCallback(2, @GadgetCallback(), #True) ; Not needed. Parent callback always set
  
  SetGadgetCallback(0, @GadgetCallback()) ; Container
  SetGadgetCallback(3, @GadgetCallback(), #True) ; Parent is Window
  
  Repeat
    Event=WaitWindowEvent()
    Select Event
      Case #PB_Event_CloseWindow
        Break
      Case #PB_Event_Gadget
        Select EventGadget()
          Case 1
            Debug "Click Button 1"
          Case 2
            Debug "Click Button 2"
          Case 3
            Debug "Click Button 3"
        EndSelect
        
    EndSelect
  ForEver
EndIf
DeleteObject_(hBrushG)
DeleteObject_(hBrushR)
DeleteObject_(hBrushB)

[Axolotl]

I extended your code a little.
in the debug window you can see, that the different callbacks are used depending on in or outside a ContainerGadget()

Code: Select all

Debug #PB_Compiler_Version  

EnableExplicit

Global ContainerGadget_PrevFunc = 0   ; keep the original function pointer 

Define hBrushG = CreateSolidBrush_(RGB(0, 255, 0))
Define hBrushR = CreateSolidBrush_(RGB(255, 0, 0))
Define hBrushB = CreateSolidBrush_(RGB(0, 0, 255))  ; new color 
Define Event


Procedure OnMessage_CTLCOLORBTN(hwndButton) 
  Shared hBrushG, hBrushR, hBrushB 

  Select hwndButton 
    Case GadgetID(1)
      ProcedureReturn hBrushG 
    Case GadgetID(2) 
      ProcedureReturn hBrushR 
    Case GadgetID(3)   ; added Button 3 
      ProcedureReturn hBrushB 
  EndSelect
  ProcedureReturn #False 
EndProcedure 


Procedure Callback(hWnd, uMsg, wParam, lParam)
  Shared hBrushG, hBrushR, hBrushB 
  Protected result 

  Select uMsg
    Case #WM_NCDESTROY                          :Debug "WM_NCDESTROY" 
      DeleteObject_(hBrushG)
      DeleteObject_(hBrushR)
      DeleteObject_(hBrushB)

    Case #WM_CTLCOLORBTN                        :Debug "WM_CTLCOLORBTN (window)" 
      result = OnMessage_CTLCOLORBTN(lParam) 
      If result 
        ProcedureReturn result 
      EndIf 
  EndSelect
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

; new subclass function of the container ... 
Procedure ContainerGadget_Callback(hWnd, uMsg, wParam, lParam) 
  Protected result 

  Select uMsg 
    Case #WM_CTLCOLORBTN                        :Debug "WM_CTLCOLORBTN (container)" 
      result = OnMessage_CTLCOLORBTN(lParam) 
      If result 
        ProcedureReturn result 
      EndIf 
  EndSelect 

  ProcedureReturn CallWindowProc_(ContainerGadget_PrevFunc, hWnd, uMsg, wParam, lParam) 
EndProcedure

If OpenWindow(0, 10, 10, 320, 240, "Window", #PB_Window_SystemMenu | #PB_Window_ScreenCentered) 
  StickyWindow(0, 1) 

  ContainerGadget(0, 0, 0, 320, 200)
  ButtonGadget(1, 10, 10, 100, 20, "Button 1")
  ButtonGadget(2, 10, 40, 100, 20, "Button 2")
  CloseGadgetList()

  ButtonGadget(3, 10, 210, 160, 20, "Button 3 (outside)") 

CompilerIf #PB_Compiler_Version > 600 And #PB_Compiler_Version < 603  ; this is an educational guess    	
  ; set the callback for the gadget 
  ContainerGadget_PrevFunc = SetWindowLongPtr_(GadgetID(0), #GWL_WNDPROC, @ContainerGadget_Callback()) 
CompilerEndIf 

  SetWindowCallback(@Callback(), 0)

  
  Repeat
    Event=WaitWindowEvent()
    Select Event
      Case #PB_Event_CloseWindow
        Break
      Case #PB_Event_Gadget 
        Debug "you clicked on Button " + EventGadget() 
    EndSelect 
  ForEver
EndIf

Happy coding and stay healthy.

[mk-soft]

Update my example!

Also works with my example with option Parent. (Without SetWindowCallback).
You only have to know that a previously set callback may be overwritten.

[Lord]

Hi!

Thanks to all for helping.
I adapted this modul by mk-soft to my needs.

[Axolotl]

good news, problem is fixed with new PB6.03 (beta)
I updated my code above.