Modular alternative for SetWindowCallback

Share your advanced PureBasic knowledge/code with the community.
Rinzwind
Enthusiast
Enthusiast
Posts: 636
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Modular alternative for SetWindowCallback

Post by Rinzwind »

Code: Select all

EnableExplicit

#MSG_CallWindowProc = #PB_ProcessPureBasicEvents
#MSG_All = -1

Prototype MessageHandler(Gadget, hwnd, msg, wp, lp)
Global NewMap Properties()

Macro SetIDProp(ID, Name, Value)
  Properties(Str(ID) + ":" + Name) = Value
EndMacro

Macro IDPropExists(ID, Name)
  FindMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Macro DeleteIDProp(ID, Name)
  DeleteMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Procedure GetIDProp(ID, Name.s)
  If FindMapElement(Properties(), Str(ID) + ":" + Name)
    ProcedureReturn Properties()
  EndIf
EndProcedure

Procedure FreeIDProp(ID)
  Protected sID.s = Str(ID) + ":"
  Protected l = Len(sID)
  ForEach Properties()
    If Left(MapKey(Properties()), l) = sID
      DeleteMapElement(Properties())
    EndIf
  Next
EndProcedure

Procedure _EventHandler(hwnd, msg, wp, lp)
  Protected gc.MessageHandler, r = #MSG_CallWindowProc, proc = GetWindowLongPtr_(hwnd, #GWL_USERDATA); = GetIDProp(hwnd, "proc")
  ;Debug "" + hwnd + #TAB$ + msg

  gc = GetIDProp(hwnd, Str(#MSG_All))
  If Not gc
    gc = GetIDProp(hwnd, Str(msg))
  EndIf
  If gc  
    r = gc(GetDlgCtrlID_(hwnd), hwnd, msg, wp, lp)
  EndIf
  If msg = #WM_DESTROY
    SetWindowLongPtr_(hwnd, #GWL_WNDPROC, proc)
    FreeIDProp(hwnd)
  EndIf
  If r = #MSG_CallWindowProc
    r = CallWindowProc_(proc, hwnd, msg, wp, lp)
  EndIf
  ProcedureReturn r
EndProcedure

Procedure BindWindowMessage(window, msg, callback.MessageHandler)
  Protected wid = WindowID(window), proc = GetWindowLongPtr_(wid, #GWL_USERDATA)
  
  ;If Not IDPropExists(wid, "proc")
  If Not proc
    proc = SetWindowLongPtr_(wid, #GWL_WNDPROC, @_EventHandler())
    SetWindowLongPtr_(wid, #GWL_USERDATA, proc)
    ;SetIDProp(wid, "proc", proc)
  EndIf
  SetIDProp(wid, msg, callback)  
EndProcedure

Procedure UnbindWindowMessage(window, msg)
  Protected wid = WindowID(window)
  
  DeleteIDProp(wid, msg)
EndProcedure

Procedure BindMessage(gadget, msg, callback.MessageHandler)
  Protected gid = GadgetID(gadget), proc = GetWindowLongPtr_(gid, #GWL_USERDATA)
  
  ;If Not IDPropExists(gid, "proc")
  If Not proc
    proc = SetWindowLongPtr_(gid, #GWL_WNDPROC, @_EventHandler())
    SetWindowLongPtr_(gid, #GWL_USERDATA, proc)
    ;SetIDProp(gid, "proc", proc)
  EndIf
  SetIDProp(gid, msg, callback)
EndProcedure

Procedure UnbindMessage(gadget, msg)
  Protected gid = GadgetID(gadget)
  
  DeleteIDProp(gid, msg)
EndProcedure

; //
; // Small demo
; //

Define e, i, c
OpenWindow(0, 0, 0, 400, 300, "Test")

ButtonGadget(0, 10, 10, 80, 40, "Test")
ButtonGadget(1, 100, 10, 80, 40, "Test2")
Procedure MyButtonMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  ;UnbindMessage(g, #WM_RBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

Procedure MyWindowMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  If IsGadget(0)
    ;FreeGadget(0)
  EndIf
  ;UnbindWindowMessage(g, #WM_LBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

;BindMessage(0, #MSG_All, @MyTest())
BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessage())
BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow
Last edited by Rinzwind on Mon Oct 25, 2021 7:45 am, edited 5 times in total.
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Modular alternative for SetWindowCallback

Post by mk-soft »

Works so well,
but FreeIDProp(ID) can randomly lead to an error. For example, ID's 1234 and 12345 would both be deleted.

Should therefore be FreeIDProp(ID, Name.s)
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
Rinzwind
Enthusiast
Enthusiast
Posts: 636
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Re: Modular alternative for SetWindowCallback

Post by Rinzwind »

Thanks, made small tweaks to first post.
I wanted to avoid ProcedureReturn #MSG_CallWindowProc from custom event handlers because that part can easily be forgotten by mistake, but I guess that's the way it is because sometimes you want to return 0 from the window proc and skip calling the prev proc.
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Modular alternative for SetWindowCallback

Post by mk-soft »

Perhaps is better to set "#MSG_CallWindowProc = -1"
It is very unwarranted that a message expects a "-1" as a result.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Modular alternative for SetWindowCallback

Post by mk-soft »

In order to avoid conflicts with the Retval, the MessageHandler would have to be adapted.
Also used a lot in API for return values.

Code: Select all

Prototype MessageHandler(Gadget, hWnd, Msg, wParam, lParam, *Retval.integer)
Send you a PM with complete code
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Modular alternative for SetWindowCallback

Post by mk-soft »

Now complete code with additional parameter Retval (ByRef)

Update 2

Code: Select all

;-TOP by mk-soft (Base from Rinzwind)

Prototype MessageCallback(ID, hWnd, Msg, wParam, lParam, *Retval.integer)

Structure udtMessageData
  ID.i
  *WindowProc
  Map *MessageCallback()
EndStructure

Global NewMap mapMessageData.udtMessageData()

Procedure DispatchMessage(hWnd, Msg, wParam, lParam)
  Protected r1, *MessageData.udtMessageData, *Callback.MessageCallback
  
  *MessageData = mapMessageData(Str(hWnd))
  If Msg = #WM_DESTROY
    SetWindowLongPtr_(hWnd, #GWL_WNDPROC, *MessageData\WindowProc)
    DeleteMapElement(mapMessageData())
  Else
    If FindMapElement(*MessageData\MessageCallback(), Str(Msg))
      *Callback = *MessageData\MessageCallback()
      If *Callback(*MessageData\ID, hWnd, Msg, wParam, lParam, @r1)
        ProcedureReturn r1
      EndIf  
    EndIf
  EndIf
  ProcedureReturn CallWindowProc_(*MessageData\WindowProc, hWnd, Msg, wParam, lParam)
EndProcedure

Procedure BindWindowMessage(Window, Msg, *Callback.MessageCallback)
  Protected hWnd = WindowID(Window)
  If Not FindMapElement(mapMessageData(), Str(hWnd))
    AddMapElement(mapMessageData(), Str(hWnd))
    mapMessageData()\WindowProc = SetWindowLongPtr_(hWnd, #GWL_WNDPROC, @DispatchMessage())
    mapMessageData()\ID = Window
  EndIf
  mapMessageData()\MessageCallback(Str(Msg)) = *Callback
EndProcedure

Procedure UnbindWindowMessage(Window, Msg)
  Protected hWnd = WindowID(Window)
  If FindMapElement(mapMessageData(), Str(hWnd))
    If Msg = #PB_All
      SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
      DeleteMapElement(mapMessageData())
    Else
      DeleteMapElement(mapMessageData()\MessageCallback(), Str(Msg))
      If MapSize(mapMessageData()\MessageCallback()) = 0
        SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
        DeleteMapElement(mapMessageData())
      EndIf
    EndIf
  EndIf
EndProcedure

Procedure BindMessage(Gadget, Msg, *Callback.MessageCallback)
  Protected hWnd = GadgetID(Gadget)
  If Not FindMapElement(mapMessageData(), Str(hWnd))
    AddMapElement(mapMessageData(), Str(hWnd))
    mapMessageData()\WindowProc = SetWindowLongPtr_(hWnd, #GWL_WNDPROC, @DispatchMessage())
    mapMessageData()\ID = Window
  EndIf
  mapMessageData()\MessageCallback(Str(Msg)) = *Callback
EndProcedure

Procedure UnbindMessage(Gadget, Msg)
  Protected hWnd = GadgetID(Gadget)
  If FindMapElement(mapMessageData(), Str(hWnd))
    If Msg = #PB_All
      SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
      DeleteMapElement(mapMessageData())
    Else
      DeleteMapElement(mapMessageData()\MessageCallback(), Str(Msg))
      If MapSize(mapMessageData()\MessageCallback()) = 0
        SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
        DeleteMapElement(mapMessageData())
      EndIf
    EndIf
  EndIf
EndProcedure

; ****

;- Example

CompilerIf #PB_Compiler_IsMainFile
  
  Define e, i, c
  OpenWindow(0, 0, 0, 400, 300, "Bind Message Example")
  ButtonGadget(0, 10, 10, 120, 40, "Click me")
  ButtonGadget(1, 140, 10, 120, 40, "Remove all")
  
  
  Procedure MyButtonMessageLeftClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button LeftClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
  EndProcedure
  
  Procedure MyButtonMessageLeftDoubleClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button DBL-Click" + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
    *Retval\i = 0
    ProcedureReturn #True
  EndProcedure
  
  Procedure MyButtonMessageRightClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button RightClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
    *Retval\i = 0
    ProcedureReturn #True
  EndProcedure
  
  Procedure MyWindowMessage(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Window LeftClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
  EndProcedure
  
  BindMessage(0, #WM_LBUTTONDOWN, @MyButtonMessageLeftClick())
  BindMessage(0, #WM_LBUTTONDBLCLK, @MyButtonMessageLeftDoubleClick())
  BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessageRightClick())
  
  BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())
  
  Repeat
    Select WaitWindowEvent()
      Case #PB_Event_CloseWindow
        Break
        
      Case #PB_Event_LeftClick
        Debug "#PB_Event_LeftClick"
        
      Case #PB_Event_Gadget
        Select EventGadget()
          Case 0
            Debug "#PB_Event_Gadget 0"
            
          Case 1
            UnbindMessage(0, #PB_All)
            UnbindWindowMessage(0, #WM_LBUTTONDOWN)
            
        EndSelect
        
    EndSelect
    
  ForEver
  
CompilerEndIf
Last edited by mk-soft on Mon Oct 25, 2021 8:03 pm, edited 1 time in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
Rinzwind
Enthusiast
Enthusiast
Posts: 636
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Re: Modular alternative for SetWindowCallback

Post by Rinzwind »

btw you can store the original windows proc instead in #GWL_USERDATA:
SetWindowLongPtr_(gid, #GWL_USERDATA, proc)
proc = GetWindowLongPtr_(hwnd, #GWL_USERDATA)

one less map lookup. Updated first post. Or even let it point to a structure that contains the proc and a simple linked list lookup per control. Probably not worth it though.
Last edited by Rinzwind on Mon Oct 25, 2021 9:09 am, edited 2 times in total.
Denis
Enthusiast
Enthusiast
Posts: 704
Joined: Fri Apr 25, 2003 5:10 pm
Location: Doubs - France

Re: Modular alternative for SetWindowCallback

Post by Denis »

perhaps the following set of functions can be used to sub-unsub/class windows instead of SetWindowLongPtr:

DefSubclassProc
GetWindowSubclass
SetWindowSubclass
RemoveWindowSubclass

Blog from Raymond Chen about these functions
https://devblogs.microsoft.com/oldnewth ... 0/?p=41883
A+
Denis
Rinzwind
Enthusiast
Enthusiast
Posts: 636
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Re: Modular alternative for SetWindowCallback

Post by Rinzwind »

Yup, possible too. Weird how old the Windows lib files are that come with PB...

Code: Select all

EnableExplicit

Global _Comctl32 = OpenLibrary(#PB_Any, "Comctl32.dll")
If _Comctl32
  Prototype SetWindowSubclass(hWnd, pfnSubclass, uIdSubclass, dwRefData)
  Prototype GetWindowSubclass(hWnd, pfnSubclass, uIdSubclass, *dwRefData)
  Prototype RemoveWindowSubclass(hWnd, pfnSubclass, uIdSubclass)
  Prototype DefSubclassProc(hWnd, uMsg, wParam, lParam)
  Global SetWindowSubclass_.SetWindowSubclass = GetFunction(_Comctl32, "SetWindowSubclass")
  Global GetWindowSubclass_.GetWindowSubclass = GetFunction(_Comctl32, "GetWindowSubclass")
  Global RemoveWindowSubclass_.RemoveWindowSubclass = GetFunction(_Comctl32, "RemoveWindowSubclass")
  Global DefSubclassProc_.DefSubclassProc = GetFunction(_Comctl32, "DefSubclassProc")  
EndIf

#MSG_CallWindowProc = #PB_ProcessPureBasicEvents
#MSG_All = -1

Prototype MessageHandler(Gadget, hwnd, msg, wp, lp)
Global NewMap Properties()

Macro SetIDProp(ID, Name, Value)
  Properties(Str(ID) + ":" + Name) = Value
EndMacro

Macro IDPropExists(ID, Name)
  FindMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Macro DeleteIDProp(ID, Name)
  DeleteMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Procedure GetIDProp(ID, Name.s)
  If FindMapElement(Properties(), Str(ID) + ":" + Name)
    ProcedureReturn Properties()
  EndIf
EndProcedure

Procedure FreeIDProp(ID)
  Protected sID.s = Str(ID) + ":"
  Protected l = Len(sID)
  ForEach Properties()
    If Left(MapKey(Properties()), l) = sID
      DeleteMapElement(Properties())
    EndIf
  Next
EndProcedure

Procedure _EventHandler(hwnd, msg, wp, lp, uIdSubclass, dwRefData)
  Protected gc.MessageHandler, r = #MSG_CallWindowProc
  ;Debug "" + hwnd + #TAB$ + msg

  gc = GetIDProp(hwnd, Str(#MSG_All))
  If Not gc
    gc = GetIDProp(hwnd, Str(msg))
  EndIf
  If gc  
    r = gc(GetDlgCtrlID_(hwnd), hwnd, msg, wp, lp)
  EndIf
  If r = #MSG_CallWindowProc
    r = DefSubclassProc_(hwnd, msg, wp, lp)
  EndIf
  If msg = #WM_DESTROY
    RemoveWindowSubclass_(hwnd, @_EventHandler(), 0)
    FreeIDProp(hwnd)
  EndIf  
  ProcedureReturn r
EndProcedure

Procedure BindWindowMessage(window, msg, callback.MessageHandler)
  Protected wid = WindowID(window)
  
  If Not GetWindowSubclass_(wid, @_EventHandler(), 0, 0)
    SetWindowSubclass_(wid, @_EventHandler(), 0, 0)
  EndIf
  SetIDProp(wid, msg, callback)  
EndProcedure

Procedure UnbindWindowMessage(window, msg)
  Protected wid = WindowID(window)
  
  DeleteIDProp(wid, msg)
EndProcedure

Procedure BindMessage(gadget, msg, callback.MessageHandler)
  Protected gid = GadgetID(gadget)
  
  If Not GetWindowSubclass_(gid, @_EventHandler(), 0, 0)
    SetWindowSubclass_(gid, @_EventHandler(), 0, 0)
  EndIf
  SetIDProp(gid, msg, callback)
EndProcedure

Procedure UnbindMessage(gadget, msg)
  Protected gid = GadgetID(gadget)
  
  DeleteIDProp(gid, msg)
EndProcedure

; //
; // Small demo
; //

Define e, i, c
OpenWindow(0, 0, 0, 400, 300, "Test")

ButtonGadget(0, 10, 10, 80, 40, "Test")
ButtonGadget(1, 100, 10, 80, 40, "Test2")
Procedure MyButtonMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  ;UnbindMessage(g, #WM_RBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

Procedure MyWindowMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  If IsGadget(0)
    ;FreeGadget(0)
  EndIf
  ;UnbindWindowMessage(g, #WM_LBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

;BindMessage(0, #MSG_All, @MyTest())
BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessage())
BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow
ps archive of 'the old new thing'.. http://bytepointer.com/resources/old_ne ... /index.htm
Rinzwind
Enthusiast
Enthusiast
Posts: 636
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Re: Modular alternative for SetWindowCallback

Post by Rinzwind »

Little bonus example that shows how to drag a window the right mouse button:

Code: Select all

OpenWindow(0, 200, 200, 400, 200, "Move window with mouse while holding right mouse button")

Procedure EventWindowMouse(w, h, msg, wp, lp)
  Static p1.POINT, wr1.RECT
  Protected p2.POINT
  
  Select msg
    Case #WM_MOUSEMOVE      
      If GetCapture_() = h
        GetCursorPos_(p2)
        SetWindowPos_(h, 0, wr1\left + (p2\x - p1\x), wr1\top + (p2\y - p1\y), 0, 0, #SWP_NOSIZE | #SWP_NOZORDER | #SWP_NOREDRAW)        
      EndIf
    Case #WM_RBUTTONDOWN
      SetCapture_(h)
      GetCursorPos_(p1)
      GetWindowRect_(h, wr1)
    Case #WM_RBUTTONUP
      ReleaseCapture_()
  EndSelect
  
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

BindWindowMessage(0, #WM_RBUTTONDOWN, @EventWindowMouse())
BindWindowMessage(0, #WM_RBUTTONUP, @EventWindowMouse())
BindWindowMessage(0, #WM_MOUSEMOVE, @EventWindowMouse())

Define e

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow
Ok not a big difference here, the advantage of using these bind procedures shine when binding many messages and controls. Instead of one giant callback, it is functionally separated and also "multi include file and module" friendly.

ps if only PB had inline array initialization... (when coming?) aka BindWindowMessage(0, [#WM_MOUSEMOVE, #WM_RBUTTONUP, #WM_MOUSEMOVE], @EventWindowMouse())
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Modular alternative for SetWindowCallback

Post by mk-soft »

I have revised my code. Basic idea from Rinzwind

Code: viewtopic.php?p=576225#p576225
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
Post Reply