Menu
▾
▴
win32forth-cvs
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14461/apps/ForthForm Modified Files: ABOUT.F CONTROLPROPERTYII.ff CreateMenu.f CreatePropertyForm.f CreateToolBar.f CreateToolBarForm.ff EXAMPLE.F FORMCONTROLS.F FORMOBJECT.F FORMPROPERTY.F FORMPROPERTY.ff FORMTOOLBAR.F FORTHFORM.F FormHelp.f FormMenu.f FormPad.f Forms.frm PREFERENCES.ff RECT.F SplitterWindow.f TABORDER.F TESTEXAMPLE.F Added Files: EXAMPLEII.ff EXAMPLEII.frm ExampleII.f FormMonitor.f JoinStr.f New Files.txt Splitter1.f Splitter2.f Splitter3.f Splitter4.f Splitter5.f Splitter6.f Log Message: ForthForm updates. EAB --- NEW FILE: Splitter5.f --- \ ForthForm generated splitter-window template \ Modify according to your needs :Object TopPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Pane" Textout: dc ;M ;Object :Object BottomLeftPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Left Pane" Textout: dc ;M ;Object :Object BottomRightPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Right Pane" Textout: dc ;M ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Bar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ COLOR_BTNFACE Call GetSysColor new-color BTNFACE :Class SplitterBar <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height BTNFACE FillArea: dc ;M :M On_Init: ( -- ) \ Remove CS_HREDRAW and CS_VREDRAW styles from all instances of \ class Child-Window to prevent flicker in window on sizing. CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ;Class SplitterBar SplitterH SplitterBar SplitterV \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Window - the main window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any 200 value TopHeight 150 value LeftWidth 5 value ThicknessH 5 value ThicknessV :Object SplitterWindow <Super Window int dragging int mousedown : RightXpos ( -- n ) LeftWidth ThicknessV + ; : RightWidth ( -- n ) Width RightXpos - ; : SplitterYpos ( -- n ) ToolBarHeight TopHeight + ; : BottomYpos ( -- n ) SplitterYpos ThicknessH + ; : StatusBarYpos ( -- n ) height StatusbarHeight - ; : BottomHeight ( -- n ) StatusBarYpos BottomYpos - ; : TotalHeight ( -- n ) StatusBarYpos ToolBarHeight - ; : LeftWidthMin ( -- n ) LeftWidth width min ; : TopHeightMin ( -- n ) TopHeight TotalHeight min ; : position-windows ( -- ) 0 ToolBarHeight Width TopHeightMin Move: TopPane 0 BottomYpos LeftWidthMin BottomHeight Move: BottomLeftPane RightXpos BottomYpos RightWidth BottomHeight Move: BottomRightPane LeftWidth BottomYpos ThicknessV BottomHeight Move: SplitterV 0 SplitterYpos Width ThicknessH Move: SplitterH ; : Splitter ( -- n ) \ the splitter window the cursor is on hWnd get-mouse-xy dup ToolBarHeight StatusBarYpos within IF 2dup BottomYpos height within swap LeftWidth RightXpos within and IF 2drop 1 ELSE SplitterYpos BottomYpos within swap 0 width within and IF 2 ELSE 0 THEN THEN ELSE 2drop 0 THEN ; : On_Tracking ( -- ) \ set min and max values of LeftWidth and TopHeight here mousedown dragging or 0= ?EXIT dragging Case 1 of mousex 0max width min thicknessV 2/ - to LeftWidth endof 2 of mousey ToolBarHeight - 0max TotalHeight min thicknessH 2/ - to TopHeight endof EndCase position-windows WINPAUSE ; : On_Clicked ( -- ) mousedown not IF hWnd Call SetCapture drop THEN true to mousedown Splitter to dragging On_Tracking ; : On_Unclicked ( -- ) mousedown IF Call ReleaseCapture drop THEN false to mousedown false to dragging ; : On_DblClick ( -- ) false to mousedown Splitter 1 = IF LeftWidth 8 > IF 0 thicknessV 2/ - to LeftWidth ELSE Width thicknessV - 2/ to LeftWidth THEN position-windows THEN ; :M WM_SETCURSOR ( h m w l -- ) Splitter Case 0 of DefWindowProc: self endof 1 of SIZEWE-CURSOR 1 endof 2 of SIZENS-CURSOR 1 endof EndCase ;M :M Classinit: ( -- ) ClassInit: super \ init super class ['] On_Clicked SetClickFunc: self ['] On_Unclicked SetUnClickFunc: self ['] On_Tracking SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M \ :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) \ prevent flicker in window on sizing CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop self Start: TopPane self Start: BottomLeftPane self Start: BottomRightPane self Start: SplitterH self Start: SplitterV ;M ;Object \ start: SplitterWindow --- NEW FILE: Splitter4.f --- \ ForthForm generated splitter-window template \ Modify according to your needs :Object TopLeftPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Left Pane" Textout: dc ;M ;Object :Object TopRightPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Right Pane" Textout: dc ;M ;Object :Object BottomLeftPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Left Pane" Textout: dc ;M ;Object :Object BottomRightPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Right Pane" Textout: dc ;M ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Bar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ COLOR_BTNFACE Call GetSysColor new-color BTNFACE :Class SplitterBar <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height BTNFACE FillArea: dc ;M :M On_Init: ( -- ) \ Remove CS_HREDRAW and CS_VREDRAW styles from all instances of \ class Child-Window to prevent flicker in window on sizing. CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ;Class SplitterBar SplitterH SplitterBar SplitterV \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Window - the main window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any 200 value TopHeight 150 value LeftWidth 5 value ThicknessH 5 value ThicknessV :Object SplitterWindow <Super Window int dragging int mousedown : RightXpos ( -- n ) LeftWidth ThicknessV + ; : RightWidth ( -- n ) Width RightXpos - ; : SplitterYpos ( -- n ) ToolBarHeight TopHeight + ; : BottomYpos ( -- n ) SplitterYpos ThicknessH + ; : StatusBarYpos ( -- n ) height StatusbarHeight - ; : BottomHeight ( -- n ) StatusBarYpos BottomYpos - ; : TotalHeight ( -- n ) StatusBarYpos ToolBarHeight - ; : LeftWidthMin ( -- n ) LeftWidth width min ; : TopHeightMin ( -- n ) TopHeight TotalHeight min ; : position-windows ( -- ) 0 ToolBarHeight LeftWidthMin TopHeightMin Move: TopLeftPane RightXpos ToolBarHeight RightWidth TopHeightMin Move: TopRightPane 0 BottomYpos LeftWidthMin BottomHeight Move: BottomLeftPane RightXpos BottomYpos RightWidth BottomHeight Move: BottomRightPane LeftWidth ToolBarHeight ThicknessV TotalHeight Move: SplitterV 0 SplitterYpos Width ThicknessH Move: SplitterH ; : Splitter ( -- n ) \ the splitter window the cursor is on hWnd get-mouse-xy dup ToolBarHeight StatusBarYpos within IF 2dup SplitterYpos BottomYpos within swap 0 width within and IF 2drop 2 ELSE ToolBarHeight StatusBarYpos within swap LeftWidth RightXpos within and IF 1 ELSE 0 THEN THEN ELSE 2drop 0 THEN ; : On_Tracking ( -- ) \ set min and max values of LeftWidth and TopHeight here mousedown dragging or 0= ?EXIT dragging Case 1 of mousex 0max width min thicknessV 2/ - to LeftWidth endof 2 of mousey ToolBarHeight - 0max TotalHeight min thicknessH 2/ - to TopHeight endof EndCase position-windows WINPAUSE ; : On_Clicked ( -- ) mousedown not IF hWnd Call SetCapture drop THEN true to mousedown Splitter to dragging On_Tracking ; : On_Unclicked ( -- ) mousedown IF Call ReleaseCapture drop THEN false to mousedown false to dragging ; : On_DblClick ( -- ) false to mousedown Splitter 1 = IF LeftWidth 8 > IF 0 thicknessV 2/ - to LeftWidth ELSE Width thicknessV - 2/ to LeftWidth THEN position-windows THEN ; :M WM_SETCURSOR ( h m w l -- ) Splitter Case 0 of DefWindowProc: self endof 1 of SIZEWE-CURSOR 1 endof 2 of SIZENS-CURSOR 1 endof EndCase ;M :M Classinit: ( -- ) ClassInit: super \ init super class ['] On_Clicked SetClickFunc: self ['] On_Unclicked SetUnClickFunc: self ['] On_Tracking SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M \ :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) \ prevent flicker in window on sizing CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop self Start: TopLeftPane self Start: TopRightPane self Start: BottomLeftPane self Start: BottomRightPane self Start: SplitterH self Start: SplitterV ;M ;Object \ start: SplitterWindow Index: FormMenu.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FormMenu.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** FormMenu.f 20 Nov 2006 14:18:17 -0000 1.3 --- FormMenu.f 27 Dec 2006 18:43:57 -0000 1.4 *************** *** 7,11 **** --- 7,13 ---- MenuItem "&Open\tCtrl+O" doOpen ; :MenuItem mnu_doform "&Edit properties" doForm ; + :MenuItem mnu_close "Close Active &Form" ActiveForm if ActiveForm doCloseForm then ; + :MenuItem mnu_closeall "&Close All" doCloseAllForms ; MenuSeparator *************** *** 47,52 **** :MenuItem mnu_psheet "&Property Form Template" doPropertyForm ; MenuSeparator ! MenuItem "SciEdit&Mdi" Start-SciEditMdi ; ! MenuItem "Project Manager " Start-ProjectManager ; MenuSeparator MenuItem "&Save Session" doSaveSession ; --- 49,54 ---- :MenuItem mnu_psheet "&Property Form Template" doPropertyForm ; MenuSeparator ! MenuItem "Win32Forth IDE" Start-Win32ForthIDE ; ! \ MenuItem "Project Manager " Start-ProjectManager ; MenuSeparator MenuItem "&Save Session" doSaveSession ; *************** *** 78,88 **** then ; : ?EnableToolbarItems { flag -- } ! flag IDC_SAVE ?ChangeButton ! flag IDC_COPY ?ChangeButton ! flag IDC_COMPILE ?ChangeButton ! flag IDC_TEST ?ChangeButton ! flag IDC_EDITOR ?ChangeButton ! flag IDC_SAVEALL ?ChangeButton flag IDC_SELECT ?ChangeButton flag IDC_BITMAP ?ChangeButton --- 80,96 ---- then ; + : ?ChangeMainButton { flag id -- } \ if button with id is on bar perform flag operation + id CommandToIndex: TheMainToolbar 0< not \ -1 if not on bar + if flag id EnableButton: TheMainToolbar + then ; + + : ?EnableToolbarItems { flag -- } ! flag IDC_SAVE ?ChangeMainButton ! flag IDC_COPY ?ChangeMainButton ! flag IDC_COMPILE ?ChangeMainButton ! flag IDC_TEST ?ChangeMainButton ! flag IDC_EDITOR ?ChangeMainButton ! flag IDC_SAVEALL ?ChangeMainButton flag IDC_SELECT ?ChangeButton flag IDC_BITMAP ?ChangeButton *************** *** 133,143 **** dup Enable: mnu_bringfront dup Enable: mnu_moveback ! dup IDC_BACK ?ChangeButton ! dup IDC_FRONT ?ChangeButton ! dup IDC_DELETE ?ChangeButton ! IDC_TAB ?ChangeButton GetHandle: FFHelpwindow 0= dup Enable: mnu_hlp ! dup IDC_HELP ?ChangeButton not Enable: mnu_nohlp ; ' EnableMenuItems is UpdateSystem --- 141,151 ---- dup Enable: mnu_bringfront dup Enable: mnu_moveback ! dup IDC_BACK ?ChangeMainButton ! dup IDC_FRONT ?ChangeMainButton ! dup IDC_DELETE ?ChangeMainButton ! IDC_TAB ?ChangeMainButton GetHandle: FFHelpwindow 0= dup Enable: mnu_hlp ! dup IDC_HELP ?ChangeMainButton not Enable: mnu_nohlp ; ' EnableMenuItems is UpdateSystem Index: CONTROLPROPERTYII.ff =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/CONTROLPROPERTYII.ff,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 Binary files /tmp/cvsMQV4VQ and /tmp/cvssHOXDo differ Index: TABORDER.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/TABORDER.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** TABORDER.F 21 Dec 2004 00:18:45 -0000 1.1 --- TABORDER.F 27 Dec 2006 18:43:57 -0000 1.2 *************** *** 45,49 **** : UpTabList ( -- ) \ shift one up in list GetCurrent: TabList ?dup \ if not the first selection ! if dup>r GetString: TabList r@ DeleteString: TabList r@ dup 1- memswap \ order listbuffer --- 45,49 ---- : UpTabList ( -- ) \ shift one up in list GetCurrent: TabList ?dup \ if not the first selection ! if dup>r GetString: TabList r@ DeleteString: TabList r@ dup 1- memswap \ order listbuffer *************** *** 57,61 **** GetCurrent: TabList to cursel GetCount: TabList to cnt cursel cnt 1- 0max <> \ if not at end of list ! if cursel GetString: TabList cursel DeleteString: TabList cursel dup 1+ memswap \ order listbuffer --- 57,61 ---- GetCurrent: TabList to cursel GetCount: TabList to cnt cursel cnt 1- 0max <> \ if not at end of list ! if cursel GetString: TabList cursel DeleteString: TabList cursel dup 1+ memswap \ order listbuffer *************** *** 100,104 **** Call InitCommonControls drop ! Create: WinFont scrlup usebitmap \ create bitmap handle --- 100,104 ---- Call InitCommonControls drop ! Create: WinFont drop scrlup usebitmap \ create bitmap handle --- NEW FILE: Splitter2.f --- \ ForthForm generated splitter-window template \ Modify according to your needs :Object TopPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Pane" Textout: dc ;M ;Object :Object BottomPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Pane" Textout: dc ;M ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Bar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ COLOR_BTNFACE Call GetSysColor new-color BTNFACE :Class SplitterBar <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height BTNFACE FillArea: dc ;M :M On_Init: ( -- ) \ Remove CS_HREDRAW and CS_VREDRAW styles from all instances of \ class Child-Window to prevent flicker in window on sizing. CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ;Class SplitterBar SplitterH \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Window - the main window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any 200 value TopHeight 5 value ThicknessH :Object SplitterWindow <Super Window int dragging int mousedown : SplitterYpos ( -- n ) ToolBarHeight TopHeight + ; : BottomYpos ( -- n ) SplitterYpos ThicknessH + ; : StatusBarYpos ( -- n ) height StatusbarHeight - ; : BottomHeight ( -- n ) StatusBarYpos BottomYpos - ; : TotalHeight ( -- n ) StatusBarYpos ToolBarHeight - ; : TopHeightMin ( -- n ) TopHeight TotalHeight min ; : position-windows ( -- ) 0 ToolBarHeight Width TopHeightMin Move: TopPane 0 BottomYpos Width BottomHeight Move: BottomPane 0 SplitterYpos Width ThicknessH Move: SplitterH ; : Splitter ( -- n ) \ the splitter window the cursor is on hWnd get-mouse-xy dup ToolBarHeight StatusBarYpos within IF SplitterYpos BottomYpos within swap 0 width within and IF 1 ELSE 0 THEN ELSE 2drop 0 THEN ; : On_Tracking ( -- ) \ set min and max values of TopHeight here mousedown dragging or 0= ?EXIT dragging IF mousey ToolBarHeight - 0max TotalHeight min thicknessH 2/ - to TopHeight THEN position-windows WINPAUSE ; : On_Clicked ( -- ) mousedown not IF hWnd Call SetCapture drop THEN true to mousedown Splitter to dragging On_Tracking ; : On_Unclicked ( -- ) mousedown IF Call ReleaseCapture drop THEN false to mousedown false to dragging ; : On_DblClick ( -- ) false to mousedown Splitter 1 = IF TopHeight 8 > IF 0 thicknessH 2/ - to TopHeight ELSE TopHeight BottomHeight + thicknessH - 2/ to TopHeight THEN position-windows THEN ; :M WM_SETCURSOR ( h m w l -- ) Splitter Case 0 of DefWindowProc: self endof 1 of SIZENS-CURSOR 1 endof EndCase ;M :M Classinit: ( -- ) ClassInit: super \ init super class ['] On_Clicked SetClickFunc: self ['] On_Unclicked SetUnClickFunc: self ['] On_Tracking SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M \ :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) \ prevent flicker in window on sizing CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop self Start: TopPane self Start: BottomPane self Start: SplitterH ;M ;Object \ start: SplitterWindow Index: Forms.frm =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/Forms.frm,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Forms.frm 1 Nov 2005 23:14:04 -0000 1.4 --- Forms.frm 27 Dec 2006 18:43:57 -0000 1.5 *************** *** 33,41 **** \ if this form is a modal form a non-zero parent must be set :M ParentWindow: ( -- hwndparent | 0 if no parent ) ! parent ;M ! :M SetParent: ( hwndparent -- ) \ set owner window ! to parent ;M --- 33,41 ---- [...1541 lines suppressed...] *** 1815,1819 **** s" MS Sans Serif" SetFaceName: WinFont 8 Width: WinFont ! Create: WinFont \ set form color to system color --- 2051,2055 ---- s" MS Sans Serif" SetFaceName: WinFont 8 Width: WinFont ! Create: WinFont \ set form color to system color *************** *** 1828,1832 **** self Start: radTest 221 32 103 21 Move: radTest - WS_GROUP +Style: radTest Handle: Winfont SetFont: radTest s" Test" SetText: radTest --- 2064,2067 ---- --- NEW FILE: Splitter6.f --- \ ForthForm generated splitter-window template \ Modify according to your needs :Object TopLeftPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Left Pane" Textout: dc ;M ;Object :Object TopRightPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Top Right Pane" Textout: dc ;M ;Object :Object BottomPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Bottom Pane" Textout: dc ;M ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Bar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ COLOR_BTNFACE Call GetSysColor new-color BTNFACE :Class SplitterBar <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height BTNFACE FillArea: dc ;M :M On_Init: ( -- ) \ Remove CS_HREDRAW and CS_VREDRAW styles from all instances of \ class Child-Window to prevent flicker in window on sizing. CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ;Class SplitterBar SplitterH SplitterBar SplitterV \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Window - the main window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any 200 value TopHeight 150 value LeftWidth 5 value ThicknessH 5 value ThicknessV :Object SplitterWindow <Super Window int dragging int mousedown : RightXpos ( -- n ) LeftWidth ThicknessV + ; : RightWidth ( -- n ) Width RightXpos - ; : SplitterYpos ( -- n ) ToolBarHeight TopHeight + ; : BottomYpos ( -- n ) SplitterYpos ThicknessH + ; : StatusBarYpos ( -- n ) height StatusbarHeight - ; : BottomHeight ( -- n ) StatusBarYpos BottomYpos - ; : TotalHeight ( -- n ) StatusBarYpos ToolBarHeight - ; : LeftWidthMin ( -- n ) LeftWidth width min ; : TopHeightMin ( -- n ) TopHeight TotalHeight min ; : position-windows ( -- ) 0 ToolBarHeight LeftWidthMin TopHeightMin Move: TopLeftPane RightXpos ToolBarHeight RightWidth TopHeightMin Move: TopRightPane 0 BottomYpos Width BottomHeight Move: BottomPane LeftWidth ToolBarHeight ThicknessV TopHeight Move: SplitterV 0 SplitterYpos Width ThicknessH Move: SplitterH ; : Splitter ( -- n ) \ the splitter window the cursor is on hWnd get-mouse-xy dup ToolBarHeight StatusBarYpos within IF 2dup ToolBarHeight SplitterYpos within swap LeftWidth RightXpos within and IF 2drop 1 ELSE SplitterYpos BottomYpos within swap 0 width within and IF 2 ELSE 0 THEN THEN ELSE 2drop 0 THEN ; : On_Tracking ( -- ) \ set min and max values of LeftWidth and TopHeight here mousedown dragging or 0= ?EXIT dragging Case 1 of mousex 0max width min thicknessV 2/ - to LeftWidth endof 2 of mousey ToolBarHeight - 0max TotalHeight min thicknessH 2/ - to TopHeight endof EndCase position-windows WINPAUSE ; : On_Clicked ( -- ) mousedown not IF hWnd Call SetCapture drop THEN true to mousedown Splitter to dragging On_Tracking ; : On_Unclicked ( -- ) mousedown IF Call ReleaseCapture drop THEN false to mousedown false to dragging ; : On_DblClick ( -- ) false to mousedown Splitter 1 = IF LeftWidth 8 > IF 0 thicknessV 2/ - to LeftWidth ELSE Width thicknessV - 2/ to LeftWidth THEN position-windows THEN ; :M WM_SETCURSOR ( h m w l -- ) Splitter Case 0 of DefWindowProc: self endof 1 of SIZEWE-CURSOR 1 endof 2 of SIZENS-CURSOR 1 endof EndCase ;M :M Classinit: ( -- ) ClassInit: super \ init super class ['] On_Clicked SetClickFunc: self ['] On_Unclicked SetUnClickFunc: self ['] On_Tracking SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M \ :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) \ prevent flicker in window on sizing CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop self Start: TopLeftPane self Start: TopRightPane self Start: BottomPane self Start: SplitterH self Start: SplitterV ;M ;Object \ start: SplitterWindow Index: FORMPROPERTY.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORMPROPERTY.F,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** FORMPROPERTY.F 1 Nov 2005 23:14:04 -0000 1.4 --- FORMPROPERTY.F 27 Dec 2006 18:43:57 -0000 1.5 *************** *** 13,21 **** 0 value eActiveControl 0 value eActiveForm \ current form, not necessarily the ActiveForm ! /* ! : InhibitPropertyWindow ( -- ) ! frmEditProperties.hwnd 0= ?exit ! Close: frmEditProperties ; ! */ : IsTypeButton? { \ ctrltype -- f } GetType: eActiveControl to ctrltype --- 13,17 ---- 0 value eActiveControl 0 value eActiveForm \ current form, not necessarily the ActiveForm ! : IsTypeButton? { \ ctrltype -- f } GetType: eActiveControl to ctrltype *************** *** 30,52 **** \ Justification is invalid for some controls so we disable this feature if the control \ is a textbox, listbox or combobox ! GetType: eActiveControl dup>r ! TypeTextBox = ! r@ TypeListBox = or ! r@ TypeComboBox = or ! r@ TypeComboListBox = or ! r@ TypeHorizScroll = or ! r@ TypeVertScroll = or ! r> TypeMultiListBox = or dup not ! dup Enable: radLeft dup Enable: radCenter dup Enable: radRight dup Enable: radLefttext ! Enable: grpOrientation ; : LoadProperties ( -- ) GetName: eActiveControl SetText: txtName GetTitle: eActiveControl SetText: txtCaption ! Origin: eActiveControl (.) SetText: txtYpos (.) SetText: txtXpos ! Dimensions: eActiveControl (.) SetText: txtHeight (.) SetText: txtWidth GetToolTip: eActiveControl SetText: txtToolTip GetBitmap: eActiveControl SetText: txtBitmap --- 26,58 ---- \ Justification is invalid for some controls so we disable this feature if the control \ is a textbox, listbox or combobox ! GetType: eActiveControl ! | TypeTextBox ! TypeListBox ! TypeComboBox ! TypeComboListBox ! TypeHorizScroll ! TypeVertScroll ! TypeMultiListBox ! TypeFileWindow ! TypeTabControl ! |if false ! else true ! then dup Enable: radLeft dup Enable: radCenter dup Enable: radRight dup Enable: radLefttext ! dup Enable: grpOrientation ; ! ! : ?EnableSpinner ( -- ) ! GetType: eActiveControl TypeTextBox = dup Enable: chkSpinner ! if Spinner?: eActiveControl ! else false ! then Check: chkSpinner ; : LoadProperties ( -- ) GetName: eActiveControl SetText: txtName GetTitle: eActiveControl SetText: txtCaption ! Origin: eActiveControl SetValue: spnYpos SetValue: spnXpos ! Dimensions: eActiveControl SetValue: spnHeight SetValue: spnWidth GetToolTip: eActiveControl SetText: txtToolTip GetBitmap: eActiveControl SetText: txtBitmap *************** *** 55,58 **** --- 61,65 ---- Group?: eActiveControl Check: chkGroup Global?: eActiveControl Check: chkGlobal + ?EnableSpinner GetType: eActiveControl dup TypeBitmapButton = swap TypeStaticBitmap = or *************** *** 69,73 **** UnCheckButton: radRight UnCheckButton: radLeftText ! CheckTypeText 0= \ if it is a valid control if Orientation: eActiveControl case --- 76,80 ---- UnCheckButton: radRight UnCheckButton: radLeftText ! CheckTypeText \ if it is a valid control if Orientation: eActiveControl case *************** *** 90,101 **** GetText: txtName SetName: eActiveControl GetText: txtCaption SetTitle: eActiveControl ! GetText: txtXpos number? ! if drop else x then \ don't change if error ! GetText: txtYpos number? ! if drop else y then SetOrigin: eActiveControl ! GetText: txtwidth number? ! if drop else w then ! GetText: txtHeight number? ! if drop else h then SetDimensions: eActiveControl GetText: txtTooltip IsTooltip: eActiveControl GetType: eActiveControl dup --- 97,102 ---- GetText: txtName SetName: eActiveControl GetText: txtCaption SetTitle: eActiveControl ! GetValue: spnXpos GetValue: spnYpos SetOrigin: eActiveControl ! GetValue: spnWidth GetValue: spnHeight SetDimensions: eActiveControl GetText: txtTooltip IsTooltip: eActiveControl GetType: eActiveControl dup *************** *** 104,108 **** then IsButtonChecked?: chkGroup IsGroup: eActiveControl IsButtonChecked?: chkGlobal IsGlobal: eActiveControl ! \ justification IsTypeButton? --- 105,111 ---- then IsButtonChecked?: chkGroup IsGroup: eActiveControl IsButtonChecked?: chkGlobal IsGlobal: eActiveControl ! GetType: eActiveControl TypeTextBox = ! if IsButtonChecked?: chkSpinner IsSpinner: eActiveControl ! then \ justification IsTypeButton? *************** *** 119,123 **** then then IsOrientation: eActiveControl ! then Ismodified: eActiveForm \ update Update: eActiveControl \ everything UpdateStatus: eActiveForm \ at this time --- 122,127 ---- then then IsOrientation: eActiveControl ! then Validate: eActiveForm \ update ! Ismodified: eActiveForm \ and check Update: eActiveControl \ everything UpdateStatus: eActiveForm \ at this time *************** *** 190,197 **** FormName: ActiveForm count SetText: txtName FormTitle: ActiveForm count SetText: txtTitle ! Origin: ActiveForm (.) SetText: txtYpos ! (.) SetText: txtXpos ! Dimensions: ActiveForm (.) SetText: txtHeight ! (.) SetText: txtWidth GetModal: ActiveForm Check: ChkModal SaveScreen?: ActiveForm Check: chkSave --- 194,201 ---- FormName: ActiveForm count SetText: txtName FormTitle: ActiveForm count SetText: txtTitle ! Origin: ActiveForm SetValue: spnYpos ! SetValue: spnXpos ! Dimensions: ActiveForm SetValue: spnHeight ! SetValue: spnWidth GetModal: ActiveForm Check: ChkModal SaveScreen?: ActiveForm Check: chkSave *************** *** 221,232 **** GetText: txtName IsFormName: ActiveForm GetText: txtTitle IsFormTitle: ActiveForm ! GetText: txtXpos number? ! if drop else x then \ if invalid number reuse old value ! GetText: txtYpos number? ! if drop else y then SetOrigin: ActiveForm ! GetText: txtWidth number? ! if drop else w then ! GetText: txtHeight number? ! if drop else h then SetDimensions: ActiveForm IsButtonChecked?: chkModal SetModal: ActiveForm IsButtonChecked?: chkSave IsSaveScreen?: ActiveForm --- 225,230 ---- GetText: txtName IsFormName: ActiveForm GetText: txtTitle IsFormTitle: ActiveForm ! GetValue: spnXpos GetValue: spnYpos SetOrigin: ActiveForm ! GetValue: spnWidth GetValue: spnHeight SetDimensions: ActiveForm IsButtonChecked?: chkModal SetModal: ActiveForm IsButtonChecked?: chkSave IsSaveScreen?: ActiveForm *************** *** 250,253 **** --- 248,252 ---- GetHandle: ActiveForm AdjustWindowSize FormTitle: ActiveForm count Settext: ActiveForm + Validate: ActiveForm \ check everything is ok IsModified: ActiveForm DoUpdate *************** *** 263,272 **** :M On_Init: ( -- ) - - ES_NUMBER dup AddStyle: txtXPos - dup AddStyle: txtYPos - dup AddStyle: txtWidth - AddStyle: txtHeight - On_Init: super --- 262,265 ---- *************** *** 366,375 **** ['] PropertyFunc SetCommand: frmEditProperties - \ set these controls to accept only numbers - ES_NUMBER - dup AddStyle: txtXpos - dup AddStyle: txtYPos - dup AddStyle: txtWidth - AddStyle: txtHeight Addr: TabProperties Start: frmEditProperties ClientSize: TabProperties 2over d- Move: frmEditProperties --- 359,362 ---- *************** *** 384,387 **** --- 371,379 ---- 0 Addr: TabProperties ontab ;M + + :M ClassInit: ( -- ) + ClassInit: Super + self link-formwindow + ;M ;Object *************** *** 394,398 **** :Noname ( -- ) \ edit form properties ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParent: frmProperties++ Start: frmProperties++ 0 ShowTab: frmProperties++ \ show the form tab --- 386,390 ---- :Noname ( -- ) \ edit form properties ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParentWindow: frmProperties++ Start: frmProperties++ 0 ShowTab: frmProperties++ \ show the form tab *************** *** 401,405 **** :Noname ( -- ) \ edit control properties ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParent: frmProperties++ Start: frmProperties++ 1 ShowTab: frmProperties++ \ show the control tab --- 393,397 ---- :Noname ( -- ) \ edit control properties ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParentWindow: frmProperties++ Start: frmProperties++ 1 ShowTab: frmProperties++ \ show the control tab *************** *** 408,412 **** :Noname ( -- ) \ multiple action on controls ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParent: frmProperties++ Start: frmProperties++ 2 ShowTab: frmProperties++ \ show the action tab --- 400,404 ---- :Noname ( -- ) \ multiple action on controls ActiveForm 0= ?exit ! GetHandle: TheMainWindow SetParentWindow: frmProperties++ Start: frmProperties++ 2 ShowTab: frmProperties++ \ show the action tab --- NEW FILE: Splitter1.f --- \ ForthForm generated splitter-window template \ Modify according to your needs :Object LeftPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Left Pane" Textout: dc ;M ;Object :Object RightPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Paint: ( -- ) 0 0 Width Height white FillArea: dc 0 0 s" Right Pane" Textout: dc ;M ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Bar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ COLOR_BTNFACE Call GetSysColor new-color BTNFACE :Class SplitterBar <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height BTNFACE FillArea: dc ;M :M On_Init: ( -- ) \ Remove CS_HREDRAW and CS_VREDRAW styles from all instances of \ class Child-Window to prevent flicker in window on sizing. CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ;Class SplitterBar SplitterV \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter Window - the main window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any 150 value LeftWidth 5 value ThicknessV :Object SplitterWindow <Super Window int dragging int mousedown : RightXpos ( -- n ) LeftWidth ThicknessV + ; : RightWidth ( -- n ) Width RightXpos - ; : LeftWidthMin ( -- n ) LeftWidth width min ; : StatusBarYpos ( -- n ) height StatusbarHeight - ; : TotalHeight ( -- n ) Height ToolBarHeight - StatusBarHeight - ; : position-windows ( -- ) 0 ToolBarHeight LeftWidthMin TotalHeight Move: LeftPane RightXpos ToolBarHeight RightWidth TotalHeight Move: RightPane LeftWidth ToolBarHeight ThicknessV TotalHeight Move: SplitterV ; : Splitter ( -- n ) \ the splitter window the cursor is on hWnd get-mouse-xy ToolBarHeight StatusBarYpos within swap LeftWidth RightXpos within and IF 1 ELSE 0 THEN ; : On_Tracking ( -- ) \ set min and max values of LeftWidth here mousedown dragging or 0= ?EXIT dragging IF mousex 0max width min thicknessV 2/ - to LeftWidth THEN position-windows WINPAUSE ; : On_Clicked ( -- ) mousedown not IF hWnd Call SetCapture drop THEN true to mousedown Splitter to dragging On_Tracking ; : On_Unclicked ( -- ) mousedown IF Call ReleaseCapture drop THEN false to mousedown false to dragging ; : On_DblClick ( -- ) false to mousedown Splitter 1 = IF LeftWidth 8 > IF 0 thicknessV 2/ - to LeftWidth ELSE Width thicknessV - 2/ to LeftWidth THEN position-windows THEN ; :M WM_SETCURSOR ( h m w l -- ) Splitter Case 0 of DefWindowProc: self endof 1 of SIZEWE-CURSOR 1 endof EndCase ;M :M Classinit: ( -- ) ClassInit: super \ init super class ['] On_Clicked SetClickFunc: self ['] On_Unclicked SetUnClickFunc: self ['] On_Tracking SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M \ :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) \ prevent flicker in window on sizing CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop self Start: LeftPane self Start: RightPane self Start: SplitterV ;M ;Object \ start: SplitterWindow --- NEW FILE: EXAMPLEII.frm --- \ EXAMPLE.FRM \- textbox needs excontrols.f \- -filelister.f needs filelister.f \ folder browser FileWindow dirbox TextBox txtpath PushButton btnDelete PushButton btnChoose PushButton btnClose ComboListBox CmbLstFilters :Object frmExample <Super DialogWindow Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color StatusBar TheStatusBar Label lblPath :M ClassInit: ( -- ) ClassInit: super \ Insert your code here ;M :M WindowStyle: ( -- style ) WS_POPUPWINDOW WS_DLGFRAME or ;M \ if this form is a modal form a non-zero parent must be set :M ParentWindow: ( -- hwndparent | 0 if no parent ) hWndParent ;M :M SetParentWindow: ( hwndparent -- ) \ set owner window to hWndParent ;M :M WindowTitle: ( -- ztitle ) z" Example - Directory Viewer" ;M :M StartSize: ( -- width height ) 345 455 ;M :M StartPos: ( -- x y ) 150 175 ;M :M Close: ( -- ) Close: dirbox \ Insert your code here Close: super ;M :M On_Init: ( -- ) s" MS Sans Serif" SetFaceName: WinFont 8 Width: WinFont Create: WinFont \ set form color to system color COLOR_BTNFACE Call GetSysColor NewColor: FrmColor self Start: TheStatusBar self Start: dirbox 8 37 225 358 Move: dirbox self Start: lblPath 9 9 72 19 Move: lblPath Handle: Winfont SetFont: lblPath s" Selected Path:" SetText: lblPath self Start: txtpath 83 9 247 21 Move: txtpath Handle: Winfont SetFont: txtpath self Start: btnDelete 239 40 100 25 Move: btnDelete Handle: Winfont SetFont: btnDelete s" &Delete File" SetText: btnDelete self Start: btnChoose 239 69 100 25 Move: btnChoose Handle: Winfont SetFont: btnChoose s" Choose &Folder" SetText: btnChoose self Start: btnClose 239 364 100 25 Move: btnClose Handle: Winfont SetFont: btnClose s" &Close" SetText: btnClose self Start: CmbLstFilters 8 401 224 20 Move: CmbLstFilters Handle: Winfont SetFont: CmbLstFilters ;M :M WM_COMMAND ( h m w l -- res ) over LOWORD ( ID ) self \ object address on stack WMCommand-Func ?dup \ must not be zero if execute else 2drop \ drop ID and object address then 0 ;M :M SetCommand: ( cfa -- ) \ set WMCommand function to WMCommand-Func ;M :M On_Paint: ( -- ) 0 0 GetSize: self Addr: FrmColor FillArea: dc ;M :M On_Size: ( -- ) Redraw: TheStatusBar ;M :M On_Done: ( -- ) Delete: WinFont \ Insert your code here On_Done: super ;M ;Object Index: CreateToolBar.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/CreateToolBar.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** CreateToolBar.f 20 Nov 2006 14:18:17 -0000 1.5 --- CreateToolBar.f 27 Dec 2006 18:43:57 -0000 1.6 *************** *** 2,11 **** \ needs CreateToolBarForm.frm 0 value DesignToolBar :Object PreviewWindow <Super Window - int &bitmap - max-path bytes BitmapFile BitmapObject TheBitmap dint xypos [...1409 lines suppressed...] ! GetID: btnMoveDown of movebuttondown endof ! GetID: btnFirst of firstbutton endof ! GetID: btnLast of lastbutton endof endcase 0 ;M + :M ParentWindow: ( -- hwndparent ) GetHandle: TheMainWindow ;M :M ToolBarName: ( -- addr cnt ) Name count ;M ! ;object :NoName ( -- ) Start: frmCreateToolBar ; is doCreateToolBar + + + \s --- NEW FILE: New Files.txt --- ( Note that this file is not intended for distribution. ) Added files for ForthForm 2.02.08 doc\forthform\FF-Toolbar Preview Window.gif doc\forthform\FF-Release Notes.htm apps\forthform\joinstr.f apps\forthform\splitter1.f apps\forthform\splitter2.f apps\forthform\splitter3.f apps\forthform\splitter4.f apps\forthform\splitter5.f apps\forthform\splitter6.f apps\forthform\formmonitor.f apps\forthform\exampleII.f apps\forthform\exampleII.ff apps\forthform\exampleII.frm Index: FORTHFORM.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORTHFORM.F,v retrieving revision 1.16 retrieving revision 1.17 diff -C2 -d -r1.16 -r1.17 *** FORTHFORM.F 2 Dec 2006 10:17:30 -0000 1.16 --- FORTHFORM.F 27 Dec 2006 18:43:57 -0000 1.17 *************** *** 29,33 **** needs file.f \ file functions encapsulated in a class needs caseEx.f \ extension to case and if ! needs sendmessage.f \ simple macro needs toolbar.f \ Windows toolbar class needs enum.f \ enumerated constants --- 29,33 ---- needs file.f \ file functions encapsulated in a class needs caseEx.f \ extension to case and if ! needs joinstr.f \ join any number of counted strings needs toolbar.f \ Windows toolbar class [...1033 lines suppressed...] ! ! \+ sysgen s" %DIRWin32ForthIDE.exe %FILENAME %LINE" editor$ place ! \+ sysgen s" %DIRWin32ForthIDE.exe /B %FILENAME %LINE" browse$ place \+ sysgen &forthdir count &appdir place \ create ForthForm.exe in the Win32Forth directory + \+ sysgen 0 0 ' ff application ForthForm.exe *************** *** 1249,1253 **** \+ sysgen 1 pause-seconds bye ! \- sysgen ff \s --- 1217,1221 ---- \+ sysgen 1 pause-seconds bye ! \- sysgen ff \s --- NEW FILE: FormMonitor.f --- \ FormMonitor.f :Object MiniWin <Super child-window int WasMoved? int wx int wy Point MyPoint :M ClassInit: ( -- ) ClassInit: super 0 to WasMoved? 0 to wx 0 to wy 1 to ID ;M :M WindowStyle: ( -- style ) WindowStyle: super WS_CAPTION or WS_BORDER or ;M :M WindowTitle: ( -- zstring ) z" Window" ;M :M StartSize: ( -- width height ) screen-size >r 10 / r> 10 / ;M :M StartPos: ( -- x y ) 0 0 ;M :M WM_MOVING ( h m w l -- ) true to WasMoved? DefWindowProc: self ;M \ WM_MOVE returns origin of window's client area only, but we are using the \ whole window as a replica : GetWindowXY ( -- x y ) GetWindowRect: self 2drop SetPoint: MyPoint AddrOf: MyPoint GetHandle: Parent Call ScreenToClient ?win-error MyPoint.x MyPoint.y ; :M WM_MOVE ( h m w l -- res ) wasMoved? if GetWindowXY 2dup to wy to wx WindowWasMoved: parent \ let parent know false to WasMoved? \ reset then WM_MOVE WM: Super \ send to super class ;M :M On_Paint: ( -- ) 0 0 GetSize: self WHITE FillArea: dc ;M ;Object :Object Monitor <Super Window Rect mBox :M ClassInit: ( -- ) ClassInit: super self link-formwindow ;M :M WindowStyle: ( -- style ) WS_OVERLAPPED WS_CAPTION or WS_DLGFRAME or ;M :M ExWindowStyle: ( -- exstyle ) ExWindowStyle: super WS_EX_TOOLWINDOW or ;M :M ParentWindow: ( -- parent | 0 if no parent ) GetHandle: TheMainWindow ;M :M WindowTitle: ( -- ztitle ) z" Monitor" ;M :M StartSize: ( -- width height ) screen-size 5 / swap 5 / swap ;M :M StartPos: ( -- x y ) MonitorLeft MonitorTop ;M :M Close: ( -- ) Close: MiniWin Close: super ;M :M On_Paint: ( -- ) 0 0 GetSize: self CYAN FillArea: dc 1 1 StartSize: self 1 1 d- SetRect: mBox addr: dc SetDC: mBox Red Green Sunken: mBox ;M : >screen-coord ( wx wy -- x y ) \ convert to screen coordinates for form screen-size StartSize: self { wx wy scrw scrh pw ph -- } scrw pw / wx * scrh ph / wy * ; : screen-coord> ( x y -- wx wy ) \ convert to form coordinates screen-size StartSize: self { x y scrw scrh pw ph -- } x scrw pw / / ( wx ) y scrh ph / / ( wy ) ; :M SetPosition: { x y -- } GetHandle: MiniWin 0= \ if not shown if self Start: MiniWin \ start it up then x y screen-coord> SetWindowPos: MiniWin ;M :M GetPosition: ( -- wx wy ) MiniWin.wx MiniWin.wy >screen-coord ;M :M Blank: ( -- ) Close: MiniWin ;M :M Update: ( -- ) ActiveForm if Origin: ActiveForm SetPosition: self FormTitle: ActiveForm count SetText: MiniWin then ;M :M WindowWasMoved: { x y -- } ActiveForm if Locked?: ActiveForm if Origin: ActiveForm SetPosition: self \ ignore move exitm then x y >screen-coord SetOrigin: ActiveForm IsModified: ActiveForm UpdateProperties++ then ;M :M PushKey: ( c -- ) Pushkey: TheMainWindow ;M ;Object : ?ShowMonitor ( -- ) ShowMonitor? if GetHandle: Monitor 0= if Start: Monitor then Update: Monitor else Close: Monitor then ; \s Index: EXAMPLE.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/EXAMPLE.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** EXAMPLE.F 21 Dec 2004 00:18:45 -0000 1.1 --- EXAMPLE.F 27 Dec 2006 18:43:57 -0000 1.2 *************** *** 21,25 **** Font WinFont - 0 value parent \ pointer to parent of form ' 2drop value OnWmCommand \ function pointer for WM_COMMAND --- 21,24 ---- *************** *** 33,36 **** --- 32,36 ---- RadioButton Radio1 Label Label6 + ColorObject FrmColor \ the background color :M ClassInit: ( -- ) *************** *** 40,44 **** :M WindowStyle: ( -- style ) ! WS_POPUPWINDOW WS_DLGFRAME or ;M --- 40,44 ---- :M WindowStyle: ( -- style ) ! WS_POPUPWINDOW WS_DLGFRAME or ;M *************** *** 50,58 **** \ if this form is a modal form a non-zero parent must be set :M ParentWindow: ( -- parent | 0 if no parent ) ! parent ;M ! :M SetParent: ( parentwindow -- ) \ set owner window ! to parent ;M --- 50,58 ---- \ if this form is a modal form a non-zero parent must be set :M ParentWindow: ( -- parent | 0 if no parent ) ! hwndparent ;M ! :M SetParentWindow: ( parentwindow -- ) \ set owner window ! to hwndparent ;M *************** *** 91,94 **** --- 91,97 ---- Create: WinFont + \ set form color to system color + COLOR_BTNFACE Call GetSysColor NewColor: FrmColor + self Start: lblName 33 22 45 17 Move: lblName *************** *** 214,218 **** :M On_Paint: ( -- ) ! 0 0 GetSize: self LTGRAY FillArea: dc ;M --- 217,221 ---- :M On_Paint: ( -- ) ! 0 0 GetSize: self Addr: FrmColor FillArea: dc ;M Index: SplitterWindow.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/SplitterWindow.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** SplitterWindow.f 21 Aug 2005 06:22:00 -0000 1.2 --- SplitterWindow.f 27 Dec 2006 18:43:57 -0000 1.3 *************** *** 1,3 **** ! \ SplitterWindow.f Some Splitter Windows Templates for ForthForm by Ezra Boyce load-bitmap splitwin-type1 "splitwin-type1.bmp" --- 1,4 ---- ! \ SplitterWindow.f Some Splitter Windows Templates for ForthForm by Ezra Boyce ! \ May 27, 2006 - Updated to used splitter-window templates by Rod OakFord load-bitmap splitwin-type1 "splitwin-type1.bmp" *************** *** 8,11 **** --- 9,13 ---- load-bitmap splitwin-type6 "splitwin-type6.bmp" + :Object frmCreateSplitterWindow <Super frmSplitterWindow *************** *** 16,812 **** ImageButton Split5 ImageButton Split6 ! 0 value ischild-window? ! 0 value stype \ splitter type ! ! : write-superclass ( -- ) ! ischild-window? ! if s" <Super Child-Window" ! else s" <Super Window" ! then 1 +tabs append&crlf ; ! ! : write-autosize ( -- ) ! ischild-window? not ?exit ! +crlf ! s" :M Autosize: ( -- ) " append&crlf ! 2 +tabs s" 0 0 GetSi... [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