den Code (aus Wine) nach PB portiert. Damit laesst es sich sehr
viel einfacher arbeiten. Dokumentiert ist das ganze auf MSDN.
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
schöne Sache, leider ist das Beispiel nicht so schön 
