http://source.winehq.org

CompilerIf Defined(SetWindowSubclass,#PB_Procedure) = 0 
 
EnableExplicit 
 
#COMCTL32_wSubclass = "CC32SubclassInfo" 
 
Prototype SUBCLASSPROC(HWND, UINT, WPARAM, LPARAM, UINT_PTR, DWORD_PTR) 
 
Declare COMCTL32_SubclassProc(hWnd,uMsg,wParam,lParam) 
Declare SetWindowSubclass(hWnd,pfnSubclass,uID,dwRef_in) 
Declare GetWindowSubclass(hWnd,pfnSubclass,uID,dwRef_out) 
Declare RemoveWindowSubclass(hWnd,pfnSubclass,uID) 
Declare DefSubclassProc(hWnd,uMsg,wParam,lParam) 
 
Structure SUBCLASSPROCS 
  subproc.SUBCLASSPROC  
  id.l 
  ref.l 
  *next.SUBCLASSPROCS 
EndStructure 
 
Structure SUBCLASS_INFO 
  *SubclassProcs.SUBCLASSPROCS  
  *stackpos.SUBCLASSPROCS  
  origproc.l 
  running.l 
EndStructure 
 
 
;*********************************************************************** 
;* SetWindowSubclass [COMCTL32.410] 
;* 
;* Starts a window subclass 
;* 
;* PARAMS 
;*     hWnd [in] handle to window subclass. 
;*     pfnSubclass [in] Pointer to new window procedure. 
;*     uIDSubclass [in] Unique identifier of sublass together with pfnSubclass. 
;*     dwRef [in] Reference data to pass to window procedure. 
;* 
;* RETURNS 
;*     Success: non-zero 
;*     Failure: zero 
;* 
;* BUGS 
;*     If an application manually subclasses a window after subclassing it with 
;*     this API and then with this API again, then none of the previous  
;*     subclasses get called or the origional window procedure. 
;* 
 
Procedure SetWindowSubclass(hWnd,pfnSubclass,uID,dwRef) 
  Protected *stack.SUBCLASS_INFO 
  Protected *proc.SUBCLASSPROCS 
   
  *stack = GetProp_(hWnd,#COMCTL32_wSubclass) 
   
  If Not *stack  
    *stack = AllocateMemory(SizeOf(SUBCLASS_INFO)) 
    If Not *stack 
      ProcedureReturn 
    EndIf 
     
    SetProp_(hWnd,#COMCTL32_wSubclass,*stack) 
     
    *stack\origproc = SetWindowLong_(hWnd,#GWL_WNDPROC,@COMCTL32_SubclassProc()) 
     
  Else 
     
    *proc = *stack\SubclassProcs 
     
    While *proc  
      If (*proc\id = uID) And (*proc\subproc = pfnSubclass) 
        *proc\ref = dwRef 
        ProcedureReturn #False 
      EndIf 
      *proc = *proc\next 
    Wend 
     
  EndIf 
   
  *proc = AllocateMemory(SizeOf(SUBCLASSPROCS)) 
   
  If Not *proc 
    SetWindowLong_(hWnd,#GWL_WNDPROC,*stack\origproc) 
    FreeMemory(*stack) 
    RemoveProp_(hWnd,#COMCTL32_wSubclass) 
    ProcedureReturn #False 
  EndIf 
   
  *proc\subproc        = pfnSubclass 
  *proc\ref            = dwRef 
  *proc\id             = uID 
  *proc\next           = *stack\SubclassProcs 
  *stack\SubclassProcs = *proc 
   
  ProcedureReturn #True  
EndProcedure 
 
 
;*********************************************************************** 
;* GetWindowSubclass [COMCTL32.411] 
;* 
;* Gets the Reference data from a subclass. 
;* 
;* PARAMS 
;*     hWnd [in] Handle to window which were subclassing 
;*     pfnSubclass [in] Pointer to the subclass procedure 
;*     uID [in] Unique indentifier of the subclassing procedure 
;*     pdwRef [out] Pointer to the reference data 
;* 
;* RETURNS 
;*     Success: Non-zero 
;*     Failure: 0 
;* 
 
Procedure GetWindowSubclass(hWnd,pfnSubclass,uID,*dwRef.long) 
  Protected *stack.SUBCLASS_INFO 
  Protected *proc.SUBCLASSPROCS 
   
  *stack = GetProp_(hWnd,#COMCTL32_wSubclass) 
   
  If Not *stack 
    ProcedureReturn #False 
  EndIf 
   
  *proc = *stack\SubclassProcs 
   
  While *proc  
    If (*proc\id = uID) And (*proc\subproc = pfnSubclass) 
      *dwRef\l = *proc\ref  
      ProcedureReturn #True 
    EndIf 
    *proc = *proc\next 
  Wend 
   
  ProcedureReturn #False 
EndProcedure  
 
 
;*********************************************************************** 
;* RemoveWindowSubclass [COMCTL32.412] 
;* 
;* Removes a window subclass. 
;* 
;* PARAMS 
;*     hWnd [in] Handle to the window were subclassing 
;*     pfnSubclass [in] Pointer to the subclass procedure 
;*     uID [in] Unique identifier of this subclass 
;* 
;* RETURNS 
;*     Success: non-zero 
;*     Failure: zero 
;* 
 
Procedure RemoveWindowSubclass(hWnd,pfnSubclass,uID) 
  Protected *stack.SUBCLASS_INFO 
  Protected *prevproc.SUBCLASSPROCS  
  Protected *proc.SUBCLASSPROCS  
  Protected ret = #False 
   
  *stack = GetProp_(hWnd,#COMCTL32_wSubclass) 
   
  If Not *stack 
    ProcedureReturn #False 
  EndIf 
   
  *proc = *stack\SubclassProcs 
   
  While *proc  
    If (*proc\id = uID) And (*proc\subproc = pfnSubclass) 
       
      If Not *prevproc 
        *stack\SubclassProcs = *proc\next 
      Else 
        *prevproc\next = *proc\next 
      EndIf 
       
      If *stack\stackpos = *proc 
        *stack\stackpos = *stack\stackpos\next 
      EndIf 
       
      FreeMemory(*proc) 
      ret = #True 
      Break 
       
    EndIf 
    *prevproc = *proc 
    *proc = *proc\next 
  Wend 
   
  If Not *stack\SubclassProcs And Not *stack\running 
    SetWindowLong_(hWnd,#GWL_WNDPROC,*stack\origproc) 
    FreeMemory(*stack) 
    RemoveProp_(hWnd,#COMCTL32_wSubclass) 
  EndIf 
   
  ProcedureReturn ret 
EndProcedure  
 
 
;*********************************************************************** 
;* COMCTL32_SubclassProc (internal) 
;* 
;* Window procedure for all subclassed windows.  
;* Saves the current subclassing stack position to support nested messages 
;* 
 
Procedure COMCTL32_SubclassProc(hWnd,uMsg,wParam,lParam) 
  Protected *stack.SUBCLASS_INFO 
  Protected *proc.SUBCLASSPROCS  
  Protected ret 
   
  *stack = GetProp_(hWnd,#COMCTL32_wSubclass) 
   
  If Not *stack 
    ProcedureReturn #False 
  EndIf 
   
  *proc = *stack\stackpos 
  *stack\stackpos = *stack\SubclassProcs  
  *stack\running + 1 
  ret = DefSubclassProc(hWnd, uMsg, wParam, lParam) 
  *stack\running - 1 
  *stack\stackpos = *proc 
   
  If Not *stack\SubclassProcs And Not *stack\running 
    SetWindowLong_(hWnd,#GWL_WNDPROC,*stack\origproc) 
    FreeMemory(*stack) 
    RemoveProp_(hWnd,#COMCTL32_wSubclass)  
  EndIf 
   
  ProcedureReturn ret 
EndProcedure  
 
 
;*********************************************************************** 
;* DefSubclassProc [COMCTL32.413] 
;* 
;* Calls the next window procedure (ie. the one before this subclass) 
;* 
;* PARAMS 
;*     hWnd [in] The window that we're subclassing 
;*     uMsg [in] Message 
;*     wParam [in] WPARAM 
;*     lParam [in] LPARAM 
;* 
;* RETURNS 
;*     Success: non-zero 
;*     Failure: zero 
;* 
 
Procedure DefSubclassProc(hWnd,uMsg,wParam,lParam) 
  Protected *stack.SUBCLASS_INFO 
  Protected *proc.SUBCLASSPROCS 
  Protected ret = #False 
   
  *stack = GetProp_(hWnd,#COMCTL32_wSubclass) 
   
  If Not *stack 
    ProcedureReturn #False 
  EndIf 
   
  If Not *stack\stackpos  
    ret = CallWindowProc_(*stack\origproc, hWnd, uMsg, wParam, lParam)  
  Else  
    *proc = *stack\stackpos 
    *stack\stackpos = *stack\stackpos\next 
    ret = *proc\subproc(hWnd, uMsg, wParam, lParam, *proc\id,*proc\ref)   
  EndIf 
   
  ProcedureReturn ret 
   
EndProcedure  
DisableExplicit 
 
CompilerEndIf