Menu
▾
▴
win32forth-cvs
|
From: George H. <geo...@us...> - 2007-05-03 09:11:37
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv29733/win32forth-stc/src Added Files: CHILDWND.F CONTROL.F CONTROLS.F Dialog.f WINMSG.F xfiledlg.f Log Message: gah:Ported Control.f and Dialog.f to STC. Added other working Class files --- NEW FILE: WINMSG.F --- \ $Id: WINMSG.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ WINMSG.F Windows Message Window Class by Tom Zimmer Require window.f cr .( Loading Message Window...) :Class MSGWINDOW <super window int cols int rows int ontop? int msgactive int msg-string int msg-length :M Classinit: ( -- ) ClassInit: super s" One Moment Please!" to msg-length to msg-string 50 to OriginX 50 to OriginY 0 to cols 0 to rows 0 to msgactive 0 to ontop? ;M :M OnTop: ( f1 -- ) \ should window float on top? to ontop? ;M :M GetActive: ( -- f1 ) \ is the message window active msgactive ;M :M Close: ( -- ) \ close if its open msgactive if Close: super false to msgactive then ;M :M Start: ( -- ) \ create a new window object Close: self register-frame-window drop create-frame-window to hWnd SW_SHOWNOACTIVATE Show: self Update: self SetFocus: self true to msgactive ;M :M WindowStyle: ( -- style ) \ return the window style [ WS_OVERLAPPED WS_CAPTION or WS_THICKFRAME or ] literal ;M :M ExWindowStyle: ( -- extended_style ) ExWindowStyle: super WS_EX_DLGMODALFRAME or ontop? \ is this a modal message? if WS_EX_TOPMOST or \ if so, lock on top then ;M :M WindowTitle: ( -- Zstring ) Z" One Moment Please!" ;M :M MessageText: ( a1 n1 -- ) to msg-length to msg-string 1 to rows msg-string msg-length begin 2dup 0x0D scan 2dup 2>r nip - nip cols max to cols 2r> dup while rows 1+ to rows \ bump row count 2 /string \ and skip CRLF repeat 2drop ;M :M On_Paint: { \ vpos -- } 25 to vpos msg-string msg-length begin dup while 2dup 0x0D scan 2dup 2>r nip - 20 vpos 2swap TextOut: dc 2r> 2 /string vpos 18 + to vpos repeat 2drop ;M :M StartSize: ( -- width height ) \ starting window size cols 9 * 10 + 200 max rows 16 * 50 + ;M :M MinSize: ( -- width height ) StartSize: [ self ] ;M :M MaxSize: ( -- width height ) StartSize: [ self ] ;M :M Refresh: ( -- ) hWnd \ only if not if StartPos: self StartSize: self Move: self Paint: self then ;M ;Class msgwindow msg-window INTERNAL : _message-off ( -- ) Close: msg-window ; ' _message-off is message-off EXTERNAL : message-on ( -- ) GetActive: msg-window if Refresh: msg-window else Start: msg-window then ; : message-origin ( x y -- ) SetOrigin: msg-window ; INTERNAL : ("message) ( f -- ) \ display message window OnTop: msg-window MessageText: msg-window Start: msg-window ; : _"message ( a1 n1 -- ) \ a floating non-modal message box message-off -if FALSE ("message) else 2drop then ; ' _"message is "message : _"top-message ( a1 n1 -- ) \ a floating ON-TOP message box message-off -if TRUE ("message) else 2drop then ; ' _"top-message is "top-message EXTERNAL : zmessage ( z& -- ) MAXCOUNTED 2dup 0 scan nip - "message ; INTERNAL (( InfoWindow implements a class of window that is used to display tooltip messages when the mouse is held over a button. InfoWindow is used inside CONTROL.F in class Control, to implement tooltips. Info window is really just a simple unframed window that allows you to put up some text on the screen at a specified location. The Close: method will take the window down. The window size is automatically adjusted to the text that you put in the window, and handles strings that contain "\n" new line designators. )) :Object InfoWindow <Super MSGWINDOW \ *G Used for old style tool tips. GdiFont msgFont int extentx int extenty 4 cells bytes &InfoRect ColorObject TIPCOLOR 7 constant fwidth 9 constant fheight :M ClassInit: ( -- ) ClassInit: super 0 to extentx 0 to extenty fwidth SetWidth: msgFont fheight SetHeight: msgFont s" MS Sans Serif" SetFaceName: msgFont COLOR_INFOBK Call GetSysColor NewColor: TIPCOLOR ;M :M On_Init: ( -- ) On_Init: super Create: msgFont ;M :M On_Done: ( -- ) Destroy: msgFont On_Done: super ;M :M StartSize: ( -- width height ) \ starting window size extentx extenty ;M :M On_Paint: { \ vpos msgmax -- } SaveDC: dc GetHandle: msgFont SetFont: dc &InfoRect GetClientRect: self Brush: TIPCOLOR &InfoRect GetHandle: dc call FillRect ?win-error TRANSPARENT SetBkMode: dc 0 to vpos 0 to msgmax 0 to extentx msg-string msg-length begin dup while 2dup 0x0D scan 2dup 2>r nip - 2r> 2swap 2dup GetTextExtent: dc >r 3 + extentx max to extentx \ new max width 0 vpos 2swap TextOut: dc 2 /string r> vpos + to vpos vpos 3 + to extenty repeat 2drop RestoreDC: dc ;M :M WindowStyle: ( -- style ) \ return the window style WS_POPUPWINDOW ;M :M ExWindowStyle: ( -- extended_style ) WS_EX_TOOLWINDOW ;M :M Start: ( c"string" x y -- ) rot count to msg-length to msg-string screen-size fheight 4 + - rot min -rot \ clip vertical msg-string msg-length \ actual string 2dup 0x0D scan nip - nip \ len of first line fwidth * - min swap \ clip horizontal SetOrigin: self \ set window origin Close: self register-frame-window drop create-frame-window to hWnd SW_SHOWNOACTIVATE Show: self Update: self true to msgactive OriginX OriginY StartSize: self Move: self ;M ;Object MODULE --- NEW FILE: xfiledlg.f --- \ $Id: xfiledlg.f,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ load print/open replacements for xcalls cr .( Loading Filedialog Functions...) Require Utils.f anew -xfiledlg.f \ ------------------- Common Open/Save/New Dialog funcs ---------------------- WINLIBRARY COMDLG32.DLL internal 1 PROC GetOpenFileName as fdlg-open ( addr -- rc ) 1 PROC GetSaveFileName as fdlg-save ( addr -- rc ) 1 PROC CommDlgExtendedError create ofn-struct 19 cells , 22 CELLS allot \ OPENFILENAME struct \ This struct can be 22 cells for Windows 2000/XP, but NT or less demands 19? \ Lowest common denominator - have gone for 19. : fdlg-filter ( abs-addr -- abs-addr ) \ change all | to \0 in filter dup begin dup c@ ?dup \ fetch char while \ if not end of string [char] | = if 0 over c! then \ make a \0 char+ \ next char repeat drop \ loose addr ; : fdlg-build ( filename diraddr titleaddr specaddr owner -- ) ofn-struct lcount erase \ clear structure ofn-struct cell+ ! \ save owner in hwnd fdlg-filter \ modify filter ofn-struct 3 cells+ ! \ save filter in filter string 1 ofn-struct 6 cells+ ! \ filterindex=1 ofn-struct 12 cells+ ! \ save title ofn-struct 11 cells+ ! \ save initial dir 1+ ofn-struct 7 cells+ ! \ save initial filename maxcounted ofn-struct 8 cells+ ! \ file length ; : fdlg-getfile ( -- filename ) \ fetch filename ofn-struct 7 cells+ @ \ fetch returned filename ; : fdlg-adjfile ( -- filename ) \ adjust filename returned fdlg-getfile \ fetch returned filename dup maxcounted 0 scan drop \ find end of string over - over 1- c! 1- \ adjust filename to cstr ; : fdlg-nofile ( -- filename ) \ return null filename fdlg-getfile \ fetch returned filename 1- 0 over c! \ null string ; : fdlg-openf ( -- ) \ set open flags in struct [ OFN_PATHMUSTEXIST OFN_FILEMUSTEXIST OR OFN_HIDEREADONLY OR OFN_SHAREAWARE OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-newf ( -- ) \ set open flags in struct [ OFN_PATHMUSTEXIST OFN_HIDEREADONLY OR OFN_SHAREAWARE OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-savef ( -- ) \ set save flags in struct [ OFN_OVERWRITEPROMPT OFN_HIDEREADONLY OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-call ( xt -- filename ) \ call GetxxxxFileName ofn-struct swap execute if fdlg-adjfile \ return filename else call CommDlgExtendedError ?dup if ." Error: GetxxxxFileName failed RC=0x" h. abort else fdlg-nofile \ no file to return then then ; : open-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build \ build ofn-struct fdlg-openf \ set open flags ['] fdlg-open fdlg-call \ call dialog ; \ rls February 4th, 2002 - 5:47 : open-dialog2 ( filterindx filenam diradr titleadr specadr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-openf \ set open flags ['] fdlg-open fdlg-call \ call dialog ; : save-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build fdlg-savef \ set save flags ['] fdlg-save fdlg-call \ call dialog ; : save-dialog2 ( filterindx filename diraddr titleaddr specaddr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-savef \ set save flags ['] fdlg-save fdlg-call \ call dialog ; : new-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build \ build ofn-struct fdlg-newf \ set new flags ['] fdlg-open fdlg-call \ call dialog ; \ rls February 4th, 2002 - 20:18 : new-dialog2 ( filterindex filename diraddr titleaddr specaddr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-newf \ set new flags ['] fdlg-open fdlg-call \ call dialog ; external : get-filter-Index ( -- n ) ofn-struct 6 cells+ @ \ get filter index ; internal \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ File dialog Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Class FileDialogs <Super Object max-handle bytes szFile max-handle bytes szDir int szFilter int szTitle :M ClassInit: ( -- ) ClassInit: super 0 szDir ! 0 szFile ! here 1+ to szTitle ,"text" max-handle here szTitle - - allot \ extend to max string here 1+ to szFilter ,"text" \ lay in filter, then max-handle here szFilter - - allot \ extend to max string ;M \ Changed to allow Filenames and path's not only in uppercase \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) :M SetDir: ( a1 n1 -- ) \ set the dialog directory string max-handle 2 - min szDir place \ lay in the directory szDir +NULL \ null terminate \ szDir count upper \ make path uppercase - dbu szDir ?-\ \ remove trailing \ ;M :M GetDir: ( -- a1 n1 ) \ get the current dialog directory string szDir count ;M :M SetTitle: ( a1 n1 -- ) szTitle 1- place \ lay in new string szTitle 1- +NULL \ null terminate it ;M \ a new file filter string would be in the following format, with vertical \ bars separating filter name from filter spec, and between filter spec \ and succeeding filter names. \ A maximum of 255 characters is allowed for the total filter specs string \ s" Forth Files (*.f)|*.f|Text Files (*.txt)|*.txt|All Files (*.*)|*.*|" :M SetFilter: ( a1 n1 -- ) \ set new file filter spec szFilter 1- place \ lay in new string szFilter 1- +NULL \ null terminate it ;M :M GetFilter: ( -- a1 n1 ) \ return current file filter string szFilter 1- count ;M \ Changed to allow Filenames and path's not only in uppercase \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) : run-dialog ( owner_handle dialog-func-cfa -- a1 ) 2>r szFile count "to-pathend" szFile place szFile +NULL szFile \ takes a counted string for filename szDir 1+ szTitle szFilter 2r> execute dup count "path-only" szDir place ; ;Class EXTERNAL :Class FileNewDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] new-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] new-dialog2 run-dialog ;M ;Class :Class FileOpenDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] open-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] open-dialog2 run-dialog ;M ;Class :Class FileSaveDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] save-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] save-dialog2 run-dialog ;M ;Class module --- NEW FILE: Dialog.f --- \ $Id: Dialog.f,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ *D doc\classes\ \ *! Dialog \ *T Dialog -- Class for dialog boxes. require generic.f cr .( Loading Dialog Box...) \ *S Load Dialog Resource File \ *P The .RES file structure is a series of records. Each record contains \ ** a header and a data field. The structure of a header is as follows: \ *L \ *| offset | length | | \ *| 0 | 4 | length of data field | \ *| 4 | 4 | length of header | \ *| 10 | 2 | record type | \ *| 14 | 2 | dialog ID number (for dialogs) | : dialogID? ( hdr ID -- f ) \ *G Given the address of a header in a resource file, return true if this \ ** is the header for a dialog resource. I'm only guessing here. over 14 + w@ = \ does ID match swap 10 + w@ 5 = and ; \ is this also a dialog : ?dlgerr ( ior -- ) abort" Error loading dialog resource" ; \ April 18th, 1996 tjz switched to LONG count from WORD count : find-dialog-ID ( id addr -- address-of-template-header ) \ *G Find dialog template given address and length of resource file in memory. swap >r lcount begin over r@ dialogID? if rdrop \ discard the ID drop \ discard the length \ return the template header address EXIT \ ALL DONE, LEAVE then over 2@ + aligned /string dup 0= until 2drop r> cr ." Looking for dialog: " . true ?dlgerr ; \ Read resource file and return address and length of dialog template. in-system \ April 18th, 1996 tjz switched to LONG count from WORD count \ September 21st, 2003 - 13:44 dbu changed to use "open instead of n"open : read-dialog ( name namelen -- ) "open ?dlgerr >r r@ file-size 2drop here ! here lcount dup cell+ allot \ room for file and word cnt r@ read-file ?dlgerr 0= ?dlgerr r> close-file ?dlgerr ; \ changed to work with blanks in file name \ January 31st, 2004 - 20:38 dbu : load-dialog ( -<filename-without-an-extension>- ) \ *G Load template from dialog resource (*.res) to here and allot memory. \n \ ** Usage: load-dialog dialog { \ ld-buf -- } maxstring localalloc: ld-buf >in @ >r \ save the input pointer bl word c@ ( name-max-chars ) 255 > \ check filename length abort" Dialog files are limited to 255 chars" r> >in ! \ restore the input pointer create last @ count \ name length 2dup ld-buf place \ lay in filename s" .res" ld-buf +place \ add extension name.res ld-buf count read-dialog \ load resource file s" fload '" ld-buf place \ load header file ( a1 n1 ) ld-buf +place \ Append filename s" .h'" ld-buf +place \ add extension name.h ld-buf count evaluate postpone \ ; \ ignore rest of line in-application \ *W <a name="Dialog"></a> \ *S Dialog Class :CLASS Dialog <SUPER Dialog&Control \ *G Dialog class. \n \ ** To use this class you have to create a ressource file (*.res) whitch must contain \ ** the dialog resource. Since Win32Forth doesn't provide any tool's to create a dialog \ ** resource you should use ForthForm to create your dialog windows instead. 4 callback: DialogProc ( hwnd msg wparam lparam -- res ) GWL_USERDATA 4 pick Call GetWindowLong ( object address ) ?dup 0= if 2 pick WM_INITDIALOG <> if 0 exit then dup \ window object pointer from \ lparam of DialogBoxIndirectParam 4 pick ( obj hwnd ) 2dup GWL_USERDATA swap Call SetWindowLong drop \ save obj pointer over ! \ set hWnd parameter of window struc then 3 pick ( msg ) over obj>class MFA ((findm)) if MethodExecute else 0 then ; \ 4 callback DialogProc (DialogProc) \ TEMPLATE has been changed to be the template header address, instead of \ the address of the template it self, so we can move the template into \ globally allocated memory : run-dialog { parent template \ tmplhndl -- f } self ['] DialogProc parent 0 <> \ if parent is not zero parent conhndl <> and \ and parent is not the console handle if GetHandle: parent \ then use the specified parent else conhndl \ else use the console for the parent then template 2@ + malloc to tmplhndl template dup cell+ @ + \ from tmplhndl template @ move \ move the length tmplhndl \ new way, template handle appInst Call DialogBoxIndirectParam tmplhndl release ; \ -------------------- Helpers -------------------- :M Start: ( parent -- flag ) \ *G Open the dialog GetTemplate: [ self ] run-dialog ;M :M EndDialog: ( return-value -- ) \ *G Close the dialog hwnd Call EndDialog drop ;M : end-dialog ( value -- flag ) EndDialog: [ self ] 1 ; \ -------------------- Initialization -------------------- :M WM_INITDIALOG swap On_Init: [ self ] ;M :M On_Init: ( hwndfocus -- f ) \ *G Init the dialog drop 1 ;M \ -------------------- Process Commands from Controls -------------------- :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over HIWORD ( notification code ) rot LOWORD ( ID ) On_Command: [ self ] ;M :M On_Command: ( hCtrl code ID -- f ) \ *G Process Commands from Controls case IDOK of 1 end-dialog endof IDCANCEL of 0 end-dialog endof false swap ( default result ) endcase ;M ;Class \ *G End of Dialog class \ December 11th, 2003 jeh, In order to use ModelessDialog you must extend the \ class and add your own GetTemplate method. ( -- template | tmplhndl ) \ The common implementation is to also create a constant to hold \ The template associated with each instance of the class although this is \ not required, only the GetTemplate method is required. \ *W <a name="ModelessDialog"></a> \ *S Modless Dialog class :Class ModelessDialog <SUPER Dialog \ *G Modless Dialog class \n \ ** To use this class you have to create a ressource file (*.res) whitch must contain \ ** the dialog resource. Since Win32Forth doesn't provide any tool's to create a dialog \ ** resource you should use ForthForm to create your dialog windows instead. int hTemplate :M ClassInit: ( -- ) ClassInit: super 0 to hTemplate +dialoglist ;M :M WindowStyle: ( -- n1 ) \ *G Get the window style of the dialog. GetTemplate: [ self ] dup if dup cell+ @ + @ then ;M :M ExWindowStyle: ( -- n1 ) \ *G Get the extended window style of the dialog. GetTemplate: [ self ] dup if dup cell+ @ + cell+ @ then ;M :M Origin: ( -- x y ) \ *G Get the origin (upper left corner) of the dialog. GetTemplate: [ self ] ?dup if dup cell+ @ + 2 cells+ 2 + @ word-split else 0 0 then ;M : run-modeless-dialog { parent template \ tmplhndl -- hwnd tmplhndl } self ['] DialogProc parent 0 <> \ if parent is not zero parent conhndl <> and \ and parent is not the console handle if GetHandle: parent \ then use the specified parent else conhndl \ else use the console for the parent then template 2@ + malloc to tmplhndl template dup cell+ @ + \ from tmplhndl template @ move \ move the length WindowStyle: [ self ] tmplhndl ! ExWindowStyle: [ self ] tmplhndl cell+ ! Origin: [ self ] word-join tmplhndl 2 cells+ 2 + ! tmplhndl \ new way, template handle appInst Call CreateDialogIndirectParam SW_SHOW over Call ShowWindow drop dup Call UpdateWindow drop dup Call SetFocus drop tmplhndl ; :M Start: ( parent -- ) \ *G Open the dialog hTemplate 0= if GetTemplate: [ self ] run-modeless-dialog to hTemplate to hWnd else drop SetFocus: self then ;M :M EndDialog: ( n1 -- ) \ *G Close the dialog drop DestroyWindow: self ;M :M WM_DESTROY ( -- result ) hTemplate release 0 to hTemplate 0 to hwnd 0 ;M :M WM_CLOSE ( -- ) DestroyWindow: Self ;M :M ~: ( -- ) -dialoglist ;M ;Class \ *G End of ModlessDialog class \ *Z --- NEW FILE: CONTROLS.F --- \ $Id: CONTROLS.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ CONTROLS.F Additional controls by Freidrick Prinz \ September 7th, 1999 - 22:48 tjz corrected a bug reported by Jos v.c. Ven, \ seems I forgot to initialize the super class of EditControl when I added \ some enhancements. \ July 29th, 1999 - 15:16 tjz enhanced EditControl and ComboControl to \ make them generalized enough to put an edit field on a ToolBar. \ January 9th, 1996 - 13:57 tjz Modified and updated both this file and \ Win32Forth to make this kind of thing easier. Added CONTROL.F to the \ Win32Forth system \ *D doc\classes\ \ *! Controls \ *T Controls -- Classes for standard windows controls. Require Control.f cr .( Loading Low Level Controls...) \ *W <a name="EditControl"></a> \ *S EditControl class :Class EditControl <Super CONTROL \ *G Class for Edit controls. \ ** An edit control is a rectangular control window typically used in a dialog \ ** box to permit the user to enter and edit text by typing on the keyboard. \ pointers to filter function to allow key capturing. int pWmChar \ function returns '0' if it handled message, non-zero otherwise int pWmKeyDown \ function returns '0' if it handled message, non-zero otherwise int pWmKillFocus \ function returns '0' if it handled message, non-zero otherwise \ For backwards compatibility synonym ClientRect wRect synonym ClientRect.addrof wRect.addrof synonym ClientRect.left wRect.left synonym ClientRect.right wRect.right synonym ClientRect.top wRect.top Synonym ClientRect.bottom wRect.bottom :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: Super 0 to pWmChar 0 to pWmKeyDown 0 to pWmKillFocus ;M :M StartSize: ( -- width height ) \ *G Get the start size of the control. Default size is 100 x 25. 100 25 ;M :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. Default style is: \ ** WS_BORDER, WS_TABSTOP and ES_AUTOHSCROLL. WindowStyle: SUPER [ WS_BORDER WS_TABSTOP OR ES_AUTOHSCROLL OR ] literal OR \ allow horizontal scrolling ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" EDIT" Create-Control ;M :M SetWmChar: ( pWmChar -- ) \ *G Install the WM_CHAR filter function. to pWmChar ;M :M SetWmKeyDown: ( pWmKeyDown -- ) \ *G Install the WM_KEYDOWN filter function. to pWmKeyDown ;M \ *P Install these filter functions if you want to capture certain keys, like \ ** Return or F3, or whatever. :M SetWmKillFocus: ( pWmKillFocus -- ) \ *G Install the WM_KILLFOCUS filter function. to pWmKillFocus ;M :M SubClass: ( hWnd Parent -- ) \ *G Subclass this control. to parent to hWnd subclass ;M : ?pexecute ( hwnd msg wparm lparm pfunction -- result ) -IF self swap execute -IF DROP old-wndproc CallWindowProc THEN ELSE drop old-wndproc CallWindowProc THEN ; :M WM_CHAR ( h m w l -- res ) \ normal & control chars pWmChar ?pexecute ;M (( \ example function to process WM_CHAR messages : myWmChar ( h m w l obj -- res ) 2 pick VK_RETURN = IF GetText: [ ] \ get adr,len of edit control text ...<process WM_CHAR message>... FALSE \ we already processed this message ELSE drop \ discard object TRUE \ and use default processing THEN ; )) :M WM_KEYDOWN ( h m w l -- res ) \ normal & control chars pWmKeyDown ?pexecute ;M :M WM_KILLFOCUS ( h m w l -- res ) \ Allow intervention on kill focus pWmKillFocus ?pexecute ;M :M WM_SETCURSOR { hndl msg wparam lparam -- res } EraseRect: WinRect \ init to zeros AddrOf: WinRect GetClientRect: self hWnd get-mouse-xy Top: WinRect Bottom: WinRect between over Left: WinRect Right: WinRect between and IF ibeam-cursor 1 ELSE DROP hndl msg wparam lparam DefaultWindowProc THEN ;M ;Class \ *G End of EditControl class \ *W <a name="ComboControl"></a> \ *S ComboControl class :Class ComboControl <Super CONTROL \ *G Class for editable combo box controls. EditControl ComboEdit :M StartSize: ( -- width height ) \ *G Get the start size of the control 100 100 ;M :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: \ ** CBS_DROPDOWN, WS_VSCROLL, WS_TABSTOP, WS_VISIBLE and ES_AUTOHSCROLL. WindowStyle: SUPER [ CBS_DROPDOWN WS_VSCROLL OR WS_TABSTOP OR WS_VISIBLE OR ES_AUTOHSCROLL OR ] literal OR ;M \ Install these filter functions if you want to capture certain keys, like \ Return or F3, or whatever. :M SetWmChar: ( pWmChar -- ) \ *G install the WM_CHAR filter function for the EditControl of the combo box. SetWmChar: ComboEdit ;M :M SetWmKeyDown: ( pWmKeyDown -- ) \ *G install the WM_KEYDOWN filter function for the EditControl of the combo box. SetWmKeyDown: ComboEdit ;M :M SetWmKillFocus: ( pWmKillFocus -- ) \ *G install the WM_KILLFOCUS filter function for the EditControl of the combo box. SetWmKillFocus: ComboEdit ;M :M InsertString: ( adr len -- ) \ *G Insert a string into the combo box hWnd NULL = \ must have a valid handle IF 2drop \ just discard if not running ELSE 2dup SetText: ComboEdit asciiz dup 0 CB_FINDSTRINGEXACT GetID: self SendDlgItemMessage: parent dup CB_ERR = \ if it's not in list IF DROP 0 CB_INSERTSTRING GetID: self SendDlgItemMessage: parent drop 0 0 CB_SETCURSEL \ set first as current item GetID: self SendDlgItemMessage: parent drop ELSE NIP \ discard string 0 swap CB_SETCURSEL \ set found item as current item GetID: self SendDlgItemMessage: parent drop THEN THEN ;M :M GetString: ( adr index -- ) \ *G Use: GetString: to get indexed items out of the combo box string list \ ** Use: GetText: to get the current combo box string. swap dup>r 1+ swap CB_GETLBTEXT GetID: self SendDlgItemMessage: parent 0 max r> c! ;M :M GetCount: ( -- n1 ) \ *G Use: GetCount: to get the count of items in the combo box string list. 0 0 CB_GETCOUNT GetID: self SendDlgItemMessage: parent 0 max ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" COMBOBOX" Create-Control \ new subclass the embedded EditControl, so we can handle WM_CHAR & WM_KEYDOWN \ messages to capture keys like Return and F3. 5 5 hWnd Call ChildWindowFromPoint self SubClass: ComboEdit 0 0 CB_RESETCONTENT GetID: self SendDlgItemMessage: parent drop ;M ;Class \ *G End of ComboControl class \ *W <a name="ComboListControl"></a> \ *S ComboListControl class :Class ComboListControl <Super ComboControl \ *G Class for select only combo box controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: CBS_DROPDOWNLIST. WindowStyle: SUPER CBS_DROPDOWNLIST OR ;M ;Class \ *G End of ComboListControl class \ *W <a name="ListControl"></a> \ *S ListControl class :Class ListControl <Super CONTROL \ *G Class for list box controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: WS_VSCROLL, \ ** LBS_NOTIFY, LBS_NOINTEGRALHEIGHT and WS_TABSTOP. WindowStyle: SUPER [ WS_VSCROLL LBS_NOTIFY OR LBS_NOINTEGRALHEIGHT OR WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" LISTBOX" Create-Control ;M ;Class \ *G End of ListControlControl class \ *W <a name="GroupControl"></a> \ *S GroupControl control class :Class GroupControl <Super CONTROL \ *G Class for group controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: BS_GROUPBOX. WindowStyle: SUPER BS_GROUPBOX OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of GroupControl class \ *W <a name="StaticControl"></a> \ *S StaticControl control class :Class StaticControl <Super CONTROL \ *G Class for static controls. :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" STATIC" Create-Control ;M ;Class \ *G End of StaticControl class \ *W <a name="CheckControl"></a> \ *S CheckControl control class :Class CheckControl <Super CONTROL \ *G Class for check box controls. :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_AUTOCHECKBOX, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_AUTOCHECKBOX WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of CheckControl class \ *W <a name="RadioControl"></a> \ *S RadioControl control class :Class RadioControl <Super CONTROL \ *G Class for radio button controls. :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_AUTORADIOBUTTON, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_AUTORADIOBUTTON WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of RadioControl class \ *W <a name="ButtonControl"></a> \ *S ButtonControl control class :Class ButtonControl <Super CONTROL \ *G Class for push button controls. int buttonfunc :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super ['] noop to buttonfunc ;M :M SetFunc: ( cfa -- ) \ *G Set the button function. This function es executed when the \ ** button is pressed whith a click with the left mouse button to buttonfunc ;M :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_PUSHBUTTON, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_PUSHBUTTON WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. to Parent z" BUTTON" Create-Control ;M :M WM_LBUTTONUP ( h m w l -- res ) hWnd get-mouse-xy hWnd in-button? if buttonfunc execute then old-wndproc CallWindowProc ;M ;Class \ *G End of ButtonControl class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Dialog Window Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="DialogWindow"></a> \ *S Dialog Window Class :CLASS DialogWindow <Super Window \ *G Base class for windows that contain controls. :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super +dialoglist ;M :M ~: ( -- ) -dialoglist ~: super ;M ;Class \ *G End of DialogWindow class \ *Z \s ********* SAMPLE Follows ********* SAMPLE Follows ********* \ ********* SAMPLE Follows ********* SAMPLE Follows ********* \ ********* SAMPLE Follows ********* SAMPLE Follows ********* 0 value check1 :OBJECT EditSample <Super DialogWindow EditControl Edit_1 \ an edit window StaticControl Text_1 \ a static text window ButtonControl Button_1 \ a button ButtonControl Button_2 \ another button CheckControl Check_1 \ a check box RadioControl Radio_1 \ a radio button RadioControl Radio_2 \ another radio button : CloseSample ( -- ) Close: [ self ] ; :M ExWindowStyle: ( -- style ) ExWindowStyle: SUPER ;M :M WindowStyle: ( -- style ) WindowStyle: SUPER [ WS_BORDER WS_OVERLAPPED OR ] literal or ;M :M WindowTitle: ( -- title ) z" " ;M :M StartSize: ( -- width height ) 200 100 ;M :M StartPos: ( -- x y ) 3 3 ;M :M On_Init: ( -- ) On_Init: super self Start: Check_1 4 25 60 20 Move: Check_1 s" Hello" SetText: Check_1 self Start: Radio_1 80 25 80 20 Move: Radio_1 s" Hello2" SetText: Radio_1 GetStyle: Radio_1 \ get the default style WS_GROUP OR SetStyle: Radio_1 \ Start a group self Start: Radio_2 80 45 120 20 Move: Radio_2 s" Hello Again" SetText: Radio_2 self Start: Text_1 \ start up static text GetStyle: Text_1 \ get the default style [ WS_GROUP SS_CENTER OR WS_BORDER OR ] literal OR \ start a group and centre SetStyle: Text_1 \ and border to style 4 4 192 20 Move: Text_1 \ position the window s" Sample Text" SetText: Text_1 \ set the window message self Start: Edit_1 3 72 60 25 Move: Edit_1 s" 000,00" SetText: Edit_1 IDOK SetID: Button_1 self Start: Button_1 110 72 36 25 Move: Button_1 s" OK" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 self Start: Button_2 150 72 45 25 Move: Button_2 s" Beep" SetText: Button_2 ['] beep SetFunc: Button_2 ;M :M On_Paint: ( -- ) \ screen redraw procedure 0 0 width height LTGRAY FillArea: dc ;M :M Close: ( -- ) GetText: Edit_1 cr type cr Close: SUPER ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD ( ID ) case IDOK of Close: self endof GetID: Check_1 of GetID: Check_1 IsDlgButtonChecked: self to check1 beep endof endcase 0 ;M ;OBJECT : demo ( -- ) Start: EditSample ; --- NEW FILE: CHILDWND.F --- \ $Id: CHILDWND.F,v 1.1 2007/05/03 09:10:48 georgeahubert Exp $ \ *D doc\classes\ \ *! Childwnd \ *T Child-Window -- Base class for all child windows \ *S Glossary cr .( Loading Child Window...) only forth also definitions needs window.f :CLASS Child-Window <Super Window \ *G Child-Window is the base class for all child windows. \ *P The windows has a parent, which is the object address, \ ** not the window handle. This allows the child to send \ ** messages to its parent. int id \ id for this child window \ int Parent \ object address of the parent window \ Note: this ivar was moved into the window class some time ago. \ Altough it's not realy needed in the window class I (dbu) left \ it there in order not to break too much code (Sonntag, Juni 04 2006 dbu). :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to id ;M :M SetParent: ( parent -- ) \ *G Set the object address of the parent window. Parent ;M :M GetParent: ( -- parent ) \ *G Get the object address of the parent window. Parent ;M :M SetID: ( n -- ) \ *G Set the ID for this child window. to id ;M :M GetID: ( -- n ) \ *G Get the ID for this child window. id ;M \ To change the minimum window size, override the MinSize: method. \ :M MinSize: ( -- width height ) 0 0 ;M \ override to change \ :M StartSize: ( -- width height ) 0 0 ;M \ override to change \ :M StartPos: ( -- left top ) 0 0 ;M \ override to change \ -------------------- Create Child Window -------------------- \ The child window class has the following properties: \ Private device context (OWNDC) \ Black background \ No icon : register-child-window ( -- f ) \ Register the window class for this child window. WndClassStyle: [ self ] to Style TheWndProc to WndProc 0 to ClsExtra 4 to WndExtra appInst to hInstance NULL to hIcon IDC_ARROW NULL Call LoadCursor to hCursor NULL to hbrBackground NULL to MenuName \ Set the window class name for this child window. Every window \ will become it's own class name and it's own window class. default-class-name WindowClassName 1+ to ClassName register-the-class ; : GetParentWindow ( -- hWnd ) \ Get the parent window handle for this child window. \ If this window has no parent the window of the console is used as the parent. \ If no console is pressent the parent handle will be NULL. Parent if GetHandle: parent else conhndl then \ make shure that we have a valid window handle \ and tell the super class about it. dup call IsWindow 0= if drop NULL then dup SetParentWindow: super ; : create-child-window ( -- hWnd ) \ Create this child window. ^base \ creation parameters appInst \ program instance id \ child id GetParentWindow \ parent window handle StartSize: [ self ] swap \ height, width StartPos: [ self ] swap \ y, x starting position WindowStyle: [ self ] \ the window style WindowTitle: [ self ] \ the window title WindowClassName 1+ \ class name ExWindowStyle: [ self ] \ extended window style Call CreateWindowEx ; :M WindowStyle: ( -- style ) \ *G User windows should override the WindowStyle: method to \ ** set the window style. Default is WS_CHILD and WS_VISIBLE. [ WS_CHILD WS_VISIBLE or ] literal ;M :M WindowTitle: ( -- Zstring ) \ *G User windows should override the WindowTitle: method to \ ** set the window caption. Default is "". z" " ;M \ we don't want a name, pass NULL :M Start: ( Parent -- ) \ *G Create this child window. Parent is the object address of the \ ** parent window. to Parent register-child-window drop create-child-window dup to hWnd if SW_SHOWNORMAL Show: self then ;M :M AutoSize: ( -- ) \ *G Size the window to fit into the client area of the parent window. tempRect.AddrOf GetClientRect: Parent 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M ;Class \ *G End of Child-Window class \ *Z --- NEW FILE: CONTROL.F --- \ $Id: CONTROL.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ *D doc\classes\ \ *! Control \ *T Control -- Class for child controls with subclassing. Require WinMsg cr .( Loading Control Window...) \ child controls with subclassing DEFER SUBCLASS-WNDPROC :NONAME 4DROP 0 ; IS SUBCLASS-WNDPROC \ ------------------------------------------------------------------------ \ ----------------- ITC Only --------------------------------------------- \ ------------------------------------------------------------------------ \ NCODE SUBCLASS-RETURN \ CODE-HERE CELL+ CODE-, \ itc \ mov eax, ebx \ C return value \ mov esp, ebp \ restore stack \ pop ebp \ restore registers \ pop ebx \ pop edi \ pop esi \ ret # 4 CELLS \ return & discard params \ c; \ CFA-CODE SUBCLASS-ENTRY ( lparam wparam message hwnd -- result ) \ push esi \ save registers \ push edi \ push ebx \ push ebp \ mov ebx, ecx \ address of object \ mov ebp, esp \ make forth stacks \ sub esp, # 4000 \ room for return stack \ push 5 CELLS [ebp] \ hwnd \ push 6 CELLS [ebp] \ message \ push 7 CELLS [ebp] \ wparam \ push 8 CELLS [ebp] \ lparam \ xor edi, edi \ EDI is constant 0 \ mov edx, fs: 0x14 \ edx is now ptr from TIB pvArbitrary \ mov esi, # ' SUBCLASS-RETURN \ mov eax, # ' SUBCLASS-WNDPROC \ exec c; \ ------------------------------------------------------------------------ \ -------------------------- STC Only ------------------------------------ \ ------------------------------------------------------------------------ CODE SUBCLASS-ENTRY ( lparam wparam message hwnd -- result ) push esi \ save registers push edi push ebx push ebp mov eax, ecx \ address of object mov ebp, esp \ make forth stacks sub ebp, # 4000 \ room for return stack mov edi, 5 CELLS [esp] \ hwnd mov -4 [ebp], edi mov edi, 6 CELLS [esp] \ message mov -8 [ebp], edi mov edi, 7 CELLS [esp] \ wparam mov -12 [ebp], edi mov edi, 8 CELLS [esp] \ lparam mov -16 [ebp], edi lea ebp, -16 [ebp] mov ebx, fs: 0x14 \ ebx is now ptr from TIB pvArbitrary call ' SUBCLASS-WNDPROC pop ebp \ restore registers pop ebx pop edi pop esi ret # 4 CELLS \ return & discard params c; : CallWindowProc ( hwnd msg wparam lparam wndproc -- result ) >r 4reverse r> Call CallWindowProc ; \ -------------------- Control Class -------------------- \ Support for displaying tool tips; used by the oldstyle buttonbars (e.g. in WinEd). \ Since we have a much better toolbar class in Win32Forth for some time now, I \ (dbu) didn't spend the time to see how this works. And so I didn't document it. INTERNAL \ definitions accessible while defining a buttonbar 0 value &binfo \ pointer to latest defined button create &ButtonRect 4 cells allot \ temp rectangle for current info msg &ButtonRect 4 cells erase create &CursorPoint 2 cells allot &CursorPoint 2 cells erase 255 constant max-binfo \ longest info message allowed : ButtonInfo" ( -- ) \ set the info for latest button or control &binfo 0= abort" Must follow a button definition" '"' word count max-binfo min &binfo place &binfo count \n->crlf ; EXTERNAL \ definitions always accessible TRUE value info-flag \ are we displaying tool tips FALSE value mouse-is-down? : get-mouse-xy { hWnd -- x y } &CursorPoint Call GetCursorPos drop &CursorPoint hWnd Call ScreenToClient drop &CursorPoint @ &CursorPoint cell+ @ ; : in-button? { x y hWnd -- f1 } &ButtonRect hWnd Call GetClientRect drop y &ButtonRect 1 cells+ @ \ 2 + \ top &ButtonRect 3 cells+ @ \ 2 - \ bottom between x &ButtonRect @ \ 2 + \ left &ButtonRect 2 cells+ @ \ 2 - \ right between and ; \ *W <a name="Control"></a> \ *S Generic Control class :Class Control <Super Dialog&Control \ *G Generic control class. \n \ ** Since Control is a generic class it should not be used to create \ ** any instances. \ The following definition must directly precede old-wndproc to work correctly code (old-wndproc) ( ^control -- old-wndproc ) \ address of old window prodedure add eax, # ^class DFA @ mov eax, [eax] next ;c int old-wndproc \ address of old window procedure int parent \ address of parent object int id \ the control's ID int title \ the counted title string int handleofparent \ the frame window handle int Horizontal int Vertical int timering? \ are we opening a popup info window int timerclosed? \ has popup been closed int auto-close? \ does info window automatically close after a time? max-binfo 1+ bytes binfo 32768 value unique-id# : unique-id ( -- id ) \ get a unique initial ID for this control unique-id# 1 +to unique-id# ; \ -------------------- Subclassed Window Procedure -------------------- : _subclass-WndProc ( hwnd msg wparam lparam window -- res ) 3 pick ( msg ) over obj>class MFA ((findm)) if sp0 @ >r sp@ 4 cells+ sp0 ! dup>r MethodCatch ?dup if r@ WndProcError then rdrop r> sp0 ! else (old-wndproc) CallWindowProc then ; ' _subclass-WndProc is subclass-WndProc \ -------------------- SubClassing -------------------- : subclass ( -- ) (controllock) code-here \ for SetWindowLong to pick up 0xC790 code-w, 0xC1 code-c, self code-, \ nop mov ecx, # object 0xE9 code-c, ['] SUBCLASS-ENTRY code-here CELL+ - code-, \ jmp (long) SUBCLASS-ENTRY (controlunlock) GWL_WNDPROC hWnd Call SetWindowLong to old-wndproc \ set ; :M ClassInit: ( -- ) ClassInit: super 0 to parent 0 to handleofparent 0 to old-wndproc unique-id to id z" " to title binfo off binfo to &binfo \ so we can set it later FALSE to timering? FALSE to timerclosed? TRUE to auto-close? ;M :M GetParent: ( -- parent ) \ *G Get the parent window of this control. parent ;M :M GetHandleOfParent: ( -- handleofparent ) \ *G Get the window handle of the parent window of this control. handleofparent ;M :M SetID: ( id -- ) \ *G Set the ID of this control. Normaly you don't need to do this, because \ ** every control get's an unique ID when it's created. to id ;M :M GetID: ( -- id ) \ *G Get the ID of this control id ;M :M ExWindowStyle: ( -- exstyle ) \ *G Get the extended window style of this control 0 ;M :M WindowStyle: ( -- style ) \ *G Get the window style of this control [ WS_CHILD WS_VISIBLE or ] literal ;M :M StartSize: ( -- width height ) \ *G Get the start size of this control. \n \ ** Override this method to change it. 0 0 ;M \ :M StartPos: ( -- left top ) \ *G Get the start position of this control. \n \ ** Override this method to change it. 0 0 ;M :M AutoSize: ( -- ) \ *G Size the window to fit into the client area of the parent window. tempRect.AddrOf GetClientRect: Parent 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M :M CreateStruct: ( -- CreateStrucPointer ) \ *G This pointer to a structure, depends on what kind of window you are \ ** creating, so we just default it to NULL. NULL ;M : create-control ( z"classname" -- ) >r CreateStruct: [ self ] \ override if needed appInst ID GetHandle: Parent dup to handleofparent StartSize: [ self ] swap \ height, width StartPos: [ self ] swap \ y, x starting position WindowStyle: [ self ] \ you can override these title 1+ \ the control's text r> \ the class name zstring ExWindowStyle: [ self ] \ the extended window style Call CreateWindowEx to hWnd hWnd if subclass then ; \ Support for displaying tool tips; used by the oldstyle buttonbars (e.g. in WinEd). \ Since we have a much better toolbar class in Win32Forth for some time now, I \ (dbu) didn't spend the time to see how this works. And so I didn't document it. 1 constant INFO_START_TIMER \ timer constant 2 constant INFO_END_TIMER \ timer constant 3 constant INFO_CLOSE_TIMER \ timer constant : clear-info ( -- ) INFO_START_TIMER hWnd Call KillTimer drop INFO_END_TIMER hWnd Call KillTimer drop INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? FALSE to timerclosed? Close: InfoWindow ; :M BInfo: ( -- a1 ) \ return the counted string of button info binfo ;M :M SetAutoClose: ( flag -- ) \ set the state of the automatic info close feature to auto-close? ;M :M GetAutoClose: ( -- flag ) auto-close? ;M :M WM_TIMER ( h m w l -- res ) hWnd get-mouse-xy to Vertical to Horizontal over INFO_START_TIMER = mouse-is-down? 0= and IF INFO_START_TIMER hWnd Call KillTimer drop Horizontal Vertical hWnd in-button? \ if timer and still on button timering? and IF 1 to timering? BInfo: [ self ] &ButtonRect hWnd Call GetWindowRect drop &ButtonRect @ Horizontal + &ButtonRect cell+ @ Vertical + 25 + Start: InfoWindow NULL 100 INFO_END_TIMER hWnd Call SetTimer drop GetAutoClose: [ self ] IF NULL 4000 INFO_CLOSE_TIMER hWnd Call SetTimer drop THEN ELSE FALSE to timering? THEN THEN over INFO_END_TIMER = IF Horizontal Vertical hWnd in-button? 0= IF INFO_END_TIMER hWnd Call KillTimer drop INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? Close: InfoWindow FALSE to timerclosed? THEN THEN over INFO_CLOSE_TIMER = IF INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? TRUE to timerclosed? Close: InfoWindow THEN 0 ;M :M amForground?: ( -- f1 ) TRUE ;M :M On_MouseMove: ( h m w -- ) info-flag \ are we displaying tool tips? BInfo: [ self ] c@ and \ and there is text to display IF hWnd get-mouse-xy hWnd in-button? \ in the button ... [truncated message content] |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X