From: George H. <geo...@us...> - 2007-05-08 08:08:47
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12988/win32forth-stc/src/console Added Files: BasicWin.f ConsoleStatbar.f Statbar.f WinBase.f Log Message: gah:Added files for console status bar: NOTE needs the kernel to be meta compiled. Also when the status bar is loaded the info doesn't show until after the first use of interpret; just hit enter. --- NEW FILE: WinBase.f --- \ $Id: WinBase.f,v 1.1 2007/05/08 08:08:44 georgeahubert Exp $ \ File: WinBase.f \ Author: Jeff Kelm \ Created: 27-Aug-1998 \ Updated: August 17th, 2003 dbu \ Extensions and defines for Win32For Comment: Revision History (most recent first) September 17th, 2003 dbu - removed old Win32s support August 17th, 2003 dbu - Changed to use in WinEd 2.21.05 and later 19990601 - Uncommented the constants which don't show up on my NT machine (running older version of Win32forth). 19990520 - Removed the class name string definitions since these are now handled in the ChildWindow DefClassName: method. - Commented out most of the constant declarations since they now appear to work (at least on Win98, Win32Forth v4.2). 19990519 - Added stack frame code. 19990422 - Eliminated the 990413 changes. Didn't work. 19990413 - Eliminated "WinLibrary COMCTL32.DLL" initialization. Moved to BasicWin.f in Create: for ChildWindow. This will hopefully clear up issues with turnkeying if that DLL isn't already loaded. 19990315 - Changed DefinedAbort, to correct a problem in ?WinError ?WinError didn't compile the right stuff if the source was from the keyboard (or pasted from the clipboard) but inside a definition. The definition: : DrawAxes ... hdc GetHandle: wnd1 Call ReleaseDC ?WinError ; generated this when typed in by hand (or pasted): : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC DUP (?WINERROR) 0= ; \ leaves a flag on the stack! and generated this when read in from file: : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC DUP (?WINERROR) 0= ABORT" Defined in file: popup.f -- Line: 80" ; corrected version generates: : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC DUP (?WINERROR) 0= DROP ; - eliminated redundant IF...ELSE...THEN clause in DefinedAbort, since the only way DefinedAbort, is executed is when STATE is true. 19981120 - added UPDOWN_CLASS definition 19981118 - added TTM_UPDATETIPTEXT, TTM_ENUMTOOLS & TTM_GETTEXT 19981117 - separated window classes into their own file (BasicWin.f) - Simplified definitions for zCount and MAKELONG - Factored ?WinError, but it still looks too complicated Comment; Require menu.f CR .( Loading Extensions...) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Extensions to Win32For \ in-system : DEFAULTOF \ defines a default condition for CASE structure (must be last!) POSTPONE DUP POSTPONE OF ; IMMEDIATE in-application \ MAKELONG macro creates an unsigned 32-bit by concatenating two 16-bit values : MAKELONG ( hi lo -- n) SWAP word-join ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Redefined ?WinError to give more debugging information \ : (GetLastError) ( -- n) GetLastWinErr ; : (FormatSystemMessage) ( error -- a n) GetLastWinErrMsg count ; : (?WinError) ( f) \ show an error dialog box if f=FALSE/0 0= IF (GetLastError) (FormatSystemMessage) 2DUP 2 - ( to drop CRLF pair) CR TYPE CR ( echo to console) DROP >R MB_OK MB_ICONWARNING OR Z" Error" R> NULL Call MessageBox drop THEN ; false [IF] \ add more debugging information to ?WinError : DefinedAbort, \ compiles an ABORT" with the file name and line where defined LOADING? IF S" Defined in file: " TEMP$ PLACE LOADFILE COUNT TEMP$ +PLACE S" -- Line: " TEMP$ +PLACE LOADLINE @ (.) TEMP$ +PLACE POSTPONE (ABORT") TEMP$ COUNT ", 0 c, align ELSE POSTPONE DROP THEN ; : ?WinError ( f) STATE @ IF POSTPONE DUP POSTPONE (?WinError) POSTPONE 0= DefinedAbort, ELSE (?WinError) THEN ; IMMEDIATE [ELSE] \ just give messagebox as an alert, don't abort : ?WinError ( f) (?WinError) ; [THEN] : CreateNewID ( -- id) \ create a new id number (hopefully unique, but not guaranteed) NextId ; WinLibrary COMCTL32.DLL \ Add the advanced control library. \ Needed for CreateToolbar, CreateStatusWindow, etc. \ defines not in Win32for WINCON.DLL \ TTN_GETDISPINFOA CONSTANT TTN_NEEDTEXT \ ANSI version \ TBN_GETBUTTONINFOA CONSTANT TBN_GETBUTTONINFO \ ANSI version \ TTM_ADDTOOLA CONSTANT TTM_ADDTOOL \ ANSI version \ SB_SETTEXTA CONSTANT SB_SETTEXT \ ANSI version \ SB_GETTEXTA CONSTANT SB_GETTEXT \ ANSI version \ TTM_UPDATETIPTEXTA CONSTANT TTM_UPDATETIPTEXT \ ANSI version \ TTM_GETTEXTA CONSTANT TTM_GETTEXT \ ANSI version \ TTM_ENUMTOOLSA CONSTANT TTM_ENUMTOOLS \ ANSI version \ Strings not defined in Win32for \ : STATUSCLASSNAME Z" msctls_statusbar32" ; \ : TOOLBARCLASSNAME Z" ToolbarWindow32" ; \ : WC_TREEVIEW Z" SysTreeView32" ; \ : TOOLTIPS_CLASS Z" tooltips_class32" ; \ : PROGRESS_CLASS Z" msctls_progress32" ; \ : TRACKBAR_CLASS Z" msctls_trackbar32" ; \ : UPDOWN_CLASS Z" msctls_updown32" ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Load Resources \ \ LR_LOADFROMFILE is not claimed to work on NT, but the documentation \ appears to be out of date since it works on my NT machine. \ For icons, the alternative would be: \ 0 Z" Toolbar.ico" appInst \ Call ExtractIcon DUP VALUE hIcon ?WinError \ Couldn't find a simple alternative for bitmaps and didn't look \ for one for cursors. \ a is a relative address of a zString for file name, \ f is resource type (IMAGE_ICON, IMAGE_BITMAP, or IMAGE_CURSOR) \ returns handle to resource : GetResource ( a f -- handle) 2>R LR_LOADFROMFILE 0 0 R> R> NULL Call LoadImage DUP ?WinError ; \ create an icon resource from file : GetIconResource ( a -- handle) IMAGE_ICON GetResource ; \ create a bitmap resource from file : GetBmpResource ( a -- handle) IMAGE_BITMAP GetResource ; \ create a cursor resource from file : GetCurResource ( a -- handle) IMAGE_CURSOR GetResource ; Comment: ------------------------------------------------------ Stack Frame Code To address concerns raised by Tom Zimmer regarding storage and reentrancy in my routines I have adopted an approach similar to the way MASM handles it. In MASM the directive LOCAL generates a stack frame with enough room for the structure being declared. My initial attempts at this are admittedly crude, but will give me something to play with for a now. After experimenting a while, I may come up with a more elegant approach. ------------------------------------------------------ Comment; \ create a stack frame on the parameter stack for u cells, addr \ is to top-of-stack item, x1. Since stack grows down in \ Win32Forth, this is the address to the start of the structure. : sFrame ( u -- xn .. x2 x1 addr) \ u<=100 100 MIN 0 MAX 0 ?DO 0 LOOP sp@ ; \ for creating an initialized stack frame 0 VALUE OldStackPtr : StartFrame ( -- ) \ start creating an initialized stack frame OldStackPtr ABORT" Can't nest initialized stack frames" sp@ TO OldStackPtr ; : EndFrame ( -- addr) \ end an initialized stack frame, \ returning address of start of structure OldStackPtr 0= ABORT" No initialized stack frame started" sp@ ; : ReclaimFrame ( xn ... x2 x1 -- ) \ return stack to state \ prior to stack frame OldStackPtr sp! 0 TO OldStackPtr ; Comment: ------------------------------------------------------ Usage StartFrame ICC_DATE_CLASSES 8 EndFrame Call InitCommonControlsEx ?WinError ReclaimFrame Could also try something like putting the stack frame on the return stack Before After return address of a routine that cleans up the xt2 xt3 <== return stack before dropping through to xt2 xt1 u <== number of items to remove from the return stack x1 x2 ... xn xt2 xt1 This would allow several frames to be created and kept around and they would automagically delete themselves when the word that created them return to the word that called it. ------------------------------------------------------ Comment; --- NEW FILE: Statbar.f --- \ File: Statbar.f \ Author: Jeff Kelm \ Created: 24-Sep-1998 \ Updated: August 17th, 2003 dbu \ Classes to handle Statusbars (simple and multipart) Comment: Revision History (most recent first) August 17th, 2003 dbu - Changed to use in WinEd 2.21.05 and later 19981231 - Incorporated the new ChildWindow class. 19981216 - Removed Redraw: SetStyle: GetStyle: methods, now handled in BasicWin.f - Changed SetSimple: to eliminate flag and created SetMulti: to make up for it 19981117 - General cosmetic updates - redefined to use BaseWindow superclass and call BasicWin.f - eliminated SetParent: from Create: set by CreateStatusWindow now Comment; NEEDS BasicWin.f CR .( Loading Statusbar class for the Console window...) \ Notes: \ 1) SBARS_SIZEGRIP don't appear to work. Always shows up with the size grip \ box. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Simple Statusbar Class \ :Class Console_Statusbar <Super Console_ChildWindow INT BorderStyle \ style of border to use :M DefStyle: ( -- style) \ default control style [ WS_VISIBLE WS_CHILD OR ] literal ;M :M DefClassName: ( -- ClassName) \ default class name Z" msctls_statusbar32" ;M :M Create: ( hParent) \ creates an empty statusbar in parent window Create: super 0 TRUE SB_SIMPLE SendMessage: self DROP ;M comment: :Class Statusbar <Super BaseWindow INT BorderStyle \ style of border to use :M DefStyle: ( -- style) \ override if another style is needed WS_BORDER WS_VISIBLE OR \ WS_CHILD is forced ;M comment; :M RaisedBorder: ( -- ) \ text drawn below border (default) 0 TO BorderStyle ;M :M NoBorder: ( -- ) \ text drawn at border level (no border) SBT_NOBORDERS TO BorderStyle ;M :M SunkenBorder: ( -- ) \ text drawn above border SBT_POPOUT TO BorderStyle ;M :M ClassInit: ( -- ) \ initialize class ClassInit: super RaisedBorder: self \ default, text lower than border ;M comment: :M Create: ( hParent) \ creates an empty statusbar in parent window CreateNewID \ Statusbar ID SWAP NULL \ initial string to display DefStyle: self WS_CHILD OR \ style Call CreateStatusWindow DUP PutHandle: self ?WinError 0 TRUE SB_SIMPLE SendMessage: self DROP ;M comment; \ NULL MinHeight: self appears to reset to the default height statusbar :M MinHeight: ( #pixels) \ set minimum height of text region (not including borders) 0 SWAP SB_SETMINHEIGHT SendMessage: self DROP ;M :M GetBorders: ( -- hWidth vWidth divWidth) \ returns the border widths in pixels HERE 0 SB_GETBORDERS SendMessage: self ?WinError HERE DUP @ SWAP CELL+ DUP @ SWAP CELL+ @ ;M :M Redraw: ( -- ) \ redraw the statusbar after changes (e.g., size) 0 0 WM_SIZE SendMessage: self DROP ;M \ :M SetStyle: ( style) \ set style of statusbar "on the fly" \ GWL_STYLE GetHandle: self Call SetWindowLong DROP \ Redraw: self \ ;M \ :M GetStyle: ( -- style) \ get current style of statusbar \ GWL_STYLE GetHandle: self Call GetWindowLong \ ;M :M SetText: ( szText) \ sets simple status bar text 255 BorderStyle OR SB_SETTEXT SendMessage: self ?WinError ;M :M Clear: ( -- ) \ clears text from status window Z" " SetText: self ;M ;Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Multipart Statusbar Class \ :Class Console_MultiStatusbar <Super Console_Statusbar INT nParts \ number of parts in statusbar INT aWidths \ address of widths table :M Create: ( hParent) Create: super 0 FALSE SB_SIMPLE SendMessage: self DROP ;M :M SetParts: ( aWidths nParts) \ width table address and count TO nParts TO aWidths aWidths nParts SB_SETPARTS SendMessage: self ?WinError ;M :M GetParts: ( -- aWidths nParts) \ retrieve data structure info aWidths nParts ;M :M SetSimple: ( flag) \ sets status bar to show single-part 0 TRUE SB_SIMPLE SendMessage: self DROP ;M :M SetMulti: ( flag) \ sets status bar to show multiparts 0 FALSE SB_SIMPLE SendMessage: self DROP ;M :M SetText: ( szText n) \ set text in n'th part BorderStyle OR \ was SB_SETTEXT SendMessage: self DROP ( is) SB_SETTEXT SendMessage: self ?WinError ;M ;Class --- NEW FILE: ConsoleStatbar.f --- \ $Id: ConsoleStatbar.f,v 1.1 2007/05/08 08:08:44 georgeahubert Exp $ \ File: ConsoleStatbar.f \ Author: Dirk Busch \ Created: September 26th, 2003 - 10:30 dbu \ Updated: January 22nd, 2004 - 10:43 dbu \ Statusbar for the Win32Forth console window needs Statbar.f \ Status bar Class by Jeff Kelm \ anew -ConsoleStatbar.f INTERNAL \ ***************************************************************************** \ window class for the status bar \ ***************************************************************************** :Object ConsoleStatusbar <Super Console_MultiStatusbar create MultiWidth 80 , -1 , \ width of statusbar parts 0 value forth-sp 0 value forth-depth 0 value forth-base 8 value display-depth \ # of stack entries that are displayed :M Create: ( hParent -- ) Create: super GetHandle: self if MultiWidth 2 SetParts: self Show: self then ;M :M SetSP: ( n -- ) to forth-sp ;M :M SetDepth: ( n -- ) to forth-depth ;M :M SetBase: ( n -- ) to forth-base ;M :M SetDisplayDepth: ( n -- ) to display-depth ;M :M SetText: ( a n -- ) \ set text a for part n swap dup +null 1+ swap SetText: super ;M :M Update: { \ buf$ buf1$ pad$ -- } MAXSTRING LocalAlloc: buf$ \ temp string buffer MAXSTRING LocalAlloc: buf1$ \ temp string buffer MAXSTRING LocalAlloc: pad$ \ a place to save PAD pad pad$ MAXSTRING move \ save PAD, (.) not reentrant hld @ >r \ save HLD, (.) not reentrant \ print base s" Base: " buf$ place forth-base case 2 of s" binary" buf$ +place endof 8 of s" octal" buf$ +place endof 10 of s" decimal" buf$ +place endof 16 of s" hex" buf$ +place endof defaultof decimal forth-base (.) buf$ +place forth-base base ! endof endcase buf$ 0 SetText: self \ print stack from left to right (right is TOS) s" Stack: " buf$ place forth-depth 0= if s" empty " buf$ +place else \ display stack depth BASE @ >R DECIMAL s" {" buf$ +place forth-depth (.) buf$ +place s" } " buf$ +place R> BASE ! \ display stack entries 0 forth-depth 1- display-depth 1- min do i cells forth-sp + @ (.) buf$ +place s" " buf$ +place -1 +loop then \ print Floating point stack from left to right (right is TOS) s" | Floating point stack: " buf$ +place fdepth 0= if s" empty" buf$ +place else \ display Stack depth BASE @ >R DECIMAL s" {" buf$ +place fdepth (.) buf$ +place s" } " buf$ +place R> BASE ! \ display stack entries display-depth fdepth umin dup 1- swap 0 DO dup i - fpick buf1$ (g.) buf1$ count buf$ +place s" " buf$ +place \ JvdV, July 26th, 2004 added a seperator LOOP drop then buf$ 1 SetText: self \ update status bar r> hld ! \ restore HLD pad$ pad MAXSTRING move \ restore PAD ;M ;Object \ ***************************************************************************** \ hook's for the interpreter \ ***************************************************************************** : Update-Console-Statusbar ( -- ) \ update the status bar GetHandle: ConsoleStatusbar if depth SetDepth: ConsoleStatusbar sp@ SetSP: ConsoleStatusbar base @ SetBase: ConsoleStatusbar source-id 0= if Update: ConsoleStatusbar then then ; : Console-Statusbar-interpret ( -- ) \ hook for INTERPRET _interpret Update-Console-Statusbar ; EXTERNAL \ changed to use the reset-stack-chain \ January 22nd, 2004 - 13:53 dbu : Console-Statusbar-reset-stacks ( ?? -- ) \ hook for RESET-STACKS TURNKEYED? NOT \in-system-ok if Update-Console-Statusbar then ; reset-stack-chain chain-add CONSOLE-STATUSBAR-RESET-STACKS INTERNAL \ ***************************************************************************** \ hook for the console window proc \ ***************************************************************************** 0 value &Console-Window-Proc \ addr of the org console window proc 4 Callback: Console-Statusbar-WindowProc ( hwnd msg wparam lparam -- res ) \ redraw our status bar if needed 2 PICK WM_WINDOWPOSCHANGED = if Redraw: ConsoleStatusbar then \ and call the org console window proc 4reverse &Console-Window-Proc Call CallWindowProc ; \ ***************************************************************************** \ set number of stack entries that are displayed in the status bar \ ***************************************************************************** : Console-SetDisplayDepth ( n -- ) SetDisplayDepth: ConsoleStatusbar ; \ ***************************************************************************** \ INIT-CONSOLE \ ***************************************************************************** : M_INIT_CONS ( -- ) _conHndl Create: ConsoleStatusbar GetHandle: ConsoleStatusbar if \ hook into the interpreter ['] Console-Statusbar-interpret is interpret \ sublassing of the console window ['] Console-Statusbar-WindowProc GWL_WNDPROC _conHndl Call SetWindowLong to &Console-Window-Proc \ and update the status bar Update-Console-Statusbar then ; m_init_cons : M_INIT-CONSOLE ( -- f ) \ create console window X_INIT-CONSOLE dup 0<> if M_INIT_CONS \ create the status bar then ; ' M_INIT-CONSOLE is INIT-CONSOLE MODULE --- NEW FILE: BasicWin.f --- \ File: BasicWin.f \ Author: Jeff Kelm \ Created: 17-Nov-1998 \ Updated: August 17th, 2003 dbu \ Defines some basic window classes Comment: Revision History (most recent first) August 17th, 2003 dbu - Changed to use in WinEd 2.21.05 and later 19990519 - Modify to use 'stack frames' instead of HERE for temp storage. Items marked ( fix) have not yet been properly handled. 19990422 - Removed the changes on 990412, didn't work. Added more to text in PutHandle: for debugging 19990412 - Add equivalent to InitCommonControls to ChildWindow, Create: to try to correct a problem with turnkeying under Win95 reported by Mar...@t-... (Martin Bitter). 19990315 - Changed GetClientSize: to give ( x y) stack arguments (had incorrectly given (y x) stack). 19990218 - GetStyleEx: changed to GetExStyle: in +/-ExStyle: 19990128 - Rename StyleEx to ExStyle in several places. - Change logic of -Style/StyleEx: so that it doesn't set a flag if it wasn't already set (was XOR, now INVERT AND). - Extended styles can be NULL which gives errors in Get/SetStyleEx: and +/-StyleEx: from Get/SetWindowLong: which test returned results with ?WinError. 19981231 - Incorporated the new ChildWindow class. 19981216 - Change stack ordering to ( x y) for Get/SetPosition: and Get/SetSize: - replaced GetHandle: self with hWnd 19981208 - Added Get/SetText: methods 19981207 - Added SetFocus: method 19981204 - Added -Style: and -StyleEx: methods 19981202 - Added +Style: and +StyleEx: methods - Rename GetWindowSize: to GetSize: for consistency 19981120 - Changed ?WinError to DROP in Enable: & Disable: methods 19981117 - separated these from WinBase.f where they had been defined. - General cosmetic updates - Added some validity checking to PutHandle: and Destroy: - Added methods to BaseWindow (SetID: GetStyle: SetStyle: GetStyleEx: GetWindowProc: SetWindowProc: Enable: Disable: IsVisible:) - Removed BaseChildWindow and incorporate functionality into BaseWindow. - Renamed BaseChildWindow to ChildWindow MoveTo: to SetPosition: Resize: to SetSize: GetWindowPos: to GetPosition: - Remove GetClientRect: (GetClientSize: provides same functionality) Comment; NEEDS WinBase.f CR .( Loading Base Window classes...) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ A basic window class with some primative methods \ :Class Console_BaseWindow <Super Object INT hWnd \ the window handle :M GetHandle: ( -- hWnd) \ return the window handle hWnd ;M :M PutHandle: ( hWnd) \ set the window handle DUP Call IsWindow 0= ABORT" Nonexistent window handle" TO hWnd ;M :M SendMessage: ( lparam wparam msg -- result) hWnd Call SendMessage ;M :M Show: ( -- ) \ show the window SW_SHOW hWnd Call ShowWindow DROP ;M :M Hide: ( -- ) \ hide the window SW_HIDE hWnd Call ShowWindow DROP ;M :M GetWindowLong: ( offset -- n) \ get window memory \ contents at offset hWnd Call GetWindowLong ( GetWindowLong could return NULL, so don't ?WinError) ;M :M SetWindowLong: ( n offset) \ set window memory contents \ at offset hWnd Call SetWindowLong DROP ( SetWindowLong could return NULL, so don't ?WinError) ;M :M GetWindowRect: ( -- b r t l) \ get window bounding rect \ was HERE hWnd Call GetWindowRect ?WinError \ was HERE 3 CELLS + @ HERE 2 CELLS + @ HERE CELL+ @ HERE @ 4 sFrame \ save space on stack for RECT hWnd Call GetWindowRect ?WinError ( b r t l) ;M :M GetClientSize: ( -- cx cy) \ returns size of client area \ was HERE hWnd Call GetClientRect ?WinError \ was HERE 2 CELLS + @ HERE @ - \ was HERE 3 CELLS + @ HERE CELL+ @ - 4 sFrame \ save space on stack for RECT hWnd Call GetClientRect ?WinError ( b r t l) SWAP >R - SWAP R> - ;M :M GetSize: ( -- cx cy) \ returns size of window rectangle \ was HERE hWnd Call GetWindowRect ?WinError \ was HERE 2 CELLS + @ HERE @ - \ was HERE 3 CELLS + @ HERE CELL+ @ - GetWindowRect: self ( b r t l) SWAP >R - SWAP R> - ;M :M SetSize: ( cx cy) \ set size of window rectangle \ was SWAP 2>R SWP_NOOWNERZORDER SWP_NOMOVE OR ( is) SWAP 2>R [ SWP_NOZORDER SWP_NOMOVE OR ] literal 2R> 0 0 NULL hWnd Call SetWindowPos ?WinError ;M :M GetPosition: ( -- x y) \ return upper-left corner \ was HERE hWnd Call GetWindowRect ?WinError \ was HERE 2@ SWAP GetWindowRect: self 2NIP SWAP ;M :M SetPosition: ( x y) \ set position of upper-left corner \ was SWAP 2>R SWP_NOOWNERZORDER SWP_NOSIZE OR ( is) SWAP 2>R [ SWP_NOZORDER SWP_NOSIZE OR ] literal 0 0 2R> NULL hWnd Call SetWindowPos ?WinError ;M :M Destroy: ( -- ) \ destroy the window hWnd Call DestroyWindow DUP IF 0 TO hWnd THEN ?WinError ;M :M GetID: ( -- id) \ retrieve window identifier GWL_ID GetWindowLong: self ;M :M SetID: ( id) \ set the window identifier GWL_ID SetWindowLong: self ;M :M GetStyle: ( -- style) \ retrieve basic window style GWL_STYLE GetWindowLong: self ;M :M SetStyle: ( style) \ set the basic window style GWL_STYLE SetWindowLong: self ;M :M +Style: ( style) \ add to the basic window style GetStyle: self OR SetStyle: self ;M :M -Style: ( style) \ remove from the basic window style INVERT GetStyle: self AND SetStyle: self ;M :M GetExStyle: ( -- exStyle) \ retrieve extended styles GWL_EXSTYLE GetWindowLong: self ;M :M SetExStyle: ( exStyle) \ set the extended window style GWL_EXSTYLE SetWindowLong: self ;M :M +ExStyle: ( exStyle) \ add to the extended window style GetExStyle: self OR SetExStyle: self ;M :M -ExStyle: ( exStyle) \ add to the extended window style INVERT GetExStyle: self AND SetExStyle: self ;M :M GetParent: ( -- hParent) \ handle of parent window hWnd Call GetParent ;M :M SetParent: ( hWnd) \ change the parent window hWnd Call SetParent ?WinError ;M :M Enable: ( -- ) \ enables mouse and keyboard input to \ the window or control TRUE hWnd Call EnableWindow DROP ;M :M Disable: ( -- ) \ disables mouse and keyboard input to \ the window or control FALSE hWnd Call EnableWindow DROP ;M :M SetFocus: ( -- ) \ set keyboard focus to this window hWnd Call SetFocus DROP ;M :M IsVisible: ( -- f) \ ff=window not visible hWnd Call IsWindowVisible ;M :M SetText: ( szText) \ send text to window/control hWnd Call SetWindowText ?WinError ;M :M GetText: ( -- a n) \ get window/control text ( fix) MAXSTRING HERE hWnd Call GetWindowText DUP ?WinError HERE SWAP ;M ;Class :Class Console_ChildWindow <Super Console_BaseWindow :M DefStyle: ( -- style) \ default control style [ WS_VISIBLE WS_CHILD OR ] literal ;M :M DefExStyle: ( -- exStyle) \ default extended style NULL ;M :M DefClassName: ( -- ClassName) \ default class name Z" STATIC" ;M :M DefSize: ( -- cx cy) \ default window size CW_USEDEFAULT CW_USEDEFAULT ;M :M DefPosition: ( -- x y) \ default window position CW_USEDEFAULT CW_USEDEFAULT ;M :M Create: ( hParent -- ) \ create a child of parent window >R NULL \ creation parameters AppInst \ instance handle CreateNewID \ menu handle/control ID R> \ parent window DefSize: [ self ] SWAP \ window size ( h w) DefPosition: [ self ] SWAP \ window pos ( y x ) DefStyle: [ self ] \ window style NULL \ window title DefClassName: [ self ] \ class name DefExStyle: [ self ] \ extended window style Call CreateWindowEx DUP TO hWnd ?WinError ;M ;Class |