PureBoard

Code: Alles auswählen

;***********************************************************************
;* Window related functions
;*
;* Copyright 1993, 1994 Alexandre Julliard
;*
;* This library is free software; you can redistribute it and/or
;* modify it under the terms of the GNU Lesser General Public
;* License as published by the Free Software Foundation; either
;* version 2.1 of the License, or (at your option) any later version.
;*
;* This library is distributed in the hope that it will be useful,
;* but WITHOUT ANY WARRANTY; without even the implied warranty of
;* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;* Lesser General Public License for more details.
;*
;* You should have received a copy of the GNU Lesser General Public
;* License along with this library; if not, write to the Free Software
;* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
;*


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

Code: Alles auswählen

Procedure SUBCLASSPROC(hWnd,uMsg,wParam,lParam,uId,dwData)
  
  if uId = 0 and uMsg = #wm_move 
    debug uId
    debug dwData
    debug "--------"
  EndIf
  
  if uId = 1 and uMsg = #wm_size
    debug uId
    debug dwData
    debug "--------"
  EndIf
  
  ProcedureReturn DefSubclassProc(hWnd, uMsg , wParam, lParam)
EndProcedure

hWnd = OpenWindow(0,0,0,200,200,"",#WS_OVERLAPPEDWINDOW|#PB_Window_ScreenCentered)

CreateGadgetList(hWnd)

SetWindowSubclass(hwnd,@SUBCLASSPROC(),0,666)
SetWindowSubclass(hwnd,@SUBCLASSPROC(),1,7777)

Repeat : Until WaitWindowEvent() = 16

Code: Alles auswählen

XIncludeFile "obigencode.pb"

Macro HiWord(long)
  (long >> 16) & $FFFF
EndMacro

Macro LoWord(long)
  long & $FFFF
EndMacro

Structure Event
  event.l
  subevent1.l
  subevent2.l
  Proc.l
  dwdata.l
EndStructure

Enumeration #WM_USER + 1000
  #OnClick
  #OnFokus
  #OnMouseMove
EndEnumeration

Procedure ButtonEventCallback(hWnd,uMsg,wParam,lParam,uId,*dwData.Event)

  If *dwData\event = #WM_COMMAND And lparam = uid
    If HiWord(wParam) = *dwData\subevent1
      CallFunctionFast(*dwData\proc,hWnd,wParam,lParam)
    EndIf
  EndIf

  If *dwData\event = #WM_MOUSEMOVE And uMsg = #WM_MOUSEMOVE
    CallFunctionFast(*dwData\proc,hWnd,wParam,lParam)
  EndIf

  ProcedureReturn DefSubclassProc(hWnd, uMsg , wParam, lParam)
EndProcedure

Procedure SetEvent(hwnd,ev,proc)
  Protected Buffer.s
  Protected *evh.Event

  id = ev

  Select ev
    Case #OnClick
      Buffer = Space(128)
      GetClassName_(hwnd,buffer,128)
      If LCase(buffer) = "button"
        id        = hwnd
        hwnd      = GetParent_(hwnd)
        event     = #WM_COMMAND
        subevent1 = #BN_CLICKED
        evhp      = @ButtonEventCallback()
      EndIf
    Case #OnFokus
      Buffer = Space(128)
      GetClassName_(hwnd,buffer,128)
      If LCase(buffer) = "button"
        id        = hwnd
        style = GetWindowLong_(hwnd,#GWL_STYLE)
        SetWindowLong_(hwnd,#GWL_STYLE,style|$4000) ; #BS_NOTIFY
        hwnd      = GetParent_(hwnd)
        event     = #WM_COMMAND
        subevent1 = #BN_SETFOCUS
        evhp      = @ButtonEventCallback()
      EndIf
    Case #OnMouseMove
      event     = #WM_MOUSEMOVE
      evhp      = @ButtonEventCallback()
  EndSelect

  GetWindowSubclass(hwnd,evhp,id,@*evh)

  If Not *evh
    *evh = AllocateMemory(SizeOf(Event))
  EndIf

  *evh\event     = event
  *evh\subevent1 = subevent1
  *evh\proc      = proc

  ProcedureReturn SetWindowSubclass(hwnd,evhp,id,*evh)
EndProcedure

Procedure OnClick_button1(hWnd,wParam,lParam)
  Debug "OnClick_button1"
EndProcedure

Procedure OnClick_button2(hWnd,wParam,lParam)
  Debug "OnClick_button2"
EndProcedure

Procedure MouseMove_button2(hWnd,wParam,lParam)
  Debug "MouseMove_button2"
EndProcedure

hWnd = OpenWindow(0,0,0,200,200,"",#WS_OVERLAPPEDWINDOW|#PB_Window_ScreenCentered)

CreateGadgetList(hWnd)
button0 = ButtonGadget(0, 10, 10, 80, 30, "bla")
button1 = ButtonGadget(1, 10, 40, 80, 30, "bla")

SetEvent(button0,#OnClick,@OnClick_button1())
SetEvent(button1,#OnClick,@OnClick_button2())
SetEvent(button1,#OnMouseMove,@MouseMove_button2())

Repeat : Until WaitWindowEvent() = 16

Code: Alles auswählen

;***********************************************************************
;* SetWindowSubclass [COMCTL32.410]
;*
;* Starts a window subclass
;*
;* ...snip
;*
;* 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.