' I'm toying with this sublcass method as a way to generalize controls so that I can use them more than once in the same or
' different programs. Prior to this, for some reason, I thought subclassing had to be one subclass procedure for one control
' only.
' Questions:
' 1. Can the subclass functions be in a DLL (Wondering about the scope of the CODEPTR function? My guess is not allowed.
' 2. If a subclass procedure has code that decides where to jump next, either the next field or three fields down the
' page, can the id's just simply be passed using Control Set User that is, at the moment using the Subclassing
' 3. Can the Set User be used to store STRPTR's or VARPTR's in case of variable data that might be needed in the subclass control
' that would be different for each control that might use the subclass.
' Any other utility uses that might be pointed out would be appreciated.
'
'Bob Mechler
' different programs. Prior to this, for some reason, I thought subclassing had to be one subclass procedure for one control
' only.
' Questions:
' 1. Can the subclass functions be in a DLL (Wondering about the scope of the CODEPTR function? My guess is not allowed.
' 2. If a subclass procedure has code that decides where to jump next, either the next field or three fields down the
' page, can the id's just simply be passed using Control Set User that is, at the moment using the Subclassing
' 3. Can the Set User be used to store STRPTR's or VARPTR's in case of variable data that might be needed in the subclass control
' that would be different for each control that might use the subclass.
' Any other utility uses that might be pointed out would be appreciated.
'
'Bob Mechler
Code:
'MESSAGE http://www.powerbasic.com/support/forums/Forum7/HTML/003030.html 'FORUM: Source Code 'TOPIC: Simple subclassing in a box 'NAME: Colin Schmidt, Member 'DATE: October 26, 2006 02:39 AM 'SubClassInABox.bas 'Demonstrate simple subclassing using just a few macros. 'Key point is that it uses the internal %GWL_USERDATA storage of each 'subclassed control so that you don't have to keep track of the original 'WinProc value yourself. It is naturally thread safe and you may have 'as many subclassed controls on as many different windows as you like. 'Colin Schmidt, skyhawk76(at)yahoo.com ' Other portions from Kev Peel's Light Hoverbutton control (LabelProc) and a sample of a subclassed decimal textbox example ' from somewhere. ' %USEMACROS = 1 #INCLUDE "Win32API.inc" '------------------------------------------------------------------------------- 'This is the box MACRO mSC_Set(phDlg, phCtl, pProc) SetWindowLong GetDlgItem(phDlg, phCtl), %GWL_USERDATA, _ SetWindowLong(GetDlgItem(phDlg, phCtl), %GWL_WNDPROC, CODEPTR(pProc)) END MACRO MACRO mSC_Kill(phCtl) SetWindowLong(GetDlgItem(CBHNDL, phCtl), %GWL_WNDPROC, _ GetWindowLong(CBHNDL, %GWL_USERDATA)) END MACRO MACRO mSC_OrgProc FUNCTION = CallWindowProc(GetWindowLong(phWnd, %GWL_USERDATA), phWnd, pdMsg, pWParam, pLParam) END MACRO 'End of box '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- 'Example of using the box %ID_EXIT = 100: %IDC_TextBox = 101: %IDC_TextBox1 = 102: %IDC_TextBox2 = 103: %IDC_TextBox3 = 104: %IDC_TextBox4 = 105 %IDC_Notice = 201: %IDC_Notice1 = 202: %IDC_Hint = 203 %hf1 = 100 GLOBAL TXT AS STRING,VKEY AS LONG FUNCTION PBMAIN LOCAL lhDlg AS DWORD DIALOG NEW 0, "SubClassInABox", , , 200, 190, %WS_MINIMIZEBOX OR %WS_SYSMENU TO lhDlg CONTROL ADD TEXTBOX, lhDlg, %IDC_TextBox, "", 10, 10, 75, 12,%ES_LEFT OR %WS_BORDER OR %WS_TABSTOP,%WS_EX_LEFT OR %WS_EX_CLIENTEDGE CONTROL ADD LABEL, lhDlg, %IDC_Hint , "Try pressing F6! or Enter ",86,10,100,12 CONTROL ADD TEXTBOX, lhDlg, %IDC_TextBox1, "", 10, 22, 75, 12,%ES_LEFT OR %WS_BORDER OR %WS_TABSTOP,%WS_EX_LEFT OR %WS_EX_CLIENTEDGE CONTROL ADD TEXTBOX, lhDlg, %IDC_TextBox2, "", 10, 34, 50, 12,%ES_RIGHT OR %WS_BORDER OR %WS_TABSTOP,%WS_EX_LEFT OR %WS_EX_CLIENTEDGE CONTROL SEND lhDlg, %IDC_TextBox2, %EM_LIMITTEXT, 10, 0 CONTROL ADD LABEL, lhDlg, %IDC_Hint , "Decimal <= 10 digits ",86,34,100,12 CONTROL ADD LABEL, lhDlg, %IDC_Notice, STR$(%IDC_Notice), 10, 100, 75, 10,%SS_SIMPLE OR %SS_NOTIFY CONTROL ADD LABEL, lhDlg, %IDC_Hint , "<--Hover or click ",86,100,100,12 CONTROL ADD LABEL, lhDlg, %IDC_Notice1, STR$(%IDC_Notice1), 10, 115, 75, 10,%SS_SIMPLE OR %SS_NOTIFY CONTROL ADD BUTTON, lhDlg, %ID_EXIT, "&OK", 145, 150, 40, 14 CONTROL ADD LABEL, lhDlg, %IDC_Hint , "<--Hover or click ",86,115,100,12 mSC_Set(lhDlg, %IDC_TextBox, TextBoxProc) mSC_Set(lhDlg, %IDC_TextBox2, MoneyInput_SC) mSC_Set(lhDlg, %IDC_Notice, LabelProc) mSC_Set(lhDlg, %IDC_Notice1, LabelProc) DIALOG SHOW MODAL lhDlg CALL MainProc END FUNCTION CALLBACK FUNCTION MainProc SELECT CASE AS LONG CBMSG CASE %WM_DESTROY mSC_Kill(%IDC_TextBox) mSC_Kill(%IDC_TextBox2) mSC_Kill(%IDC_Notice) mSC_Kill(%IDC_Notice1) CASE %WM_COMMAND SELECT CASE AS LONG CBCTL CASE %IDOK SetFocus GetNextDlgTabItem(CBHNDL,GetFocus(),0) CASE %ID_EXIT DIALOG END CBHNDL END SELECT END SELECT END FUNCTION FUNCTION Lookup (TXT AS STRING) AS LONG LOCAL lhDlg1 AS LONG DIALOG NEW 0, "Add something to the text",10 ,100 , 200, 195, %WS_MINIMIZEBOX OR %WS_SYSMENU TO lhDlg1 CONTROL ADD TEXTBOX, lhDlg1, %hf1, TXT, 10, 10, 75, 10 CONTROL ADD BUTTON, lhDlg1, %ID_EXIT, "&OK", 145, 150, 40, 14 DIALOG SHOW MODAL lhDlg1, CALL MainProc1 END FUNCTION CALLBACK FUNCTION MainProc1 SELECT CASE AS LONG CBMSG CASE %WM_COMMAND SELECT CASE AS LONG CBCTL CASE %ID_EXIT SELECT CASE CBCTLMSG CASE %BN_CLICKED CONTROL GET TEXT CBHNDL,%HF1 TO TXT DIALOG END CBHNDL END SELECT CASE %HF1 SELECT CASE CBCTLMSG CASE %EN_UPDATE CONTROL GET TEXT CBHNDL,%HF1 TO TXT END SELECT END SELECT END SELECT END FUNCTION FUNCTION MoneyInput_SC(BYVAL phWnd AS DWORD, BYVAL pdMsg AS DWORD, BYVAL pWParam AS DWORD, BYVAL pLParam AS LONG) AS LONG DIM Dpnt AS LOCAL LONG DIM hWnd AS LOCAL DWORD DIM Mlen AS LOCAL LONG DIM Tlen AS LOCAL LONG DIM Txt AS LOCAL ASCIIZ * %MAX_PATH DIM Value AS LOCAL CUX SELECT CASE pdMsg CASE %WM_CHAR : IF pWParam < 32 THEN EXIT SELECT ' BkSpc, Tab, etc pass these on IF pWParam > 57 THEN EXIT FUNCTION ' > "9" not legal IF pWParam = 47 THEN EXIT FUNCTION ' "/" not legal IF pWParam < 46 THEN EXIT FUNCTION ' < "." not legal Tlen = GetWindowTextLength(phWnd) ' current text length IF Tlen = 0 THEN EXIT SELECT ' anything goes here! GetWindowText phWnd, Txt, %MAX_PATH ' get current text Dpnt = INSTR(Txt,".") ' find "." IF pWParam = 46 THEN ' "." was input IF Dpnt > 0 THEN EXIT FUNCTION ' can't have 2 ELSEIF Dpnt > 0 THEN ' already working on decimal value IF Dpnt + 2 = Tlen THEN EXIT FUNCTION ' can't have more than 2 places past decimal ELSE ' digits 0 -> 9 Mlen = SendMessage(phWnd,%EM_GETLIMITTEXT,0,0) ' max length IF Tlen = Mlen-3 THEN EXIT FUNCTION ' can't have more whole numbers than this END IF ' CASE %WM_PASTE : EXIT FUNCTION ' bypass this CASE %WM_SETFOCUS : GetWindowText phWnd, Txt, %MAX_PATH ' strip out the comma's Txt = REMOVE$(Txt,",") ' SetWindowText phWnd, Txt ' SendMessage phWnd, %EM_SETSEL, 0, -1 ' CASE %WM_KILLFOCUS : GetWindowText phWnd, Txt, %MAX_PATH ' reformat the value for display Value = VAL(Txt) ' Txt = FORMAT$(Value, "0,.00") ' SetWindowText phWnd, Txt ' END SELECT ' ' ' mSC_OrgProc END FUNCTION FUNCTION TextBoxProc(BYVAL phWnd AS DWORD, BYVAL pdMsg AS DWORD, BYVAL pWParam AS DWORD, BYVAL pLParam AS LONG) AS LONG SELECT CASE AS LONG pdMsg CASE %WM_KEYDOWN,%WM_SYSKEYDOWN CONTROL SET TEXT GetParent(phWnd), %IDC_Notice, STR$(pWParam) IF pWParam = %VK_F6 THEN CONTROL GET TEXT GetParent(phWnd),%IDC_TextBox TO TXT CALL Lookup(TXT) CONTROL SET TEXT GetParent(phWnd),%IDC_TextBox1,TXT CONTROL SET FOCUS GetParent(phWnd),%IDC_TextBox1 END IF CASE %WM_KEYUP IF pWParam = %VK_RETURN THEN GetNextDlgTabItem(GetParent(phWnd),phWnd,0) END IF END SELECT mSC_OrgProc END FUNCTION TYPE HB_DATA ' Custom data for the control zText AS ASCIIZ * 250 ' Display text cText AS DWORD ' Text color cBack AS DWORD ' Back color cHovTxt AS DWORD ' Mouse over text color cHovBk AS DWORD ' Mouse over back color cFocus AS DWORD ' Focus rectangle color bHasTxtClr AS BYTE ' Nonzero if text color is valid bHasBkClr AS BYTE ' Nonzero if back color is valid bIsOver AS BYTE ' Mouse is hovering over bIsDown AS BYTE ' Mouse button is down bTimer AS BYTE ' Nonzero for timer bCheck AS BYTE ' Nonzero if checked lfFont AS LOGFONT ' Font style END TYPE FUNCTION LabelProc(BYVAL phWnd AS DWORD, BYVAL pdMsg AS DWORD, BYVAL pWParam AS DWORD, BYVAL pLParam AS LONG) AS LONG DIM pt AS POINTAPI,rc AS RECT, i AS LONG STATIC fda AS LONG STATIC fdaover AS LONG DIM CID AS LONG CID = GetDlgCtrlId(phWnd) SELECT CASE AS LONG pdMsg CASE %WM_LBUTTONDOWN SetWindowText GetParent(phWnd), "Button Down " + STR$(CID) CASE %WM_LBUTTONUP SetWindowText GetParent(phWnd), "Button Up " + STR$(CID) CASE %WM_MOUSEMOVE ' Activate temporary timer... 'fda = GetWindowLong(phWnd, 0) IF fda = 0 THEN fda = 1 SetTimer phWnd, 100, 10, 0 END IF CASE %WM_TIMER ' This timer is temporarily set when the mouse moves over the control ' If the mouse moves off, the timer is destroyed. It is done this way for performance reasons... 'fda = GetWindowLong(phWnd, 0) GetCursorPos pt GetWindowRect phWnd, rc ' Send multiple signals to parent if button has spin style... i = PtInRect(rc, pt.x, pt.y) IF (i = 0) AND (fda = 1) THEN KillTimer phWnd, 100 fda = 0 END IF IF (i <> fdaover) THEN fdaover = IIF&(fdaover, 0, 1) 'RedrawWindow phWnd, BYVAL 0, 0, %RDW_ERASE OR %RDW_INVALIDATE END IF IF fdaover THEN CONTROL SET TEXT GetParent(phWnd),CID,"" CONTROL SET TEXT GetParent(phWnd),CID,STR$(CID) CONTROL SET COLOR GetParent(phWnd),CID,%RED,-1 RedrawWindow phWnd, BYVAL 0, 0, %RDW_ERASE OR %RDW_INVALIDATE ELSE CONTROL SET TEXT GetParent(phWnd),CID,"" CONTROL SET TEXT GetParent(phWnd),CID,STR$(CID) CONTROL SET COLOR GetParent(phWnd),CID,%BLACK,-1 RedrawWindow phWnd, BYVAL 0, 0, %RDW_ERASE OR %RDW_INVALIDATE END IF END SELECT mSC_OrgProc END FUNCTION
Comment