Subclassing Controls with ComCtl32.dll version 6 (win only)

Share your advanced PureBasic knowledge/code with the community.
Axolotl
Enthusiast
Enthusiast
Posts: 435
Joined: Wed Dec 31, 2008 3:36 pm

Subclassing Controls with ComCtl32.dll version 6 (win only)

Post by Axolotl »

Hey folks,
while browsing through the MSDN documentation, I stumbled across an interesting thing about subclassing.
After I played around with it a bit, I would like to share the current state with you....

Because of the additional parameters there are more possibilities than with the "old" function SetWindowLongPtr().
I still need to work out how it is best to use the two parameters uIdSubclass and dwRefData

But just look at the example and decide for yourself.

For starters, there is an article on MSDN that discusses the changes that occured in subclassing controls between version 6.0 and prior that you should be familiar with.
LINK : https://learn.microsoft.com/en-us/windo ... g-overview
and more descriptions and opinions ...
LINK : https://github.com/MicrosoftDocs/win32/ ... erview.md
LINK : https://devblogs.microsoft.com/oldnewthing/?p=41883

My code gets bigger and bigger but still can't cover all the possibilities....
So here is a small example code

Code: Select all

 
EnableExplicit

Import "Comctl32.lib" 
  ; use the PureBasic Syntax (Windows API procedures using trailing underscore) 
  ; 
  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" 
EndImport 

Enumeration EWindow 
  #WINDOW_Main 
EndEnumeration 

Enumeration EGadget 
  #GADGET_Panel 

  #GADGET_Button1
  #GADGET_Button2 
  #GADGET_Button3 

  #GADGET_Listview1 
  #GADGET_Listview2 
EndEnumeration 

#SUBCLAAS_Window = 1 
#SUBCLAAS_Button = 2 

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

Macro Out(Message) 
  AddGadgetItem(#GADGET_Listview1, -1, Message) 
  SetGadgetState(#GADGET_Listview1, CountGadgetItems(#GADGET_Listview1)-1)
  SetGadgetState(#GADGET_Listview1, -1) 
  Debug "OUT: " + Message 

  AddGadgetItem(#GADGET_Listview2, -1, Message) 
  SetGadgetState(#GADGET_Listview2, CountGadgetItems(#GADGET_Listview2)-1)
  SetGadgetState(#GADGET_Listview2, -1) 
EndMacro 


; ---------------------------------------------------------------------------------------------------------------------
;  SubclasssWindowProc .. 
; ---------------------------------------------------------------------------------------------------------------------

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

Procedure SubclassWindowProc(hWnd, uMsg, wParam, lParam, uIdSubclass, dwRefData) 
  Static pt.POINT, wr.RECT, hCursor = 0  
  Protected pt2.POINT 

  Select uMsg 
    Case #WM_NCDESTROY                                                         :Debug("WM_NCDESTROY") 
      ; 
      ; remove all defined subclass procedures 
      ; 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc(), uIdSubclass)  

    Case #WM_NCLBUTTONDOWN                     ;:Debug("WM_NCLBUTTONDOWN") 
      If hCursor : SetCursor_(hCursor) : EndIf   

    Case #WM_MOUSEMOVE                         ;:Debug("WM_MOUSEMOVE") 
      If hCursor = 0 : hCursor = LoadCursor_(#Null, #IDC_HAND) : EndIf   
      If hCursor : SetCursor_(hCursor) : EndIf   

      If GetCapture_() = hWnd 
        GetCursorPos_(pt2)
        SetWindowPos_(hWnd, 0, wr\left + (pt2\x - pt\x), wr\top + (pt2\y - pt\y), 0, 0, #SWP_NOSIZE|#SWP_NOZORDER|#SWP_NOREDRAW) 
      EndIf

    Case #WM_LBUTTONDOWN                                                       :Debug("WM_LBUTTONDOWN") 
      SendMessage_(hWnd, #WM_NCLBUTTONDOWN, #HTCAPTION, 0)  

    Case #WM_LBUTTONUP                                                         :Debug("WM_LBUTTONUP") 
      ReleaseCapture_() 

    Case #WM_RBUTTONDOWN                                                       :Debug("WM_RBUTTONDOWN") 
      SetCapture_(hWnd)
      GetCursorPos_(pt)
      GetWindowRect_(hWnd, wr)
      If hCursor : SetCursor_(hCursor) : EndIf   

    Case #WM_RBUTTONUP                                                         :Debug("WM_RBUTTONUP") 
      ReleaseCapture_() 

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

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

Procedure SubclassGadgetProc(hWnd, uMsg, wParam, lParam, uIdSubclass, dwRefData) 
  Protected *drawItem.DRAWITEMSTRUCT 
  Protected text.s, field.s, state  
  Protected textColor, brush  ; for background 

  Select uMsg 
    Case #WM_NCDESTROY                                                         :Debug("WM_NCDESTROY") 
      ; 
      ; remove all defined subclass procedures 
      ; 
      RemoveWindowSubclass_(hWnd, @SubclassGadgetProc(), uIdSubclass)  

    Case #WM_RBUTTONUP                                                         :Debug("WM_RBUTTONUP") 
      ; 
      ; uIdSubclass is #SUBCLASS_Gadget 
      ; 
      PostEvent(#PB_Event_Gadget, GetActiveWindow(), GetDlgCtrlID_(hwnd), #PB_EventType_RightClick) 
      ; 
      ; here the use of uIdSubclass is possible (assigned #GADGET_ButtonX) 
      ;
      ; PostEvent(#PB_Event_Gadget, GetActiveWindow(), uIdSubclass, #PB_EventType_RightClick)  
      ; 
; Debug " .. GetDlgCtrlID(hwnd)     -> " + GetDlgCtrlID_(hwnd) 
; Debug " .. GetProp(hwnd, 'PB_ID') -> " + GetProp_(hwnd, "PB_ID") 
; Debug " .. uIdSubclass            -> " + uIdSubclass 

    Case #WM_DRAWITEM                          ;:Debug("WM_DRAWITEM") 
      *drawItem = lParam  ; type cast :) 

   ;  If wParam = #GADGET_Listview1 ; exact this listview 
      ; 
      ; here we can use uIdSubclass (assigned #GADGET_ListviewX) 
      ;
      If wParam = uIdSubclass                                                  ;:Debug("WM_DRAWITEM") 
        If *drawItem\itemID <> -1 ; And *drawItem\CtlType = #ODT_LISTBOX 
          text = GetGadgetItemText(wParam, *drawItem\itemID) 

          ; make it look special (the reason why we do the drawing by ourselves. 
          If *drawItem\itemState & #ODS_SELECTED 
            brush = CreateSolidBrush_(GetSysColor_(#COLOR_HIGHLIGHT))
            textColor = GetSysColor_(#COLOR_HIGHLIGHTTEXT) 
          Else 
            If *drawItem\itemID & $01 
              brush = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW)) 
            Else 
              brush = CreateSolidBrush_(GetSysColor_(#COLOR_3DFACE)) 
            EndIf 
            textColor = GetSysColor_(#COLOR_WINDOWTEXT) 
          EndIf 
          FillRect_(*drawItem\hdc, *drawItem\rcItem, brush) 
          DeleteObject_(brush)  ; no longer needed 

          If *drawItem\itemState & #ODS_SELECTED 
            DrawFocusRect_(*drawItem\hdc, *drawItem\rcItem)   ; needed if we let the default procedures work on this event 
          EndIf 

          SetTextColor_(*drawItem\hdc, textColor) 
          SetBkMode_(*drawItem\hdc, #TRANSPARENT)  

          ; first column [30] is item index ... 
          field = RSet(Str(*drawItem\itemID), 4, "0") + ": " 
          TextOut_(*drawItem\hdc, *drawItem\rcItem\left+2, *drawItem\rcItem\top, @field, Len(field)) 

          ; second column [all] is entire item text 
          field = text 
          TextOut_(*drawItem\hdc, *drawItem\rcItem\left+40, *drawItem\rcItem\top, @field, Len(field)) 

        ; ProcedureReturn 0   ; don't let the default procedures work 
        EndIf 
      EndIf ; wParam = uIdSubclass  
    
  EndSelect 
  ProcedureReturn DefSubclassProc_(hWnd, uMsg, wParam, lParam)  ; do the chain procedures 
EndProcedure

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

Procedure main() 
  Protected RefData   ; for testing  

  If OpenWindow(#WINDOW_Main, 0, 0, 640, 480, "Move window with mouse while holding left mouse button", #PB_Window_ScreenCentered|#PB_Window_SystemMenu) 
    StickyWindow(#WINDOW_Main, 1) ; always on top :) 

    PanelGadget(#GADGET_Panel, 32, 16, 600, 200) 
      AddGadgetItem(#GADGET_Panel, -1, "Panel 1")
      ButtonGadget(#GADGET_Button1, 8, 8, 96, 24, "Button 1") 

      AddGadgetItem(#GADGET_Panel, -1, "Panel 2") 
      ButtonGadget(#GADGET_Button2, 8, 8, 96, 24, "Button 2") 

      AddGadgetItem(#GADGET_Panel, -1, "Panel 3")  
      ListViewGadget(#GADGET_Listview1, 8, 8, 584, 184, #LBS_OWNERDRAWFIXED|#LBS_HASSTRINGS) 

    CloseGadgetList() ; Panel 
  
    ButtonGadget(#GADGET_Button3,  32, 224, 96, 24, "Button 3") 

    ListViewGadget(#GADGET_Listview2, 136, 224, 240, 200, #LBS_OWNERDRAWFIXED|#LBS_HASSTRINGS) 

    ; Window 
    SetWindowSubclass_(WindowID(#WINDOW_Main), @SubclassWindowProc(), #SUBCLAAS_Window, 100)  ; 

   ;SetWindowSubclass_(GetParent_(GadgetID(#GADGET_Button1)), @SubclassWindowProc(), #SUBCLAAS_Button, 101)  ; 
    SetWindowSubclass_(GadgetID(#GADGET_Button1), @SubclassGadgetProc(), #SUBCLAAS_Button, 101)  ; 
    SetWindowSubclass_(GadgetID(#GADGET_Button2), @SubclassGadgetProc(), #SUBCLAAS_Button, 102)  ; 
    SetWindowSubclass_(GadgetID(#GADGET_Button3), @SubclassGadgetProc(), #SUBCLAAS_Button, 103)  ; 

    ; use the #GADGET_Xxxx to determine the gadget we want work with 
    ; 
    SetWindowSubclass_(GetParent_(GadgetID(#GADGET_Listview1)), @SubclassGadgetProc(), #GADGET_Listview1, 110)  ; 
    SetWindowSubclass_(GetParent_(GadgetID(#GADGET_Listview2)), @SubclassGadgetProc(), #GADGET_Listview2, 111)  ; 
  
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow : Break ; say good bye. 
        Case #PB_Event_Gadget
          Select EventGadget()
            Case #GADGET_Button1
              Select EventType()
                Case #PB_EventType_LeftClick    : Out("Left Click Button 1") 
                Case #PB_EventType_RightClick   : Out("Right Click Button 1")
              EndSelect
            Case #GADGET_Button2
              Select EventType()
                Case #PB_EventType_LeftClick    : Out("Left Click Button 2") 
                Case #PB_EventType_RightClick   : Out("Right Click Button 2")
              EndSelect
            Case #GADGET_Button3
              Select EventType()
                Case #PB_EventType_LeftClick    : Out("Left Click Button 3") 
                  If GetWindowSubclass_(GetParent_(GadgetID(#GADGET_Listview1)), @SubclassGadgetProc(), #GADGET_Listview1, @RefData) 
                    Debug "OUT:  RefData (110) == " + RefData 
                  EndIf 
                Case #PB_EventType_RightClick   : Out("Right Click Button 3")
              EndSelect
          EndSelect
      EndSelect
    ForEver
  EndIf 
EndProcedure 

End main() 


Happy coding and stay healthy.
Mostly running PureBasic <latest stable version and current alpha/beta> (x64) on Windows 11 Home
Axolotl
Enthusiast
Enthusiast
Posts: 435
Joined: Wed Dec 31, 2008 3:36 pm

Re: Subclassing Controls with ComCtl32.dll version 6 (win only)

Post by Axolotl »

Example of how easy subclass management works
BTW: I use the dwRefData parameter to check the proper function on the unique subclass procedures

Background information:
ComCtl32.dll version 6 supplied with Windows XP contains four functions that make creating subclasses easier and
eliminate the disadvantages previously discussed. The new functions encapsulate the management involved with multiple
sets of reference data, therefore the developer can focus on programming features and not on managing subclasses.

Code: Select all

EnableExplicit 

Import "Comctl32.lib" 
  ; use the PureBasic Syntax (Windows API procedures using trailing underscore) 
  ; 
  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" 
EndImport 

Enumeration EWindow 
  #WINDOW_Main 
EndEnumeration 

Enumeration EGadget 
EndEnumeration 


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

Macro Debug(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                                                         :Debug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc1(), uIdSubclass)  

    Case #WM_LBUTTONDOWN                                                       :Debug("WM_LBUTTONDOWN") 
    Case #WM_RBUTTONDOWN                                                       :Debug("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                                                         :Debug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc2(), uIdSubclass)  

    Case #WM_LBUTTONDOWN                                                       :Debug("WM_LBUTTONDOWN") 
    Case #WM_RBUTTONDOWN                                                       :Debug("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                                                         :Debug("WM_NCDESTROY") 
      RemoveWindowSubclass_(hWnd, @SubclassWindowProc3(), uIdSubclass)  

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

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


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


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

    ; No Gadgets 
    
    hwndMain = WindowID(#WINDOW_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() 
Mostly running PureBasic <latest stable version and current alpha/beta> (x64) on Windows 11 Home
PeDe
Enthusiast
Enthusiast
Posts: 119
Joined: Sun Nov 26, 2017 3:13 pm
Location: Vienna
Contact:

Re: Subclassing Controls with ComCtl32.dll version 6 (win only)

Post by PeDe »

I am using Windows 7, 32-bit with PB v6.02, and I get this error message:

Code: Select all

---------------------------
PureBasic - Linker error
---------------------------
error: Unresolved external symbol 'RemoveWindowSubclass'.
POLINK: error: Unresolved external symbol 'DefSubclassProc'.
POLINK: error: Unresolved external symbol 'SetWindowSubclass'.
POLINK: error: Unresolved external symbol 'GetWindowSubclass'.
POLINK: fatal error: 4 unresolved external(s).
---------------------------
OK   
---------------------------
But it works with the following changes:

Code: Select all

Import "Comctl32.lib" 
  ; use the PureBasic Syntax (Windows API procedures using trailing underscore) 
  ; 
  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" 
EndImport 
Why does your code work for you, does it have to do with the 64-bit version?

Peter
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Subclassing Controls with ComCtl32.dll version 6 (win only)

Post by mk-soft »

Why does your code work for you, does it have to do with the 64-bit version?
Yes

Code: Select all

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
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
Axolotl
Enthusiast
Enthusiast
Posts: 435
Joined: Wed Dec 31, 2008 3:36 pm

Re: Subclassing Controls with ComCtl32.dll version 6 (win only)

Post by Axolotl »

Thanks for testing and improving...
Mostly running PureBasic <latest stable version and current alpha/beta> (x64) on Windows 11 Home
Post Reply