Problem with EventType() function

[akj]

I have recently returned to writing PB code after a break of 6 years, so I am now very forgetful of coding details, but have managed to satisfactorily complete a couple of test/exercise programs.
My third test program will focus on binding events to windows and gadgets. But I have hit a problem with the use of the EventType() function.

The code below is from the help file for BindGadgetEvent() except that I have added a second Debug line.

Code: Select all

Procedure ButtonHandler()
    Debug "Button click event on gadget #" + EventGadget()
    Debug "  Event type = "+EventType() ; Added by me
  EndProcedure
  
  OpenWindow(0, 100, 100, 200, 90, "Click test", #PB_Window_SystemMenu)
  
  ButtonGadget(0, 10, 10, 180, 30, "Click me")
  BindGadgetEvent(0, @ButtonHandler())
  
  ButtonGadget(1, 10, 50, 180, 30, "Click me")
  BindGadgetEvent(1, @ButtonHandler())
  
  Repeat
    Event = WaitWindowEvent()
  Until Event = #PB_Event_CloseWindow

I am intending to expand the second Debug line to check whether a button gadget was left-clicked or right-clicked or double-clicked but currently it only works for left-clicking. Is there a simple way to do this within the ButtonHandler() procedure?

[infratec]

A Button in PB generates only one event. You can not check an eventtype.
If you really need this, you can build a button with a canvasgadget.

Or ... use API stuff

[Mijikai]

I recently created an request for this to be possible in PB
Mouse and Keybord support is incomplete.

[mk-soft]

Only Windows ...

Code: Select all

;-TOP

; Comment : Module SetGadgetCallback (Windows Only)
; Author  : mk-soft
; Version : v0.03
; Created : 10.06.2018
; Updated : 16.02.2020
; 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) 
  Declare CallGadgetProc(hWnd, uMsg, wParam, lParam)
  
EndDeclareModule

Module GadgetCallback
  
  EnableExplicit
  
  ; ---------------------------------------------------------------------------
  
  Procedure SetGadgetCallback(Gadget, *lpNewFunc)
    Protected hWnd, *lpPrevFunc
    
    hWnd = GadgetID(Gadget)
    *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

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

;-TOP Main

UseModule GadgetCallback

Procedure ButtonProc(hWnd,uMsg,wParam,lParam)
  Select uMsg
    Case #WM_LBUTTONDBLCLK
      PostEvent(#PB_Event_Gadget, GetActiveWindow(), GetProp_(hWnd, "pb_id"), #PB_EventType_LeftDoubleClick)
    Case #WM_RBUTTONDOWN
      PostEvent(#PB_Event_Gadget, GetActiveWindow(), GetProp_(hWnd, "pb_id"), #PB_EventType_RightClick)
    Case #WM_RBUTTONDBLCLK
      PostEvent(#PB_Event_Gadget, GetActiveWindow(), GetProp_(hWnd, "pb_id"), #PB_EventType_RightDoubleClick)
  EndSelect
  ProcedureReturn CallGadgetProc(hWnd,uMsg,wParam,lParam)
EndProcedure

; ----

Procedure DoButtonEvent()
  Select EventType()
    Case #PB_EventType_LeftClick
      Debug "Button Left Click ID " + EventGadget()
      
    Case #PB_EventType_LeftDoubleClick
      Debug "Button Left Double Click ID " + EventGadget()
      
    Case #PB_EventType_RightClick
      Debug "Button Right Click ID " + EventGadget()
      
    Case #PB_EventType_RightDoubleClick
      Debug "Button Right Double Click ID " + EventGadget()
    
  EndSelect
EndProcedure

; ----

Procedure UpdateWindow()
  Protected dx, dy
  dx = WindowWidth(0)
  dy = WindowHeight(0) - StatusBarHeight(0) - MenuHeight()
  ; Resize Gadgets
EndProcedure

Procedure Main()
  Protected dx, dy
  
  #WinStyle = #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MaximizeGadget | #PB_Window_MinimizeGadget
  
  If OpenWindow(0, #PB_Ignore, #PB_Ignore, 600, 400, "Test Window", #WinStyle)
    ; MenuBar
    CreateMenu(0, WindowID(0))
    MenuTitle("&File")
    MenuItem(99, "E&xit")
    
    ; StatusBar
    CreateStatusBar(0, WindowID(0))
    AddStatusBarField(#PB_Ignore)
    
    ; Gadgets
    dx = WindowWidth(0)
    dy = WindowHeight(0) - StatusBarHeight(0) - MenuHeight()
    ButtonGadget(0, 10, 10, 120, 25, "Ok")
    ButtonGadget(1, 150, 10, 120, 25, "Cancel")
    
    SetGadgetCallback(0, @ButtonProc())
    SetGadgetCallback(1, @ButtonProc())
    
    ; Bind Events
    BindEvent(#PB_Event_SizeWindow, @UpdateWindow(), 0)
    
    BindGadgetEvent(0, @DoButtonEvent())
    BindGadgetEvent(1, @DoButtonEvent())
    
    ; Main Loop
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          Select EventWindow()
            Case 0
              Break
          EndSelect
          
        Case #PB_Event_Menu
          Select EventMenu()
            Case 99
              PostEvent(#PB_Event_CloseWindow, 0, 0)
              
          EndSelect
          
        Case #PB_Event_Gadget
          Select EventGadget()
              
          EndSelect
          
      EndSelect
    ForEver
    
  EndIf
  
EndProcedure : Main()

[akj]

Hi mk-soft,

Thank you for your SetGadgetCallback module which I will have a good look at.

I'm surprised the code is so lengthy for such a basic facility.

akj

[Axolotl]

this alternative way of doing the subclass maybe interesting as well.

Code: Select all

EnableExplicit 
; Forum Link: https://www.purebasic.fr/english/viewtopic.php?t=81714 

Import "Comctl32.lib" 
  ; use the PureBasic Syntax (Windows API procedures using trailing underscore) 
  ; 
  CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
    SetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, dwRefData)  As "SetWindowSubclass" 
    GetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, *dwRefData) As "GetWindowSubclass"
    RemoveWindowSubclass_(hWnd, *fnSubclass, uIdSubclass)          As "RemoveWindowSubclass"
    DefSubclassProc_(hWnd, uMsg, wParam, lParam)                   As "DefSubclassProc"
  CompilerElse
    SetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, dwRefData)  As "_SetWindowSubclass@16" 
    GetWindowSubclass_(hWnd, *fnSubclass, uIdSubclass, *dwRefData) As "_GetWindowSubclass@16"
    RemoveWindowSubclass_(hWnd, *fnSubclass, uIdSubclass)          As "_RemoveWindowSubclass@12"
    DefSubclassProc_(hWnd, uMsg, wParam, lParam)                   As "_DefSubclassProc@16" 
  CompilerEndIf
EndImport


Enumeration EWindow 
  #WND_Main 
EndEnumeration 

Enumeration EGadget 
EndEnumeration 


; ---------------------------------------------------------------------------------------------------------------------

Macro WMDebug(Message) 
  Debug "  " + 
        #PB_Compiler_Procedure + "()    " + 
        LSet(Message, 20) + 
        RSet(Str(uIdSubclass), 4) + 
        RSet(Str(dwRefData), 6)  
EndMacro 


; --- first subclass procedure --- 
; 
Procedure SubclassWindowProc1(hWnd, uMsg, wParam, lParam, uIdSubclass, dwRefData) 
  Select uMsg 
    Case #WM_NCDESTROY                                                         : WMDebug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc1(), uIdSubclass)  

    Case #WM_LBUTTONDOWN                                                       : WMDebug("WM_LBUTTONDOWN") 
    Case #WM_RBUTTONDOWN                                                       : WMDebug("WM_RBUTTONDOWN") 

  EndSelect 
  ProcedureReturn DefSubclassProc_(hWnd, uMsg, wParam, lParam) 
EndProcedure

; --- second subclass procedure --- 
; 
Procedure SubclassWindowProc2(hWnd, uMsg, wParam, lParam, uIdSubclass, dwRefData) 
  Select uMsg 
    Case #WM_NCDESTROY                                                         : WMDebug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc2(), uIdSubclass)  

    Case #WM_LBUTTONDOWN                                                       : WMDebug("WM_LBUTTONDOWN") 
    Case #WM_RBUTTONDOWN                                                       : WMDebug("WM_RBUTTONDOWN") 

  EndSelect 
  ProcedureReturn DefSubclassProc_(hWnd, uMsg, wParam, lParam) 
EndProcedure

; --- third subclass procedure --- 
; 
Procedure SubclassWindowProc3(hWnd, uMsg, wParam, lParam, uIdSubclass, dwRefData) 
  Select uMsg 
    Case #WM_NCDESTROY                                                         : WMDebug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc3(), uIdSubclass)  

    Case #WM_LBUTTONDOWN                                                       : WMDebug("WM_LBUTTONDOWN") 
    Case #WM_RBUTTONDOWN                                                       : WMDebug("WM_RBUTTONDOWN") 

  EndSelect 
  ProcedureReturn DefSubclassProc_(hWnd, uMsg, wParam, lParam) 
EndProcedure


; --- main procedure --- 
; 
Procedure Main() 
  Protected hwndMain, RefData   ; for testing  


  If OpenWindow(#WND_Main, 0, 0, 320, 240, "Click on window (left or right mouse button) ... ", #PB_Window_ScreenCentered|#PB_Window_SystemMenu) 
    StickyWindow(#WND_Main, 1) ; always on top :) 

    ; No Gadgets 
    
    hwndMain = WindowID(#WND_Main)

    ; Window Subclass -> different procedure names, same uIdSubclass -> unique  
    SetWindowSubclass_(hwndMain, @SubclassWindowProc1(), 1, 101)  ; 
    SetWindowSubclass_(hwndMain, @SubclassWindowProc2(), 1, 102)  ; removed early by app 
    SetWindowSubclass_(hwndMain, @SubclassWindowProc3(), 1, 103)  ; 

    ; Window Subclass -> same procedure name, different uIdSubclass -> unique 
    SetWindowSubclass_(hwndMain, @SubclassWindowProc3(), 2, 104)  ; 
    SetWindowSubclass_(hwndMain, @SubclassWindowProc3(), 3, 105)  ; removed early by app 
    SetWindowSubclass_(hwndMain, @SubclassWindowProc3(), 4, 106)  ; 

    ; remove any proc from chain 
    If GetWindowSubclass_(hwndMain, @SubclassWindowProc2(), 1, @RefData)  ; we can get the RefData  
      Debug "Remove SubclassWindowProc2() with " + RefData + " -> " + RemoveWindowSubclass_(hwndMain, @SubclassWindowProc2(), 1)  
    EndIf 

    ; remove any proc from chain 
    If GetWindowSubclass_(hwndMain, @SubclassWindowProc3(), 3, @RefData)  ; we can get the RefData  
      Debug "Remove SubclassWindowProc3() with " + RefData + " -> " + RemoveWindowSubclass_(hwndMain, @SubclassWindowProc3(), 3)  
    EndIf 

    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow 
          Break ; say good bye. 
      EndSelect
    ForEver
  EndIf 
EndProcedure 

End Main()