Menu
▾
▴
win32forth-cvs — CVS Commit List
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(70) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(38) |
Feb
(4) |
Mar
(11) |
Apr
(49) |
May
(81) |
Jun
(65) |
Jul
(36) |
Aug
(57) |
Sep
(63) |
Oct
(57) |
Nov
(49) |
Dec
(41) |
| 2006 |
Jan
(75) |
Feb
(80) |
Mar
(10) |
Apr
(13) |
May
(100) |
Jun
(100) |
Jul
(77) |
Aug
(87) |
Sep
(80) |
Oct
(124) |
Nov
(39) |
Dec
(41) |
| 2007 |
Jan
(20) |
Feb
(32) |
Mar
(32) |
Apr
(43) |
May
(146) |
Jun
(40) |
Jul
(49) |
Aug
(33) |
Sep
(25) |
Oct
(19) |
Nov
(11) |
Dec
(8) |
| 2008 |
Jan
(4) |
Feb
(11) |
Mar
(31) |
Apr
(40) |
May
(34) |
Jun
(24) |
Jul
(39) |
Aug
(104) |
Sep
(27) |
Oct
(35) |
Nov
(34) |
Dec
(97) |
| 2009 |
Jan
(75) |
Feb
(29) |
Mar
(45) |
Apr
(76) |
May
(121) |
Jun
(103) |
Jul
(67) |
Aug
(28) |
Sep
(22) |
Oct
(39) |
Nov
(9) |
Dec
(15) |
| 2010 |
Jan
(7) |
Feb
(39) |
Mar
(40) |
Apr
(57) |
May
(67) |
Jun
(69) |
Jul
(49) |
Aug
(68) |
Sep
(22) |
Oct
(7) |
Nov
(2) |
Dec
(10) |
| 2011 |
Jan
|
Feb
|
Mar
(10) |
Apr
(4) |
May
(6) |
Jun
(10) |
Jul
(16) |
Aug
(23) |
Sep
(9) |
Oct
|
Nov
(28) |
Dec
(3) |
| 2012 |
Jan
(11) |
Feb
(10) |
Mar
(1) |
Apr
|
May
(4) |
Jun
(3) |
Jul
(3) |
Aug
(4) |
Sep
(2) |
Oct
|
Nov
|
Dec
(1) |
| 2013 |
Jan
|
Feb
(7) |
Mar
(30) |
Apr
(4) |
May
(4) |
Jun
(8) |
Jul
(10) |
Aug
(4) |
Sep
|
Oct
(2) |
Nov
(24) |
Dec
(13) |
| 2014 |
Jan
(7) |
Feb
(2) |
Mar
|
Apr
(1) |
May
(9) |
Jun
|
Jul
(3) |
Aug
(9) |
Sep
|
Oct
(2) |
Nov
|
Dec
(3) |
| 2015 |
Jan
(4) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
(1) |
Oct
(4) |
Nov
(7) |
Dec
(39) |
| 2016 |
Jan
(17) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(1) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
(2) |
| 2017 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(1) |
Jun
(2) |
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
|
Dec
(2) |
| 2018 |
Jan
|
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2019 |
Jan
|
Feb
|
Mar
(1) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2022 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
(1) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
| 2025 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Rod O. <rod...@us...> - 2005-11-06 10:43:27
|
Update of /cvsroot/win32forth/win32forth/apps/ProMgr In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12182/apps/ProMgr Modified Files: HexViewer.f Log Message: Rod: scroll the window contents - smoother than repainting Index: HexViewer.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ProMgr/HexViewer.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** HexViewer.f 5 Nov 2005 22:22:30 -0000 1.2 --- HexViewer.f 6 Nov 2005 10:43:15 -0000 1.3 *************** *** 27,33 **** last-line# 20 - to last-top-line# ;m - :m home: ( -- ) - first-line# to cur-first-line paint: self ;m - : set-params ( -- ) temprect GetClientrect: self --- 27,30 ---- *************** *** 52,69 **** size cell+ malloc to buff-ptr ; - : hex-view ( a1 n1 -- ) - dup to buff-len alloc-buffptr \ keep my own copy, just in case - buff-ptr buff-len move - hwnd 0= ?exit - buff-len bytes/line /mod swap - if 1+ - then to last-line# - buff-ptr buff-len + to eob-ptr - set-params - home: self ; - - :M Dump: ( addr cnt -- ) - hex-view ;M - :M On_Init: ( -- ) On_Init: super --- 49,52 ---- *************** *** 121,125 **** 16 +loop drop TheBuffer ; ! :m on_paint: ( -- ) 0 0 GetSize: self WHITE FillArea: dc buff-ptr 0= ?exitm --- 104,108 ---- 16 +loop drop TheBuffer ; ! :M on_paint: ( -- ) 0 0 GetSize: self WHITE FillArea: dc buff-ptr 0= ?exitm *************** *** 134,138 **** loop RestoreDC: dc ! ;m :M WindowStyle: ( -- style ) \ return the window style --- 117,121 ---- loop RestoreDC: dc ! ;M :M WindowStyle: ( -- style ) \ return the window style *************** *** 141,156 **** ;M ! :m vposition: ( n -- ) \ move to position n ! 0max last-top-line# min ! to cur-first-line paint: self ;m ! :m vscroll: ( n -- ) \ move n lines up or down ! cur-first-line + vposition: self ;m ! :m end: ( -- ) \ move to end, in this case it's 100 bytes down to pad ! last-top-line# to cur-first-line paint: self ;m ! :m vpage: ( n -- ) \ down or up n pages ! screen-rows 1- * vscroll: self ;m :M WM_VSCROLL ( h m w l -- res ) --- 124,144 ---- ;M ! :M VPosition: ( n -- ) \ move to position n ! cur-first-line swap \ save previous cur-first-line on stack ! 0max last-top-line# min to cur-first-line ! cur-first-line - char-height * 0 swap Scroll: self \ scroll rather than repaint ! set-scrollpos ;M ! :M VScroll: ( n -- ) \ move n lines up or down ! cur-first-line + VPosition: self ;M ! :M Home: ( -- ) ! first-line# VPosition: self ;M ! :M End: ( -- ) \ move to end, in this case it's 100 bytes down to pad ! last-top-line# VPosition: self ;M ! ! :M VPage: ( n -- ) \ down or up n pages ! screen-rows 1- * VScroll: self ;M :M WM_VSCROLL ( h m w l -- res ) *************** *** 166,173 **** SB_THUMBTRACK of r@ VPosition: self endof ENDCASE r>drop - \ position the vertical button in the scroll bar - set-scrollpos 0 ;M :m on_done: ( -- ) release-buffptr --- 154,174 ---- SB_THUMBTRACK of r@ VPosition: self endof ENDCASE r>drop 0 ;M + : hex-view ( a1 n1 -- ) + dup to buff-len alloc-buffptr \ keep my own copy, just in case + buff-ptr buff-len move + hwnd 0= ?exit + buff-len bytes/line /mod swap + if 1+ + then to last-line# + buff-ptr buff-len + to eob-ptr + set-params + home: self + paint: self ; + + :M Dump: ( addr cnt -- ) + hex-view ;M + :m on_done: ( -- ) release-buffptr *************** *** 177,181 **** :M AutoSize: ( -- ) tempRect.AddrOf GetClientRect: Parent ! 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M --- 178,182 ---- :M AutoSize: ( -- ) tempRect.AddrOf GetClientRect: Parent ! 0 0 Right: tempRect Bottom: tempRect \ x,y,w,h Move: self ;M |
|
From: Dirk B. <db...@us...> - 2005-11-06 10:15:56
|
Update of /cvsroot/win32forth/win32forth/demos/GdiDemo In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3588/demos/GdiDemo Removed Files: Metafile.emf Log Message: Removed none needed file. --- Metafile.emf DELETED --- |
|
From: Dirk B. <db...@us...> - 2005-11-06 09:17:31
|
Update of /cvsroot/win32forth/win32forth/apps/Sudoku In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24995/apps/Sudoku Modified Files: Sudoku.f Log Message: Changed the ChooseFont: and ChooseColor: methods of the Frame-Window object to use the Choose: methods of the gdiClass library. Index: Sudoku.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Sudoku/Sudoku.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Sudoku.f 3 Nov 2005 19:21:01 -0000 1.3 --- Sudoku.f 6 Nov 2005 09:17:22 -0000 1.4 *************** *** 6,10 **** anew -Sudoku.f ! Create SudokuVersion ," 1.2" s" apps\Sudoku" "fpath+ s" apps\Sudoku\res" "fpath+ --- 6,10 ---- anew -Sudoku.f ! Create SudokuVersion ," 1.3" s" apps\Sudoku" "fpath+ s" apps\Sudoku\res" "fpath+ *************** *** 77,81 **** 0 Width: SudokuFont 700 Weight: SudokuFont - \ 0 PitchAndFamily: SudokuFont : ChangeFontSize ( n -- ) dup to FontHeight Height: SudokuFont Create: SudokuFont ; : SetFontSize ( -- ) size 6 8 */ negate ChangeFontSize ; \ set font size to a fixed fraction of cell size --- 77,80 ---- *************** *** 114,118 **** +z," 000000000000000000000000000000000000000000000000000000000000000000000000000000000" : SetColours ( -- ) 81 0 DO Numbers 81 + i + c@ '0' = IF 1 ELSE 0 THEN Numbers 243 + i + c! LOOP ; - \ SetColours Create TempNumbers 81 allot : Start>Solution numbers 81 + numbers 81 move ; --- 113,116 ---- *************** *** 206,210 **** : BlankAll ( -- ) Numbers 243 '0' fill Numbers 243 + 81 1 fill ; \ to make new game - \ : ClearAll ( -- ) Numbers 81 + Numbers 162 + 81 move ; : ClearAll ( -- ) 81 0 DO Numbers 81 + i + c@ dup Numbers 162 + i + c! \ to restart game '0' = IF 1 ELSE 0 THEN Numbers 243 + i + c! --- 204,207 ---- *************** *** 335,339 **** : OpenFile ( Filename$ -- f ) dup dup c@ \ true on success IF count r/o open-file - \ IF 3drop false ( ReadErrorMessage ) \ file does not exist IF drop ReadErrorMessage false \ file does not exist ELSE to FileHandle --- 332,335 ---- *************** *** 350,354 **** : SaveFile ( Filename$ -- ) dup dup c@ IF count r/w create-file - \ IF 3drop false to SaveFlag ( WriteErrorMessage ) \ file does not exist IF drop WriteErrorMessage false to SaveFlag \ file does not exist ELSE to FileHandle --- 346,349 ---- *************** *** 431,490 **** :Object Frame <Super Window - Record: CHOOSEFONT - int lSize - int hOwner - int hDC - int lpLogFont - int iPointSize - int FontFlags - int rgbColors - 8 cells class-allot - ;RecordSize: sizeof(CHOOSEFONT) - :M ChooseFont: ( -- ) ! CHOOSEFONT call ChooseFont ! IF SetFontSize redraw: [ self ] THEN ! ;M ! ! 64 bytes CustomColors ! ! Record: CHOOSECOLOR ! int lStructSize ! int hwndOwner ! int Instance ! int rgbResult ! int lpCustColors ! int Flags ! 3 cells class-allot ! ;RecordSize: sizeof(CHOOSECOLOR) ! ! int ColorObject ! :M ChooseColor: ( object -- ) to ColorObject ! Color: ColorObject 16777215 and to rgbResult ! CHOOSECOLOR call ChooseColor ! IF rgbResult [ PC_NOCOLLAPSE 256 * 256 * 256 * ] literal or NewColor: ColorObject redraw: [ self ] THEN ! ;M :M Classinit: ( -- ) ClassInit: super \ init super class SudokuMenu to CurrentMenu - hWnd to hOwner - sizeof(CHOOSEFONT) to lSize - CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or to FontFlags - Sudokufont.LOGFONT to lpLogFont - - sizeof(CHOOSECOLOR) to lStructSize - hWnd to hwndOwner - [ Hex ] - E6FFFF CustomColors ! FFE6FF CustomColors 4 + ! FFFFE6 CustomColors 8 + ! - FFE6E6 CustomColors C + ! E6FFE6 CustomColors 10 + ! E6E6FF CustomColors 14 + ! - C8F0F0 CustomColors 18 + ! F0C8F0 CustomColors 1C + ! F0F0C8 CustomColors 20 + ! - F0C8C8 CustomColors 24 + ! C8F0C8 CustomColors 28 + ! C8C8F0 CustomColors 2C + ! - F0F0F0 CustomColors 30 + ! E6E6E6 CustomColors 34 + ! F4FFFF CustomColors 38 + ! - FFFFF4 CustomColors 3C + ! - [ Decimal ] - CustomColors to lpCustColors - CC_RGBINIT CC_FULLOPEN or to Flags ;M --- 426,442 ---- :Object Frame <Super Window :M ChooseFont: ( -- ) ! hWnd Choose: SudokuFont ! IF SetFontSize redraw: [ self ] ! THEN ;M ! :M ChooseColor: { ColorObject -- } ! Choose: ColorObject ! if redraw: [ self ] ! then ;M :M Classinit: ( -- ) ClassInit: super \ init super class SudokuMenu to CurrentMenu ;M *************** *** 539,543 **** CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop 101 appinst Call LoadIcon GCL_HICON hWnd Call SetClassLong drop - \ 0 GCL_HCURSOR hWnd Call SetClassLong drop \ no, need default cursor for margin 0 GCL_HBRBACKGROUND hWnd Call SetClassLong drop 0 Call CreateCompatibleDC PutHandle: mdc --- 491,494 ---- *************** *** 598,602 **** : Draw9 { l t -- } l 2 + t 2 + size 3 * 2 - dup DrawRectangle \ extra line on inside - \ l t size 3 * 2 + dup DrawRectangle \ extra line on outside t 1+ size 3 * bounds DO l 1+ size 3 * bounds DO i j size size DrawRectangle size +LOOP --- 549,552 ---- *************** *** 606,610 **** Black LineColor: mdc LeftMargin TopMargin size 9 * 2 + dup DrawRectangle \ extra line on outside - \ LeftMargin 2 + TopMargin 2 + size 9 * 2 - dup DrawRectangle \ extra line on inside TopMargin size 9 * bounds DO LeftMargin size 9 * bounds DO i j Draw9 size 3 * +LOOP --- 556,559 ---- *************** *** 681,689 **** :M On_Paint: ( -- ) - \ SaveDC: dc SRCCOPY 0 0 GetHandle: mdc Width Height StatusBarHeight - ToolbarHeight - 0 ToolbarHeight BitBlt: dc - \ RestoreDC: dc ;M --- 630,636 ---- *************** *** 902,916 **** Resize: Frame ; IDM_TOGGLE_TOOLBAR SetCommand : OnFont ( -- ) ChooseFont: Frame ; IDM_FONT SetCommand ! : TextColour1 ( -- ) TextColor1 ChooseColor: frame ; IDM_TEXT_COLOUR_1 SetCommand ! : TextColour2 ( -- ) TextColor2 ChooseColor: frame ; IDM_TEXT_COLOUR_2 SetCommand ! : TextColour3 ( -- ) TextColor3 ChooseColor: frame ; IDM_TEXT_COLOUR_3 SetCommand ! : TextColour4 ( -- ) TextColor4 ChooseColor: frame ; IDM_TEXT_COLOUR_4 SetCommand ! : FixedColour ( -- ) FixedColor ChooseColor: frame ; IDM_FIXED_COLOUR SetCommand ! : WarningColour ( -- ) WarningColor ChooseColor: frame ; IDM_WARNING_COLOUR SetCommand : VariableBackgroundColour ( -- ) VariableBackgroundColor ChooseColor: frame ; IDM_VARIABLE_BACKGROUND_COLOUR SetCommand ! : FixedBackgroundColour ( -- ) FixedBackgroundColor ChooseColor: frame ; IDM_FIXED_BACKGROUND_COLOUR SetCommand ! : HighLightColour ( -- ) HighLightColor ChooseColor: frame ; IDM_HIGHLIGHT_COLOUR SetCommand ! : MarginColour ( -- ) MarginColor ChooseColor: frame ; IDM_MARGIN_COLOUR SetCommand ! : EliminationColour ( -- ) EliminationColor ChooseColor: frame ; IDM_ELIMINATION_COLOUR SetCommand \ Game Menu --- 849,864 ---- Resize: Frame ; IDM_TOGGLE_TOOLBAR SetCommand : OnFont ( -- ) ChooseFont: Frame ; IDM_FONT SetCommand ! ! : TextColour1 ( -- ) TextColor1 ChooseColor: frame ; IDM_TEXT_COLOUR_1 SetCommand ! : TextColour2 ( -- ) TextColor2 ChooseColor: frame ; IDM_TEXT_COLOUR_2 SetCommand ! : TextColour3 ( -- ) TextColor3 ChooseColor: frame ; IDM_TEXT_COLOUR_3 SetCommand ! : TextColour4 ( -- ) TextColor4 ChooseColor: frame ; IDM_TEXT_COLOUR_4 SetCommand ! : FixedColour ( -- ) FixedColor ChooseColor: frame ; IDM_FIXED_COLOUR SetCommand ! : WarningColour ( -- ) WarningColor ChooseColor: frame ; IDM_WARNING_COLOUR SetCommand : VariableBackgroundColour ( -- ) VariableBackgroundColor ChooseColor: frame ; IDM_VARIABLE_BACKGROUND_COLOUR SetCommand ! : FixedBackgroundColour ( -- ) FixedBackgroundColor ChooseColor: frame ; IDM_FIXED_BACKGROUND_COLOUR SetCommand ! : HighLightColour ( -- ) HighLightColor ChooseColor: frame ; IDM_HIGHLIGHT_COLOUR SetCommand ! : MarginColour ( -- ) MarginColor ChooseColor: frame ; IDM_MARGIN_COLOUR SetCommand ! : EliminationColour ( -- ) EliminationColor ChooseColor: frame ; IDM_ELIMINATION_COLOUR SetCommand \ Game Menu *************** *** 1121,1125 **** rtMargin 12 + 100 REG_DWORD RegEntry "MarginBottom" ' CurrentTextColour 4 + 1 REG_DWORD RegEntry "CurrentTextColour" ! Frame.CustomColors 64 2dup REG_BINARY RegEntry "CustomColors" FixedColor dup @ REG_DWORD RegEntry "FixedColour" TextColor1 dup @ REG_DWORD RegEntry "TextColour1" --- 1069,1073 ---- rtMargin 12 + 100 REG_DWORD RegEntry "MarginBottom" ' CurrentTextColour 4 + 1 REG_DWORD RegEntry "CurrentTextColour" ! CustomColors: FixedColor 2dup REG_BINARY RegEntry "CustomColors" FixedColor dup @ REG_DWORD RegEntry "FixedColour" TextColor1 dup @ REG_DWORD RegEntry "TextColour1" *************** *** 1238,1248 **** Create MessageStructure 32 allot - (( - : Pause ( -- ) \ instead of "Winpause" - BEGIN PM_REMOVE 0 0 0 MessageStructure Call PeekMessage - WHILE MessageStructure HandleMessages drop - REPEAT - ; - )) : MessageLoop ( -- ) \ instead of "Begin key drop again" BEGIN 0 0 0 MessageStructure Call GetMessage --- 1186,1189 ---- *************** *** 1254,1259 **** : Su ( -- ) - \ LOGPIXELSX condc Call GetDeviceCaps to Resolution \ Resolution of screen - \ 96 100 145 */ to Resolution \ pixels per inch 96 to Resolution \ needs to be adjusted to make print size same as screen size DefaultPrinter --- 1195,1198 ---- *************** *** 1267,1273 **** Color: MarginColor MarginColor off NewColor: MarginColor Start: Frame - \ ZeroMoves - \ StartTimer - \ SelectBlank Colour1 RestoreRecentFiles --- 1206,1209 ---- *************** *** 1278,1282 **** ShowElimination check: hEliminate Directory count 2dup SetDir: OpenDialog SetDir: SaveDialog - \ 6 SetNumber: RecentFiles NumberRecentFiles SetNumber: RecentFiles SudokuAccelerators EnableAccelerators --- 1214,1217 ---- *************** *** 1284,1296 **** ; ! [defined] VIMAGE [if] also VIMAGE [then] ! [defined] CONSOLE-DLL? [if] false to CONSOLE-DLL? [then] ! ' Su turnkey Sudoku.exe ! needs SudokuResources ! \ cr .( Do you want to associate .sku files with Sudoku.exe [Y/N]: ) key dup emit dup 121 = swap 89 = or nostack ! \ [IF] ! \ Needs FileAssociations ! \ s" .sku" s" Sudoku File" s" Sudoku.exe" SetAssociation ! \ [THEN] ! 1 pause-seconds bye --- 1219,1226 ---- ; ! [defined] VIMAGE [if] also VIMAGE [then] ! [defined] CONSOLE-DLL? [if] false to CONSOLE-DLL? [then] ! ' Su turnkey Sudoku.exe ! needs SudokuResources ! 1 pause-seconds bye |
|
From: Dirk B. <db...@us...> - 2005-11-06 09:14:45
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24087/src Modified Files: COLORS.F Log Message: - Changed the ColorObject class to use an instance of the gdiCOLORREF class to hold the color. - Added a Choose: method to the ColorObject class to open the ChooseColor dialog. - Marked FOREGROUND and BACKGROUND as deprecated. Index: COLORS.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/COLORS.F,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** COLORS.F 29 Aug 2005 15:56:27 -0000 1.2 --- COLORS.F 6 Nov 2005 09:14:37 -0000 1.3 *************** *** 4,7 **** --- 4,8 ---- cr .( Loading Object Color...) + needs gdi/gdiStruct.f \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 110,114 **** \ local data allocated for each color object that is defined. ! int colorref \ the actual color reference value int hbrush \ the brush handle int hpen \ the pen handle --- 111,115 ---- \ local data allocated for each color object that is defined. ! gdiCOLORREF colorref \ the actual color reference value int hbrush \ the brush handle int hpen \ the pen handle *************** *** 134,144 **** \ and a brush for each color object. UnInitColor: self \ delete previous pens/brushes ! colorref penwidth PenStyle Call CreatePen to hpen ! colorref Call CreateSolidBrush to hbrush ;M :M ClassInit: ( -- ) \ compile time initialization for each color object \ as it is defined ! 0 0 0 rgb to colorref 0 to hpen 0 to hbrush --- 135,145 ---- \ and a brush for each color object. UnInitColor: self \ delete previous pens/brushes ! GetColor: colorref penwidth PenStyle Call CreatePen to hpen ! GetColor: colorref Call CreateSolidBrush to hbrush ;M :M ClassInit: ( -- ) \ compile time initialization for each color object \ as it is defined ! 0 0 0 SetRGB: colorref 0 to hpen 0 to hbrush *************** *** 155,159 **** :M Color: ( -- colorref ) \ get the colorref value ! colorref ;M :M Pen: ( -- hpen ) \ get the color pen handle --- 156,160 ---- :M Color: ( -- colorref ) \ get the colorref value ! GetColor: colorref ;M :M Pen: ( -- hpen ) \ get the color pen handle *************** *** 164,179 **** :M NewColor: ( colorref -- ) \ set a color object to a new color ref value ! dup colorref <> ! if to colorref ! InitColor: [ self ] \ create the new pens/brushes ! else drop ! then ;M :M PenWidth: ( pen_width -- ) \ set the pen width 1 max dup penwidth <> ! if to penwidth ! InitColor: [ self ] ! else drop ! then ;M ;Class --- 165,190 ---- :M NewColor: ( colorref -- ) \ set a color object to a new color ref value ! dup GetColor: colorref <> ! if SetColor: colorref ! InitColor: [ self ] \ create the new pens/brushes ! else drop ! then ;M ! ! :M Choose: ( hWnd -- f ) \ let the user choose a color ! Choose: colorref ! if InitColor: [ self ] true \ create the new pens/brushes ! else false ! then ;M ! ! :M CustomColors: ( -- addr len ) \ return address and length of the user defined ! \ custom colors ! CustomColors: colorref ;M :M PenWidth: ( pen_width -- ) \ set the pen width 1 max dup penwidth <> ! if to penwidth ! InitColor: [ self ] ! else drop ! then ;M ;Class *************** *** 198,207 **** \ and a brush for each color object. UnInitColor: self \ delete previous pens/brushes ! colorref to lbColor \ same as colorref lpStyle \ if not NULL StyleCount &LOGBRUSH ! penwidth PenStyle Call ExtCreatePen to hpen ! colorref Call CreateSolidBrush to hbrush ;M --- 209,218 ---- \ and a brush for each color object. UnInitColor: self \ delete previous pens/brushes ! GetColor: colorref to lbColor \ same as colorref lpStyle \ if not NULL StyleCount &LOGBRUSH ! penwidth PenStyle Call ExtCreatePen to hpen ! GetColor: colorref Call CreateSolidBrush to hbrush ;M *************** *** 212,216 **** \ init the LOGBRUSH structure to some defaults BS_SOLID to lbStyle ! colorref to lbColor NULL to lbHatch \ init remaining parameters to defaults --- 223,227 ---- \ init the LOGBRUSH structure to some defaults BS_SOLID to lbStyle ! GetColor: colorref to lbColor NULL to lbHatch \ init remaining parameters to defaults *************** *** 258,262 **** 128 128 0 palettergb new-color YELLOW 255 255 0 palettergb new-color LTYELLOW ! 204 0 204 palettergb new-color DKMAGENTA \ JaP 128 0 128 palettergb new-color MAGENTA 255 0 255 palettergb new-color LTMAGENTA --- 269,273 ---- 128 128 0 palettergb new-color YELLOW 255 255 0 palettergb new-color LTYELLOW ! 204 0 204 palettergb new-color DKMAGENTA \ JaP 128 0 128 palettergb new-color MAGENTA 255 0 255 palettergb new-color LTMAGENTA *************** *** 266,298 **** 128 64 0 palettergb new-color BROWN - \ Note: FOREGROUND and BACKGROUND doesn't work for the console window. - \ The only way to set the foreground and/or background color for the console - \ window is using the word FGBG! like this: - \ - \ Color: red BG@ FGBG! \ set red foreground color - \ FG@ Color: blue FGBG! \ set blue background color - \ - \ To work with the console window FOREGROUND and BACKGROUND should be - \ replaced with: - \ - \ : FG! { color_object -- } - \ color_object ?ColorCheck drop - \ Color: color_object BG@ FGBG! ; - \ - \ : BG! { color_object -- } - \ color_object ?ColorCheck drop - \ FG@ Color: color_object FGBG! ; ! : foreground { color_object \ theDC -- } \ set foreground text color ! color_object ?ColorCheck drop ! conHndl call GetDC to theDC \ get and save the Device Control # ! Color: color_object theDC Call SetTextColor drop ! theDC conHndl call ReleaseDC drop ; ! : background { color_object \ theDC -- } \ set background text color ! color_object ?ColorCheck drop ! conHndl call GetDC to theDC \ get and save the Device Control # ! Color: color_object theDC Call SetBkColor drop ! theDC conHndl call ReleaseDC drop ; --- 277,292 ---- 128 64 0 palettergb new-color BROWN ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Set console text color ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! : FOREGROUND { color_object \ theDC -- } \ set foreground text color ! color_object ?ColorCheck drop ! Color: color_object BG@ FGBG! ; DEPRECATED ! ! : BACKGROUND { color_object \ theDC -- } \ set background text color ! color_object ?ColorCheck drop ! FG@ Color: color_object FGBG! ; DEPRECATED *************** *** 307,319 **** :M InitColor: ( -- ) \ define color as a hatched color UnInitColor: self \ delete previous pens/brushes ! colorref penwidth PS_SOLID Call CreatePen to hpen ! colorref HS_DIAGCROSS Call CreateHatchBrush to hbrush ;M ;Class - - \ : new-hatch-color ( colorref -<name>- ) \ make a hatched color - \ HatchColorObject \ define a new object - \ NewColor: NewObject ; \ and initialize it - - --- 301,307 ---- :M InitColor: ( -- ) \ define color as a hatched color UnInitColor: self \ delete previous pens/brushes ! GetColor: colorref penwidth PS_SOLID Call CreatePen to hpen ! GetColor: colorref HS_DIAGCROSS Call CreateHatchBrush to hbrush ;M ;Class |
|
From: Dirk B. <db...@us...> - 2005-11-06 09:09:35
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22873/src/gdi Modified Files: gdiStruct.f Log Message: Made the CustomColors for the ChooseColor dialog global to all instances of the gdiCOLORREF class. Index: gdiStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiStruct.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiStruct.f 1 Nov 2005 12:21:40 -0000 1.1 --- gdiStruct.f 6 Nov 2005 09:09:27 -0000 1.2 *************** *** 10,13 **** --- 10,24 ---- internal + + create CustomColors 64 allot \ hold the userdefined custom colors + + \ init custom colors + 0xE6FFFF CustomColors ! 0xFFE6FF CustomColors 0x04 + ! 0xFFFFE6 CustomColors 0x08 + ! + 0xFFE6E6 CustomColors 0x0C + ! 0xE6FFE6 CustomColors 0x10 + ! 0xE6E6FF CustomColors 0x14 + ! + 0xC8F0F0 CustomColors 0x18 + ! 0xF0C8F0 CustomColors 0x1C + ! 0xF0F0C8 CustomColors 0x20 + ! + 0xF0C8C8 CustomColors 0x24 + ! 0xC8F0C8 CustomColors 0x28 + ! 0xC8C8F0 CustomColors 0x2C + ! + 0xF0F0F0 CustomColors 0x30 + ! 0xE6E6E6 CustomColors 0x34 + ! 0xF4FFFF CustomColors 0x38 + ! + 0xFFFFF4 CustomColors 0x3C + ! + external *************** *** 64,69 **** ;RecordSize: sizeof(CHOOSECOLOR) - 64 bytes CustomColors - :M ClassInit: ( -- ) ClassInit: super --- 75,78 ---- *************** *** 86,96 **** null to lpTemplateName - \ init custom colors - 0xE6FFFF CustomColors ! 0xFFE6FF CustomColors 0x04 + ! 0xFFFFE6 CustomColors 0x08 + ! - 0xFFE6E6 CustomColors 0x0C + ! 0xE6FFE6 CustomColors 0x10 + ! 0xE6E6FF CustomColors 0x14 + ! - 0xC8F0F0 CustomColors 0x18 + ! 0xF0C8F0 CustomColors 0x1C + ! 0xF0F0C8 CustomColors 0x20 + ! - 0xF0C8C8 CustomColors 0x24 + ! 0xC8F0C8 CustomColors 0x28 + ! 0xC8C8F0 CustomColors 0x2C + ! - 0xF0F0F0 CustomColors 0x30 + ! 0xE6E6E6 CustomColors 0x34 + ! 0xF4FFFF CustomColors 0x38 + ! - 0xFFFFF4 CustomColors 0x3C + ! ;M --- 95,98 ---- *************** *** 119,122 **** --- 121,128 ---- then ;M + \ return address and length of the user defined custom colors + :M CustomColors: ( -- addr len ) + CustomColors 64 ;M + ;class |
|
From: Dirk B. <db...@us...> - 2005-11-06 07:41:24
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6386/src/gdi Modified Files: gdiBase.f Log Message: Fixed a bug in the gdiBase class that made SciEdit crash sometimes on shutdown. Index: gdiBase.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiBase.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** gdiBase.f 5 Nov 2005 13:22:16 -0000 1.2 --- gdiBase.f 6 Nov 2005 07:41:16 -0000 1.3 *************** *** 141,145 **** :M SetHandle: ( hObject -- ) ! Destroy: [ self ] to hObject ;M --- 141,145 ---- :M SetHandle: ( hObject -- ) ! Destroy: self to hObject ;M |
|
From: Dirk B. <db...@us...> - 2005-11-06 07:36:52
|
Update of /cvsroot/win32forth/win32forth/apps/SciEdit In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5435/apps/SciEdit Modified Files: Main.f Log Message: Fixed a smal bug in SciEdit Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/SciEdit/Main.f,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** Main.f 15 Sep 2005 16:36:08 -0000 1.11 --- Main.f 6 Nov 2005 07:36:40 -0000 1.12 *************** *** 79,122 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! :Object Frame <Super MDIFrameWindow create RegPath$ ," SciEdit\" ! :M Classinit: ( -- ) ! ClassInit: super ! MainMenu to CurrentMenu ;M :M InitRegistry: ( -- ) ! \ set the base registry string PROGREG-SET-BASE-PATH RegPath$ count progreg +place progreg +null ;M :M WindowMenuNo: ( -- n ) ! WINDOW-MENU ;M \ the Window menu where the child window titles will be placed :M WindowHasMenu: ( -- f ) ! True ;M :M WindowStyle: ( -- style ) ! WindowStyle: SUPER ! WS_CLIPCHILDREN or ;M :M ExWindowStyle: ( -- exstyle ) ! WS_EX_ACCEPTFILES ;M ! :M DropFiles: { hndl message wParam lParam \ drop$ -- res } ! SetForegroundWindow: self ! MAXSTRING LocalAlloc: drop$ ! 0 0 -1 wParam Call DragQueryFile ! 0 DO MAXCOUNTED drop$ 1+ i wParam Call DragQueryFile drop$ c! ! drop$ IDM_OPEN_RECENT_FILE DoCommand ! LOOP ! wParam Call DragFinish ;M :M WM_DROPFILES ( hndl message wParam lParam -- res ) ! DropFiles: self ;M :M WindowTitle: ( -- z" ) ! z" SciEdit" ;M : AdjustWindowSize { width height win -- } --- 79,122 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! :Object Frame <Super MDIFrameWindow create RegPath$ ," SciEdit\" ! :M Classinit: ( -- ) ! ClassInit: super ! MainMenu to CurrentMenu ;M :M InitRegistry: ( -- ) ! \ set the base registry string PROGREG-SET-BASE-PATH RegPath$ count progreg +place progreg +null ;M :M WindowMenuNo: ( -- n ) ! WINDOW-MENU ;M \ the Window menu where the child window titles will be placed :M WindowHasMenu: ( -- f ) ! True ;M :M WindowStyle: ( -- style ) ! WindowStyle: SUPER ! WS_CLIPCHILDREN or ;M :M ExWindowStyle: ( -- exstyle ) ! WS_EX_ACCEPTFILES ;M ! :M DropFiles: { hndl message wParam lParam \ drop$ -- res } ! SetForegroundWindow: self ! MAXSTRING LocalAlloc: drop$ ! 0 0 -1 wParam Call DragQueryFile ! 0 DO MAXCOUNTED drop$ 1+ i wParam Call DragQueryFile drop$ c! ! drop$ IDM_OPEN_RECENT_FILE DoCommand ! LOOP ! wParam Call DragFinish ;M :M WM_DROPFILES ( hndl message wParam lParam -- res ) ! DropFiles: self ;M :M WindowTitle: ( -- z" ) ! z" SciEdit" ;M : AdjustWindowSize { width height win -- } *************** *** 127,155 **** win Call SetWindowPos drop ; ! :M ReSize: ( -- ) tempRect.AddrOf GetClientRect: self Left: tempRect ! ShowToolbar? if Height: TheRebar 2 - else Top: tempRect then ! Right: tempRect Bottom: tempRect ! ShowStatusbar? if Height: ScintillaStatusbar - 1+ then ! ShowToolbar? if Height: TheRebar - 1+ then Move: MDIClient ! ShowToolbar? if Width Height: TheRebar GetHandle: TheRebar AdjustWindowSize then ! ShowStatusbar? if Redraw: ScintillaStatusbar then ! ;M int WindowState ! :M On_Size: ( h m w -- ) ! to WindowState \ get WindowState, don't save size of maximised or minimised window ! ReSize: self ;M :M WM_ACTIVATEAPP ( hndl message wParam lParam -- res ) ! drop true = ActiveChild 0<> and ! if SetFocus: ActiveChild ! then 0 ;M : "GetDefault ( a1 n1 -- a2 n2 ) --- 127,155 ---- win Call SetWindowPos drop ; ! :M ReSize: ( -- ) tempRect.AddrOf GetClientRect: self Left: tempRect ! ShowToolbar? if Height: TheRebar 2 - else Top: tempRect then ! Right: tempRect Bottom: tempRect ! ShowStatusbar? if Height: ScintillaStatusbar - 1+ then ! ShowToolbar? if Height: TheRebar - 1+ then Move: MDIClient ! ShowToolbar? if Width Height: TheRebar GetHandle: TheRebar AdjustWindowSize then ! ShowStatusbar? if Redraw: ScintillaStatusbar then ! ;M int WindowState ! :M On_Size: ( h m w -- ) ! to WindowState \ get WindowState, don't save size of maximised or minimised window ! ReSize: self ;M :M WM_ACTIVATEAPP ( hndl message wParam lParam -- res ) ! drop true = ActiveChild 0<> and ! if SetFocus: ActiveChild ! then 0 ;M : "GetDefault ( a1 n1 -- a2 n2 ) *************** *** 166,225 **** : SaveRecentFiles ( -- ) ! s" Recent Files" s" File1" 9 1 ! DO 2dup + 1- i 48 + swap c! ! 4dup i GetRecentFile: RecentFiles count ! 2rot 2rot 2swap RegSetString ! LOOP 2drop ; : RestoreRecentFiles ( -- ) ! 8 SetNumber: RecentFiles ! s" Recent Files" s" File1" 9 0 ! DO 2dup + 1- 57 i - swap c! ! 4dup 2swap RegGetString ! 2dup FILE-STATUS nip 0= \ we only add the file's witch still exist ! IF pad place pad Insert: RecentFiles ! ELSE 2drop ! THEN ! LOOP 4drop ; : save-defaults ( -- ) base @ >r decimal \ MUST be in decimal when saving defaults ! InitRegistry: self ! CreateBackup? s>d (d.) s" Backup" "SetDefault ! EOL s>d (d.) s" EOL" "SetDefault ! ViewEOL? s>d (d.) s" ViewEOL" "SetDefault ! ViewWhiteSpace? s>d (d.) s" WhiteSpace" "SetDefault ! CaseSensitive? s>d (d.) s" CaseSensitive" "SetDefault ! sub-dirs? s>d (d.) s" SubDirectories" "SetDefault ! all-occur? s>d (d.) s" AllOccurances" "SetDefault ! Colorize? s>d (d.) s" Colorize" "SetDefault ! ViewLineNumbers? s>d (d.) s" ViewLineNumbers" "SetDefault ! TabSize s>d (d.) s" TabSize" "SetDefault ! UseTabs? s>d (d.) s" UseTabs" "SetDefault ! ShowToolbar? s>d (d.) s" ShowToolbar" "SetDefault ! ShowStatusbar? s>d (d.) s" ShowStatusbar" "SetDefault ! HandleW32FMsg? s>d (d.) s" HandleW32FMsg" "SetDefault ! FinalNewLine? s>d (d.) s" FinalNewLine" "SetDefault ! SaveAllBeforeCompile? s>d (d.) s" SaveAllBeforeCompile" "SetDefault ! StripTrailingWhitespace? s>d (d.) s" StripTrailingSpaces" "SetDefault ! WindowState SIZE_RESTORED = ! if StartPos: self s>d (d.) s" WindowTop" "SetDefault ! s>d (d.) s" WindowLeft" "SetDefault ! Width: self s>d (d.) s" WindowWidth" "SetDefault ! Height: self s>d (d.) s" WindowHeight" "SetDefault ! then ! mask-ptr count s" SearchMask" "SetDefault ! find-buf count s" SearchText" "SetDefault ! path-ptr count s" SearchPath" "SetDefault ! SaveRecentFiles ! SetRegistryKey: ControlToolBar true SaveRestore: ControlToolBar ! r> base ! ; : load-defaults ( -- ) --- 166,226 ---- : SaveRecentFiles ( -- ) ! s" Recent Files" s" File1" 9 1 ! DO 2dup + 1- i 48 + swap c! ! 4dup i GetRecentFile: RecentFiles count ! 2rot 2rot 2swap RegSetString ! LOOP 4drop ; : RestoreRecentFiles ( -- ) ! 8 SetNumber: RecentFiles ! s" Recent Files" s" File1" 9 1 ! DO 2dup + 1- 57 i - swap c! ! 4dup 2swap RegGetString ! 2dup FILE-STATUS nip 0= \ we only add the file's witch still exist ! IF pad place pad Insert: RecentFiles ! ELSE 2drop ! THEN ! LOOP 4drop ; : save-defaults ( -- ) base @ >r decimal \ MUST be in decimal when saving defaults ! InitRegistry: self ! CreateBackup? s>d (d.) s" Backup" "SetDefault ! EOL s>d (d.) s" EOL" "SetDefault ! ViewEOL? s>d (d.) s" ViewEOL" "SetDefault ! ViewWhiteSpace? s>d (d.) s" WhiteSpace" "SetDefault ! CaseSensitive? s>d (d.) s" CaseSensitive" "SetDefault ! sub-dirs? s>d (d.) s" SubDirectories" "SetDefault ! all-occur? s>d (d.) s" AllOccurances" "SetDefault ! Colorize? s>d (d.) s" Colorize" "SetDefault ! ViewLineNumbers? s>d (d.) s" ViewLineNumbers" "SetDefault ! TabSize s>d (d.) s" TabSize" "SetDefault ! UseTabs? s>d (d.) s" UseTabs" "SetDefault ! ShowToolbar? s>d (d.) s" ShowToolbar" "SetDefault ! ShowStatusbar? s>d (d.) s" ShowStatusbar" "SetDefault ! HandleW32FMsg? s>d (d.) s" HandleW32FMsg" "SetDefault ! FinalNewLine? s>d (d.) s" FinalNewLine" "SetDefault ! SaveAllBeforeCompile? s>d (d.) s" SaveAllBeforeCompile" "SetDefault ! StripTrailingWhitespace? s>d (d.) s" StripTrailingSpaces" "SetDefault ! WindowState SIZE_RESTORED = ! if StartPos: self s>d (d.) s" WindowTop" "SetDefault ! s>d (d.) s" WindowLeft" "SetDefault ! Width: self s>d (d.) s" WindowWidth" "SetDefault ! Height: self s>d (d.) s" WindowHeight" "SetDefault ! then ! mask-ptr count s" SearchMask" "SetDefault ! find-buf count s" SearchText" "SetDefault ! path-ptr count s" SearchPath" "SetDefault ! SaveRecentFiles ! SetRegistryKey: ControlToolBar true SaveRestore: ControlToolBar ! r> base ! ! ; : load-defaults ( -- ) *************** *** 259,272 **** :M StartSize: ( -- w h ) base @ >r decimal \ MUST be in decimal when loading defaults ! InitRegistry: self ! s" WindowWidth" "GetDefaultValue 0= IF drop 400 THEN ! s" WindowHeight" "GetDefaultValue 0= IF drop 400 THEN r> base ! ;M :M StartPos: ( -- x y ) base @ >r decimal \ MUST be in decimal when loading defaults ! InitRegistry: self ! s" WindowLeft" "GetDefaultValue 0= IF drop 0 THEN ! s" WindowTop" "GetDefaultValue 0= IF drop 0 THEN r> base ! ;M --- 260,273 ---- :M StartSize: ( -- w h ) base @ >r decimal \ MUST be in decimal when loading defaults ! InitRegistry: self ! s" WindowWidth" "GetDefaultValue 0= IF drop 400 THEN ! s" WindowHeight" "GetDefaultValue 0= IF drop 400 THEN r> base ! ;M :M StartPos: ( -- x y ) base @ >r decimal \ MUST be in decimal when loading defaults ! InitRegistry: self ! s" WindowLeft" "GetDefaultValue 0= IF drop 0 THEN ! s" WindowTop" "GetDefaultValue 0= IF drop 0 THEN r> base ! ;M *************** *** 274,318 **** LoadAppIcon ;M ! :M On_Init: ( -- ) ! On_Init: super ! InitScintillaControl \ Dienstag, August 03 2004 dbu ! AccelTable EnableAccelerators \ init the accelerator table GetHandle: self Create: ScintillaStatusbar self Start: TheRebar ! EnableToolbar ! load-defaults ReSize: self ! ;M :M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam ) ! over LOWORD ( command ID ) dup ! IsCommand? IF DoCommand \ intercept Toolbar and shortkey commands ELSE drop OnWmCommand: Super \ intercept Menu commands THEN ;M ! :M WM_CLOSE ( h m w l -- res ) ! CloseAll: self ! NotCancelled \ if we don't cancel the close ! IF CloseBrowser \ close the browser window ! save-defaults \ save properties in registry ! ExitScintillaControl \ terminate the Scintilla control ! AccelTable DisableAccelerators \ free the accelerator table ! bye \ then terminate the program ! ELSE 1 \ else abort program termination ! THEN ;M ! :M On_Done: ( -- ) ! Turnkeyed? IF 0 call PostQuitMessage drop THEN ! On_Done: Super ;M :M WM_INITMENU ( h m w l -- res ) \ enable/disable the menu items ! EnableMenuBar ;M :M MessageBox: ( szText szTitle style -- result ) ! 3reverse hWnd Call MessageBox ;M :M WM_NOTIFY ( h m w l -- res ) ! Handle_Notify: ControlToolbar ;M :M Win32Forth: ( hndl msg wParam lParam -- ) \ respond to Win32Forth messages --- 275,319 ---- LoadAppIcon ;M ! :M On_Init: ( -- ) ! On_Init: super ! InitScintillaControl \ Dienstag, August 03 2004 dbu ! AccelTable EnableAccelerators \ init the accelerator table GetHandle: self Create: ScintillaStatusbar self Start: TheRebar ! EnableToolbar ! load-defaults ReSize: self ! ;M :M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam ) ! over LOWORD ( command ID ) dup ! IsCommand? IF DoCommand \ intercept Toolbar and shortkey commands ELSE drop OnWmCommand: Super \ intercept Menu commands THEN ;M ! :M WM_CLOSE ( h m w l -- res ) ! CloseAll: self ! NotCancelled \ if we don't cancel the close ! IF CloseBrowser \ close the browser window ! save-defaults \ save properties in registry ! ExitScintillaControl \ terminate the Scintilla control ! AccelTable DisableAccelerators \ free the accelerator table ! bye \ then terminate the program ! ELSE 1 \ else abort program termination ! THEN ;M ! :M On_Done: ( -- ) ! Turnkeyed? IF 0 call PostQuitMessage drop THEN ! On_Done: Super ;M :M WM_INITMENU ( h m w l -- res ) \ enable/disable the menu items ! EnableMenuBar ;M :M MessageBox: ( szText szTitle style -- result ) ! 3reverse hWnd Call MessageBox ;M :M WM_NOTIFY ( h m w l -- res ) ! Handle_Notify: ControlToolbar ;M :M Win32Forth: ( hndl msg wParam lParam -- ) \ respond to Win32Forth messages |
|
From: Ezra B. <ezr...@us...> - 2005-11-06 05:41:07
|
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11567/apps/ForthForm Modified Files: FORTHFORM.F Log Message: Bug fix ( I hope! ) Index: FORTHFORM.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORTHFORM.F,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** FORTHFORM.F 4 Nov 2005 06:40:15 -0000 1.10 --- FORTHFORM.F 6 Nov 2005 05:40:56 -0000 1.11 *************** *** 7,11 **** anew -ForthForm.f ! : sysgen ; \ : withbgnd ; \ add the ForthForm folder's to our path list --- 7,11 ---- anew -ForthForm.f ! : sysgen ; \ : withbgnd ; \ add the ForthForm folder's to our path list *************** *** 534,538 **** --- 534,547 ---- ; + : ?data-size ( -- ) + frmdata-size 0<> ctrldata-size 0<> and ?exit + new> Form dup>r GetData: [ ] nip to frmdata-size + r> Dispose \ discard + new> ControlObject dup>r Getdata: [ ] nip to ctrldata-size + r> Dispose \ discard + ; + : check-file { fname fcnt \ fsize -- f } \ check integrity of file before opening + ?data-size fname fcnt SetName: TheFile \ Open: TheFile ?dup ?exit *************** *** 722,726 **** #IFDEF withbgnd self Start: BkGndImageWindow - \ WS_CLIPSIBLINGS WS_CLIPCHILDREN or +Style: BkGndImageWindow FIT_SIZE SetViewMode: BkGndImageWindow GetBackGroundImage --- 731,734 ---- *************** *** 1026,1033 **** z" ToolBar" SetRegistryKey: ControlToolBar - new> Form dup>r GetData: [ ] nip to frmdata-size - r> Dispose \ discard - new> ControlObject dup>r Getdata: [ ] nip to ctrldata-size - r> Dispose \ discard ; --- 1034,1037 ---- |
|
From: Ezra B. <ezr...@us...> - 2005-11-06 05:41:07
|
Update of /cvsroot/win32forth/win32forth/doc/ForthForm In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11567/doc/ForthForm Modified Files: FF-History.htm Log Message: Bug fix ( I hope! ) Index: FF-History.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/ForthForm/FF-History.htm,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** FF-History.htm 4 Nov 2005 06:40:15 -0000 1.4 --- FF-History.htm 6 Nov 2005 05:40:56 -0000 1.5 *************** *** 26,29 **** --- 26,34 ---- <P ALIGN=LEFT> + + <b>November 06, 2005 </b> - I think I figured out the console problem. Seems to have been + a bug in the routine to check the integrity of a file. Newing and disposing objects before + main window ( or some reason! ) seems to be a no-no. <br><br> + <b>November 03, 2005 </b> - Updated to use gdiFont class. <br><br> |
|
From: Rod O. <rod...@us...> - 2005-11-05 22:22:40
|
Update of /cvsroot/win32forth/win32forth/apps/ProMgr In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31285/apps/ProMgr Modified Files: HexViewer.f Log Message: Rod: fixed problems with sizing HexViewer window. It was not updating when sizing right pane in ProjectManager and Scrollbar was not in correct position when it reappeared. Index: HexViewer.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ProMgr/HexViewer.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** HexViewer.f 1 Nov 2005 23:17:36 -0000 1.1 --- HexViewer.f 5 Nov 2005 22:22:30 -0000 1.2 *************** *** 68,71 **** --- 68,72 ---- :M On_Init: ( -- ) On_Init: super + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop 8 Width: fdFont 14 Height: fdFont *************** *** 74,79 **** --- 75,84 ---- ;M + : set-scrollpos ( -- ) \ position the vertical button in the scroll bar + TRUE cur-first-line SB_VERT GetHandle: self Call SetScrollPos drop ; + :m on_size: ( -- ) set-params + set-scrollpos ;m *************** *** 121,125 **** SaveDC: dc \ save device context Handle: fdFont SetFont: dc \ set the font to be used ! screen-rows 0 do 0 char-height i * i cur-first-line + dup last-line# >= --- 126,130 ---- SaveDC: dc \ save device context Handle: fdFont SetFont: dc \ set the font to be used ! screen-rows 1+ 0 do 0 char-height i * i cur-first-line + dup last-line# >= *************** *** 162,169 **** ENDCASE r>drop \ position the vertical button in the scroll bar ! TRUE cur-first-line SB_VERT ! GetHandle: self Call SetScrollPos drop ! ! 0 ;M :m on_done: ( -- ) --- 167,172 ---- ENDCASE r>drop \ position the vertical button in the scroll bar ! set-scrollpos ! 0 ;M :m on_done: ( -- ) |
|
From: Dirk B. <db...@us...> - 2005-11-05 14:08:21
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22774/src/gdi Modified Files: gdiDC.f gdiMetafile.f Log Message: Removed usage of TempRect to avoid trouble with applications that use it, too. Index: gdiMetafile.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiMetafile.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** gdiMetafile.f 5 Nov 2005 13:22:16 -0000 1.2 --- gdiMetafile.f 5 Nov 2005 14:08:13 -0000 1.3 *************** *** 18,21 **** --- 18,23 ---- :class gdiMetafile <super gdiObject + rectangle RECT + :M ClassInit: ( -- ) ClassInit: super *************** *** 60,65 **** \ Play the metafile in a rectangle :M PlayInRect: ( left top right bottom hDestDC -- ) ! GetGdiObjectHandle >r SetRect: TempRect ! AddrOf: TempRect hObject r> call PlayEnhMetaFile drop ;M --- 62,67 ---- \ Play the metafile in a rectangle :M PlayInRect: ( left top right bottom hDestDC -- ) ! GetGdiObjectHandle >r SetRect: RECT ! AddrOf: RECT hObject r> call PlayEnhMetaFile drop ;M Index: gdiDC.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiDC.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** gdiDC.f 5 Nov 2005 10:53:27 -0000 1.3 --- gdiDC.f 5 Nov 2005 14:08:13 -0000 1.4 *************** *** 25,28 **** --- 25,29 ---- gdiTEXTMETRIC TEXTMETRIC gdiPOINT POINT + rectangle RECT : GetObjectColor { colorref -- colorref } *************** *** 601,606 **** \ interior. :M InvertRect: ( left top right bottom -- ) ! SetRect: TempRect ! Addrof: TempRect hObject Call InvertRect ?win-error ;M \ ---------------------------------------------------------------------- --- 602,607 ---- \ interior. :M InvertRect: ( left top right bottom -- ) ! SetRect: RECT ! Addrof: RECT hObject Call InvertRect ?win-error ;M \ ---------------------------------------------------------------------- *************** *** 703,707 **** : InitRect ( left top right bottom hBrush -- hBrush &rect ) ! GetGdiObjectHandle >r SetRect: TempRect r> Addrof: TempRect ; \ The FillRect method fills a rectangle by using the specified brush. --- 704,708 ---- : InitRect ( left top right bottom hBrush -- hBrush &rect ) ! GetGdiObjectHandle >r SetRect: RECT r> Addrof: RECT ; \ The FillRect method fills a rectangle by using the specified brush. |
|
From: Dirk B. <db...@us...> - 2005-11-05 14:08:21
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22774/src Modified Files: Dc.f Log Message: Removed usage of TempRect to avoid trouble with applications that use it, too. Index: Dc.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Dc.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** Dc.f 1 Nov 2005 12:21:40 -0000 1.10 --- Dc.f 5 Nov 2005 14:08:12 -0000 1.11 *************** *** 29,34 **** int currentfont - Rectangle FillRect - :M ClassInit: ( -- ) ClassInit: super --- 29,32 ---- *************** *** 321,326 **** colorref NewColor: PRINTFILLCOLOR Brush: PRINTFILLCOLOR ! left top right bottom SetRect: FillRect ! FillRect.AddrOf GetHandle: super ( 3 win-parameters ) Call FillRect ?win-error ;M --- 319,324 ---- colorref NewColor: PRINTFILLCOLOR Brush: PRINTFILLCOLOR ! left top right bottom SetRect: RECT ! RECT.AddrOf GetHandle: super ( 3 win-parameters ) Call FillRect ?win-error ;M |
|
From: Dirk B. <db...@us...> - 2005-11-05 13:22:24
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12989/src/gdi Modified Files: gdiBase.f gdiMetafile.f gdiWindowDc.f Log Message: Fixed some problems in the gdiClass Library I found when trying the Metafile demo as a turnkey application. Index: gdiBase.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiBase.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiBase.f 1 Nov 2005 12:21:40 -0000 1.1 --- gdiBase.f 5 Nov 2005 13:22:16 -0000 1.2 *************** *** 141,145 **** :M SetHandle: ( hObject -- ) ! Destroy: self to hObject ;M --- 141,145 ---- :M SetHandle: ( hObject -- ) ! Destroy: [ self ] to hObject ;M *************** *** 170,178 **** repeat drop ; ! : init-gdi-objects ( -- ) \ clear all font handles [getmethod] ZeroHandle: GdiObject do-objects ; : destroy-gdi-objects ( -- ) \ destroy all font handles ! [getmethod] Destroy: GdiObject do-objects ; initialization-chain chain-add init-gdi-objects --- 170,181 ---- repeat drop ; ! : init-gdi-objects ( -- ) \ clear all handles [getmethod] ZeroHandle: GdiObject do-objects ; + :M destroy-gdi-objects: ( -- ) \ destory this object + 0 SetHandle: self ;M + : destroy-gdi-objects ( -- ) \ destroy all font handles ! [getmethod] destroy-gdi-objects: GdiObject do-objects ; initialization-chain chain-add init-gdi-objects Index: gdiMetafile.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiMetafile.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiMetafile.f 1 Nov 2005 12:21:40 -0000 1.1 --- gdiMetafile.f 5 Nov 2005 13:22:16 -0000 1.2 *************** *** 60,65 **** \ Play the metafile in a rectangle :M PlayInRect: ( left top right bottom hDestDC -- ) ! GetGdiObjectHandle >r SetRect: TempRect AddrOf: TempRect ! hObject r> call PlayEnhMetaFile ?win-error ;M \ Copy the metafile to the clipboard --- 60,66 ---- \ Play the metafile in a rectangle :M PlayInRect: ( left top right bottom hDestDC -- ) ! GetGdiObjectHandle >r SetRect: TempRect ! AddrOf: TempRect hObject r> ! call PlayEnhMetaFile drop ;M \ Copy the metafile to the clipboard Index: gdiWindowDc.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiWindowDc.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiWindowDc.f 1 Nov 2005 12:21:40 -0000 1.1 --- gdiWindowDc.f 5 Nov 2005 13:22:16 -0000 1.2 *************** *** 44,48 **** : SetHandle ( hDC -- f ) ! SetHandle: super Valid?: super ; --- 44,48 ---- : SetHandle ( hDC -- f ) ! to hObject Valid?: super ; |
|
From: Dirk B. <db...@us...> - 2005-11-05 13:22:23
|
Update of /cvsroot/win32forth/win32forth/demos/GdiDemo In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12989/demos/GdiDemo Modified Files: Metafile.f Log Message: Fixed some problems in the gdiClass Library I found when trying the Metafile demo as a turnkey application. Index: Metafile.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/GdiDemo/Metafile.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Metafile.f 5 Nov 2005 10:53:26 -0000 1.2 --- Metafile.f 5 Nov 2005 13:22:16 -0000 1.3 *************** *** 10,14 **** needs gdi/gdi.f \ the GDI class library ! 0 value create-tunkey? \ ---------------------------------------------------------------------- --- 10,14 ---- needs gdi/gdi.f \ the GDI class library ! 1 value create-tunkey? \ ---------------------------------------------------------------------- *************** *** 29,32 **** --- 29,33 ---- create Text1 ," This is a Text" create Text2 ,"TEXT" "This is a Text with a\TTAB" + int Created? winver 1 > [if] \ sorry only Win98 and better *************** *** 93,96 **** --- 94,98 ---- if \ save it FileName count Save: tMetaDC drop + true to Created? then Destroy: tMetaDC *************** *** 107,117 **** :M On_Paint: ( -- ) ! GetHandle: self GetDC: tDC ! if LoadAndDrawIt ! Release: tDC then ;M :M Start: ( -- ) \ create a Pen hWnd ChooseColor: tPen 0= --- 109,123 ---- :M On_Paint: ( -- ) ! Created? ! if hWnd GetDC: tDC ! if LoadAndDrawIt ! Release: tDC ! then then ;M :M Start: ( -- ) + FALSE to Created? \ we don't have a Metafile to display yet + \ create a Pen hWnd ChooseColor: tPen 0= *************** *** 148,160 **** :M On_Done: ( -- ) ! TURNKEYED? 0= ! if Destroy: tPen ! Destroy: tSolidBrush ! Destroy: tHatchBrush ! Destroy: tDC ! Destroy: tMetaDC ! then ! On_Done: super ;M ! ;object --- 154,160 ---- :M On_Done: ( -- ) ! On_Done: super ! turnkeyed? if bye then ! ;M ;object *************** *** 168,172 **** create-tunkey? [if] ! ' GdiDemo turnkey GdiDemo.exe [else] GdiDemo --- 168,172 ---- create-tunkey? [if] ! ' GdiDemo turnkey Metafile.exe [else] GdiDemo |
|
From: Dirk B. <db...@us...> - 2005-11-05 10:53:36
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17197/src/gdi Modified Files: gdiDC.f Log Message: Fixed a bug in the SetArcDirection: method of the gdiDC class. Index: gdiDC.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiDC.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** gdiDC.f 2 Nov 2005 16:30:56 -0000 1.2 --- gdiDC.f 5 Nov 2005 10:53:27 -0000 1.3 *************** *** 386,390 **** \ AD_CLOCKWISE Figures drawn clockwise. :M SetArcDirection: ( Direction -- OldDirection ) ! if hObject call SetArcDirection then ;M \ The GetArcDirection method retrieves the current arc direction for the --- 386,390 ---- \ AD_CLOCKWISE Figures drawn clockwise. :M SetArcDirection: ( Direction -- OldDirection ) ! hObject call SetArcDirection ;M \ The GetArcDirection method retrieves the current arc direction for the |
|
From: Dirk B. <db...@us...> - 2005-11-05 10:53:36
|
Update of /cvsroot/win32forth/win32forth/demos/GdiDemo In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17197/demos/GdiDemo Modified Files: Metafile.f Log Message: Fixed a bug in the SetArcDirection: method of the gdiDC class. Index: Metafile.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/GdiDemo/Metafile.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Metafile.f 1 Nov 2005 12:21:40 -0000 1.1 --- Metafile.f 5 Nov 2005 10:53:26 -0000 1.2 *************** *** 30,33 **** --- 30,41 ---- create Text2 ,"TEXT" "This is a Text with a\TTAB" + winver 1 > [if] \ sorry only Win98 and better + :M SetArcDirection: ( Direction -- OldDirection ) + SetArcDirection: tMetaDC ;M + [else] + :M SetArcDirection: ( Direction -- OldDirection ) + ;M + [then] + : CreateIt ( -- ) hWnd GetDC: tDC |
|
From: Ezra B. <ezr...@us...> - 2005-11-04 06:40:23
|
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2159/apps/ForthForm Modified Files: CreatePropertyForm.f FORMCONTROLS.F FORMOBJECT.F FORTHFORM.F Removed Files: EXFONT.F Log Message: Updated to use new gdiFont class. Index: FORTHFORM.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORTHFORM.F,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** FORTHFORM.F 1 Nov 2005 23:14:04 -0000 1.9 --- FORTHFORM.F 4 Nov 2005 06:40:15 -0000 1.10 *************** *** 37,41 **** needs ScintillaControl.f \ editor for FormPad needs FileLister.f \ directory viewer - needs exfont.f \ enhanced font class to allow runtime font selection needs Win32Help.f needs Resources.f --- 37,40 ---- *************** *** 715,719 **** s" MS Sans Serif" SetFaceName: ControlFont 8 Width: ControlFont ! Create: ControlFont self to TheMainWindow --- 714,718 ---- s" MS Sans Serif" SetFaceName: ControlFont 8 Width: ControlFont ! Create: ControlFont drop self to TheMainWindow Index: CreatePropertyForm.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/CreatePropertyForm.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** CreatePropertyForm.f 1 Nov 2005 23:14:04 -0000 1.1 --- CreatePropertyForm.f 4 Nov 2005 06:40:15 -0000 1.2 *************** *** 88,92 **** s" SetFaceName: WinFont" append&crlf&tabs s" 8 Width: WinFont" append&crlf&tabs ! s" Create: WinFont" append&crlf +crlf 2tabs s" ['] ontab IsChangeFunc: SheetTab" append&crlf +crlf 2tabs --- 88,92 ---- s" SetFaceName: WinFont" append&crlf&tabs s" 8 Width: WinFont" append&crlf&tabs ! s" Create: WinFont drop " append&crlf +crlf 2tabs s" ['] ontab IsChangeFunc: SheetTab" append&crlf +crlf 2tabs Index: FORMCONTROLS.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORMCONTROLS.F,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** FORMCONTROLS.F 1 Nov 2005 23:14:04 -0000 1.4 --- FORMCONTROLS.F 4 Nov 2005 06:40:15 -0000 1.5 *************** *** 628,633 **** ;RecordSize: SizeOf(ctrlData) ! UserFont TheFont ! \ BitmapObject ctrlBitmap \ doesn't appear to be and causes problems with bytes IVAR above gah int oldstyle --- 628,632 ---- ;RecordSize: SizeOf(ctrlData) ! Font TheFont int oldstyle *************** *** 750,760 **** :M CreateFont: ( -- ) Delete: TheFont ! Create: TheFont Handle: TheFont SetFont: TheControl ;M :M GetUserFont: ( -- ) Delete: TheFont ! GetUserFont: TheFont drop ! LogFontStruct: TheFont ctrlFont swap move \ save font info true to fontchanged CreateFont: self --- 749,759 ---- :M CreateFont: ( -- ) Delete: TheFont ! Create: TheFont drop Handle: TheFont SetFont: TheControl ;M :M GetUserFont: ( -- ) Delete: TheFont ! GetHandle: ActiveForm Choose: TheFont drop ! GetLogFont: TheFont ctrlFont sizeof(LogFont) move \ save font info true to fontchanged CreateFont: self *************** *** 764,768 **** : default-font ( -- ) Delete: TheFont ! ControlFont.LogFont LogFontStruct: TheFont move ControlFont.LogFont ctrlFont sizeof(LogFont) move ; --- 763,767 ---- : default-font ( -- ) Delete: TheFont ! ControlFont.LogFont TheFont.LogFont sizeof(LogFont) move ControlFont.LogFont ctrlFont sizeof(LogFont) move ; *************** *** 779,783 **** \ the following is done to correct any previously created forms which have the \ font flag invalidly set and no font information ! TheFont.LogFont 7 cells+ ( lfFaceName ) zcount nip 0= if default-font false to fontchanged --- 778,782 ---- \ the following is done to correct any previously created forms which have the \ font flag invalidly set and no font information ! GetFaceName: TheFont nip 0= if default-font false to fontchanged Index: FORMOBJECT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORMOBJECT.F,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** FORMOBJECT.F 1 Nov 2005 23:14:04 -0000 1.8 --- FORMOBJECT.F 4 Nov 2005 06:40:15 -0000 1.9 *************** *** 1426,1430 **** FontChanged: ThisControl if s" Set-" append fontname append&crlf 2tabs ! s" Create: " append fontname append&crlf 2tabs s" Handle: " append fontname append s" SetFont: " append GetName: ThisControl append else s" Handle: Winfont SetFont: " append GetName: ThisControl append --- 1426,1430 ---- FontChanged: ThisControl if s" Set-" append fontname append&crlf 2tabs ! s" Create: " append fontname append s" drop" append&crlf 2tabs s" Handle: " append fontname append s" SetFont: " append GetName: ThisControl append else s" Handle: Winfont SetFont: " append GetName: ThisControl append *************** *** 1889,1893 **** s" SetFaceName: WinFont" append&crlf 2tabs s" 8 Width: WinFont" append&crlf ! ( create font ) 2tabs s" Create: WinFont" append&crlf +crlf 2tabs s" \ set form color to system color" append&crlf --- 1889,1893 ---- s" SetFaceName: WinFont" append&crlf 2tabs s" 8 Width: WinFont" append&crlf ! ( create font ) 2tabs s" Create: WinFont drop" append&crlf +crlf 2tabs s" \ set form color to system color" append&crlf --- EXFONT.F DELETED --- |
|
From: Ezra B. <ezr...@us...> - 2005-11-04 06:40:23
|
Update of /cvsroot/win32forth/win32forth/doc/ForthForm In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2159/doc/ForthForm Modified Files: FF-History.htm Log Message: Updated to use new gdiFont class. Index: FF-History.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/ForthForm/FF-History.htm,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** FF-History.htm 1 Nov 2005 23:25:36 -0000 1.3 --- FF-History.htm 4 Nov 2005 06:40:15 -0000 1.4 *************** *** 26,29 **** --- 26,30 ---- <P ALIGN=LEFT> + <b>November 03, 2005 </b> - Updated to use gdiFont class. <br><br> <b>November 01, 2005 </b> - Working on enhancing the toolbar design tool. <br><br> |
|
From: Rod O. <rod...@us...> - 2005-11-03 19:21:40
|
Update of /cvsroot/win32forth/win32forth/apps/Sudoku In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32091/apps/Sudoku Modified Files: SudokuResources.f Log Message: Rod: use WAVE resource Index: SudokuResources.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Sudoku/SudokuResources.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** SudokuResources.f 3 Oct 2005 22:04:27 -0000 1.1 --- SudokuResources.f 3 Nov 2005 19:21:28 -0000 1.2 *************** *** 20,23 **** --- 20,24 ---- 150 s" res\arrow_m8.cur" "path-file drop AddCursor 151 s" res\arrow_m9.cur" "path-file drop AddCursor + 153 s" WAVE" asciiz s" Applause7.wav" "path-file drop AddResource false EndUpdate |
|
From: Rod O. <rod...@us...> - 2005-11-03 19:21:11
|
Update of /cvsroot/win32forth/win32forth/apps/Sudoku In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31983/apps/Sudoku Modified Files: Sudoku.f Log Message: Rod: use WAVE resource Index: Sudoku.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Sudoku/Sudoku.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Sudoku.f 8 Oct 2005 08:24:21 -0000 1.2 --- Sudoku.f 3 Nov 2005 19:21:01 -0000 1.3 *************** *** 46,50 **** IF MB_ICONEXCLAMATION call MessageBeep drop THEN ; : PlayApplause ( -- ) ShowSolution ?exit ! SND_ASYNC z" Applause7.wav" call sndPlaySound drop ; 0 value FlatToolbar? 0 value WindowState --- 46,52 ---- IF MB_ICONEXCLAMATION call MessageBeep drop THEN ; : PlayApplause ( -- ) ShowSolution ?exit ! SND_ASYNC SND_RESOURCE or ! AppInst ! 153 call PlaySound drop ; 0 value FlatToolbar? 0 value WindowState *************** *** 843,850 **** \ File Menu ! : InitGame ( -- ) 0 to x 0 to y Redraw: Frame SetCaption: Frame IDM_PAUSE false CheckButton: SudokuToolbar ( ZeroMoves IDM_ESCAPE DoCommand ) false to EditMode false check: hEdit ShowMoves StartTimer ; ! : ?Restart ( -- ) numbers 162 + 81 48 scan nip \ blank squares? IF InitGame ELSE --- 845,854 ---- \ File Menu ! : InitGame ( -- ) 0 to x 0 to y Redraw: Frame IDM_PAUSE false CheckButton: SudokuToolbar ( ZeroMoves IDM_ESCAPE DoCommand ) false to EditMode false check: hEdit ShowMoves StartTimer ; ! : ?Restart ( -- ) ! SetCaption: Frame ! numbers 162 + 81 48 scan nip \ blank squares? IF InitGame ELSE *************** *** 879,883 **** IF Solution ?dup IF Numbers 81 move THEN \ if a full solution just add to current file ! Start ?dup IF Numbers 81 + 81 move CurrentFile Insert: RecentFiles CurrentFile off ClearAll InitGame true to Modified THEN THEN ; IDM_IMPORT SetCommand : OpenRecentFile ( FileName$ -- ) SaveIfModified ?OpenFile ; IDM_OPEN_FILE SetCommand --- 883,887 ---- IF Solution ?dup IF Numbers 81 move THEN \ if a full solution just add to current file ! Start ?dup IF Numbers 81 + 81 move CurrentFile Insert: RecentFiles CurrentFile off ClearAll SetCaption: Frame InitGame true to Modified THEN THEN ; IDM_IMPORT SetCommand : OpenRecentFile ( FileName$ -- ) SaveIfModified ?OpenFile ; IDM_OPEN_FILE SetCommand |
|
From: Ezra B. <ezr...@us...> - 2005-11-03 03:31:34
|
Update of /cvsroot/win32forth/win32forth/doc/ProMgr In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24192/doc/ProMgr Modified Files: ProjectManager.htm Log Message: Updated documentation. ( forgot this one!) Index: ProjectManager.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/ProMgr/ProjectManager.htm,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** ProjectManager.htm 8 Oct 2005 08:24:58 -0000 1.3 --- ProjectManager.htm 3 Nov 2005 03:31:25 -0000 1.4 *************** *** 68,73 **** <p>When a file is selected in the treeview a viewer is opened in the right window. This viewer allows the browsing of text files or .bmp and .ico resource files. Binary files are displayed as a hex view. ! For a hex view only the first 10k of a file is hex dumped. Double-clicking on the selected file ! opens the default application to edit the file. If there is none an error message will be displayed. <br>The ability to hyperlink between source files has also been added. To browse to a --- 68,73 ---- <p>When a file is selected in the treeview a viewer is opened in the right window. This viewer allows the browsing of text files or .bmp and .ico resource files. Binary files are displayed as a hex view. ! Double-clicking on the selected file opens the default application to edit the file. If there is none ! an error message will be displayed. <br>The ability to hyperlink between source files has also been added. To browse to a |
|
From: Dirk B. <db...@us...> - 2005-11-02 16:31:05
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10484/src/gdi Modified Files: gdiDC.f Log Message: Added some conditional compilation for gdi functions that aren't supported under win98. Index: gdiDC.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiDC.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiDC.f 1 Nov 2005 12:21:40 -0000 1.1 --- gdiDC.f 2 Nov 2005 16:30:56 -0000 1.2 *************** *** 108,111 **** --- 108,113 ---- GetStockObject: self SelectObject self ;M + winver win2k >= [IF] \ only w2k or later + \ SetPenColor method sets the current device context (DC) pen color to the \ specified color value. If the device cannot represent the specified color value, *************** *** 134,137 **** --- 136,141 ---- hObject call GetDCBrushColor ;M + [THEN] + \ The Save method saves the current state of the device context by copying \ data describing selected objects and graphic modes (such as the bitmap, *************** *** 375,378 **** --- 379,384 ---- hObject call GetROP2 ;M + winver 1 > [if] \ only Win98 and better + \ SetArcDirection sets the drawing direction to be used for arc and \ rectangle methods. Possible value for nDirection are: *************** *** 380,384 **** \ AD_CLOCKWISE Figures drawn clockwise. :M SetArcDirection: ( Direction -- OldDirection ) - winver 1 > \ only Win98 and better if hObject call SetArcDirection then ;M --- 386,389 ---- *************** *** 388,391 **** --- 393,398 ---- hObject call GetArcDirection ;M + [then] + \ ---------------------------------------------------------------------- \ Coordinate Space and Transformation |
|
From: Ezra B. <ezr...@us...> - 2005-11-01 23:20:27
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28837/src/lib Modified Files: ExUtils.f Log Message: Slight mods. Index: ExUtils.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/ExUtils.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** ExUtils.f 21 Aug 2005 06:22:01 -0000 1.1 --- ExUtils.f 1 Nov 2005 23:20:19 -0000 1.2 *************** *** 9,13 **** The following routines uses shared memory for interprocess communication. Uses the last 1k for info passing, arbitrarily reserving the first 24 bytes for ! process ids. First cell will identify ForthForm. comment; --- 9,13 ---- The following routines uses shared memory for interprocess communication. Uses the last 1k for info passing, arbitrarily reserving the first 24 bytes for ! process ids. First cell will identify ForthForm. Second celll identifies Project Manager. comment; *************** *** 17,20 **** --- 17,21 ---- ed-size msg-buff-len - constant msg-offset \ start of message buffer for ForthForm 102378530 constant FFormID \ identify ForthForm + 872015346 constant ProMgrID \ identify Project Manager 0 value msg-buffer \ pointer to buffer, set at runtime 0 value param-buffer *************** *** 25,28 **** --- 26,45 ---- msg-buffer [ 6 cells ] LITERAL + to param-buffer then ; + + : ?fform-started ( -- f ) + msg-buffer @ FFormID = ; + + : ?promgr-started ( -- f ) + msg-buffer cell+ @ ProMgrID = ; + + : fform-started ( f -- ) + if FFormID + else 0 + then msg-buffer ! ; + + : promgr-started ( f -- ) + if ProMgrID + else 0 + then msg-buffer cell+ ! ; newproc FF_ACTIVATE \ sent on startup *************** *** 31,35 **** \ String building routines ! 1024 64 * constant buffermax buffermax cell+ Pointer BufferAddress --- 48,52 ---- \ String building routines ! 1024 128 * constant buffermax buffermax cell+ Pointer BufferAddress *************** *** 66,75 **** +chars ; - : s"append ( -- ) - [char] s cappend [char] " cappend bl cappend ; - : "append ( -- ) [char] " cappend ; : +crlf ( -- ) 0x0D cappend 0x0A cappend --- 83,98 ---- +chars ; : "append ( -- ) [char] " cappend ; + : s"append ( -- ) + [char] s cappend "append bl cappend ; + + : z"append ( -- ) + [char] z cappend "append bl cappend ; + + : #append ( n -- ) + (.) append bl cappend ; + : +crlf ( -- ) 0x0D cappend 0x0A cappend *************** *** 134,138 **** addr cnt "path-only" temp$ place temp$ +NULL ! NULL \ nShowCmd temp$ 1+ \ default directory Null \ parameters --- 157,161 ---- addr cnt "path-only" temp$ place temp$ +NULL ! SW_SHOWNORMAL \ nShowCmd temp$ 1+ \ default directory Null \ parameters |
|
From: Ezra B. <ezr...@us...> - 2005-11-01 23:17:46
|
Update of /cvsroot/win32forth/win32forth/apps/ProMgr In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27444/apps/ProMgr Modified Files: ProjectManager.f Added Files: HexViewer.f Log Message: Enhance Project Manager a little. Index: ProjectManager.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ProMgr/ProjectManager.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** ProjectManager.f 15 Sep 2005 16:36:08 -0000 1.10 --- ProjectManager.f 1 Nov 2005 23:17:36 -0000 1.11 *************** *** 5,8 **** --- 5,10 ---- comment: + October 07, 2005 - EAB - added class for viewing binary files of any size. + September 5th, 2005 Rod - version 2.01.00 *************** *** 42,46 **** May 15, 2004 08:57:31 PM - factored out project manager into a separate application ! First integrated into ForthForm, butI thought that it would be a little cumbersome to have the additional files required - especially the Zip32.dll and w32fScintilla.dll - distributed with ForthForm. --- 44,48 ---- May 15, 2004 08:57:31 PM - factored out project manager into a separate application ! First integrated into ForthForm, but I thought that it would be a little cumbersome to have the additional files required - especially the Zip32.dll and w32fScintilla.dll - distributed with ForthForm. *************** *** 96,100 **** \ Odd minor version numbers are possibly unstable beta releases. ! Create ProjectVersion ," 2.01.00" needs linklist.f --- 98,102 ---- \ Odd minor version numbers are possibly unstable beta releases. ! Create ProjectVersion ," 2.01.01" needs linklist.f *************** *** 111,114 **** --- 113,117 ---- needs ScintillaHyperEdit.f needs HtmlDisplayWindow.f + needs hexviewer.f \ hex dump class needs RegistrySupport.f needs RecentFiles.f *************** *** 207,216 **** : OpenProjectFile ( -- addr ) - \ ProjectPath count ?dup - \ if SetDir: OpenProjectDialog else drop then s" Project Files|*.fpj|" SetFilter: OpenProjectDialog s" Open Project File" SetTitle: OpenProjectDialog Gethandle: TheProjectWindow Start: OpenProjectDialog ; - \ GetDir: OpenProjectDialog ?dup if ProjectPath place else drop then ; : SelectAFile ( -- addr ) --- 210,216 ---- *************** *** 282,287 **** Start: super - \ 24 22 word-join 0 TB_SETBUTTONSIZE hwnd call SendMessage drop \ does nothing - \ 16 20 word-join 0 TB_SETBITMAPSIZE hwnd call SendMessage drop 16 16 word-join 0 TB_SETBITMAPSIZE hwnd call SendMessage drop \ smaller height of toolbar --- 282,285 ---- *************** *** 561,565 **** TVIF_IMAGE or TVIF_SELECTEDIMAGE or to mask tvitem->tvins - \ tvins 0 TVM_INSERTITEMA hWnd Call SendMessage InsertItem: self IsHandle: ThisItem ; --- 559,562 ---- *************** *** 630,634 **** TVIF_IMAGE or TVIF_SELECTEDIMAGE or to mask tvitem->tvins - \ tvins 0 TVM_INSERTITEMA hWnd Call SendMessage ; InsertItem: self ; --- 627,630 ---- *************** *** 651,661 **** : .buildfile ( -- ) ! mainfile c@ if s" Build file: " else s" No build file set" then new$ dup>r place mainfile count r@ +place ! r@ +null ! r> 1+ 1 SetText: TheStatusBar false to dirty? ; :m setbuildfile: ( addr cnt -- ) --- 647,658 ---- : .buildfile ( -- ) ! mainfile c@ dup if s" Build file: " else s" No build file set" then new$ dup>r place mainfile count r@ +place ! if s" ---- Total files in project= " r@ +place ! totalfiles: self (.) r@ +place ! then r> dup +null 1+ 1 SetText: TheStatusBar false to dirty? ; :m setbuildfile: ( addr cnt -- ) *************** *** 837,841 **** Close: ProjectFile false to Modified - \ 0= s" Project saved!" ?MessageBox ;M s" Error saving project" ?MessageBox ;M --- 834,837 ---- *************** *** 897,901 **** THEN THEN - \ hwndmain ToggleExpandItem: self hwndmain TVE_EXPAND Expand: self hwndmain GetChild: self SelectItem: self --- 893,896 ---- *************** *** 931,935 **** ;Object - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Right Pane \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 926,929 ---- *************** *** 942,945 **** --- 936,940 ---- int viewfont HtmlDisplayControl HtmlBox + HexViewer BinaryBox :M ExWindowStyle: ( -- ) *************** *** 948,952 **** : is-binary-file? ( -- f ) true \ default ! GetBuffer: viewerfile 100 min 0max \ check first 100 bytes bounds ?do i c@ bl < --- 943,947 ---- : is-binary-file? ( -- f ) true \ default ! GetBuffer: viewerfile 1000 min 0max \ check first 1000 bytes bounds ?do i c@ bl < *************** *** 958,962 **** loop not ; ! : Close-viewers ( -- ) Close: ViewBox Close: HtmlBox ; : Start-ViewBox ( -- ) --- 953,958 ---- loop not ; ! : Close-viewers ( -- ) ! Close: ViewBox Close: HtmlBox Close: BinaryBox ; : Start-ViewBox ( -- ) *************** *** 978,1013 **** 0 0 GetSize: self Move: HtmlBox then ; ! ! \ The following routines for hex viewing adapted from "Dump" in kernel ! : H.R ( n1 -- ) \ display n1 as a hex number right ! \ justified in a field of 8 characters ! BASE @ >R HEX ! 0 <# #S #> 8 OVER - +spaces append ! R> BASE ! ; ! ! : H.2 ( n1 -- ) \ display n1 as a HEX number of n2 digits ! BASE @ >R HEX ! 0 <# 2 0 ?DO # LOOP #> append ! R> BASE ! ; ! ! : EMIT. ( n -- ) ! DUP BL 255 BETWEEN 0= IF DROP [CHAR] . THEN cappend ; ! ! : HexView ( -- ) ( hex byte format with ascii ) ! initbuffer GetBuffer: viewerfile ! \ our buffer is limited so dump only first 10k ! [ 10 1024 * ] LITERAL min 0max ! over +no-wrap dup rot ! ?do i h.r s" | " append ! i 16 +no-wrap over umin i ! 2dup ! do i c@ h.2 ! bl cappend ! i j 7 + = if bl cappend then ! loop 2dup - 16 over - 3 * swap 8 < - +spaces ! s" |" append ! do i c@ emit. ! loop s" |" append&crlf ! 16 +loop drop Thebuffer Settextz: Viewbox ; : LoadCursor ( z$ -- h ) >r LR_LOADFROMFILE 0 0 IMAGE_CURSOR r> 0 call LoadImage ; --- 974,983 ---- 0 0 GetSize: self Move: HtmlBox then ; ! ! : Start-BinaryBox ( -- ) ! GetHandle: BinaryBox 0= ! if self Start: BinaryBox ! AutoSize: BinaryBox ! then ; : LoadCursor ( z$ -- h ) >r LR_LOADFROMFILE 0 0 IMAGE_CURSOR r> 0 call LoadImage ; *************** *** 1029,1033 **** ( default ) swap is-binary-file? ! IF start-ViewBox HexView ELSE start-ViewBox GetBuffer: viewerfile SetTextz: ViewBox --- 999,1003 ---- ( default ) swap is-binary-file? ! IF Start-BinaryBox GetBuffer: viewerfile Dump: BinaryBox ELSE start-ViewBox GetBuffer: viewerfile SetTextz: ViewBox *************** *** 1043,1046 **** --- 1013,1017 ---- GetHandle: ViewBox if 0 0 Getsize: self Move: ViewBox then GetHandle: HtmlBox if Autosize: HtmlBox then + GetHandle: BinaryBox if AutoSize: BinaryBox then ;M *************** *** 1074,1080 **** then ;M ;Object - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Project StatusBar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 1045,1053 ---- then ;M + :M Close: ( -- ) + Close-Viewers ;M + ;Object \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Project StatusBar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 1089,1093 **** ;Object - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Project help window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 1062,1065 ---- *************** *** 1229,1233 **** :M DefaultIcon: ( -- hIcon ) \ return the default icon handle for window 101 appInst Call LoadIcon - \ s" src\res\Project.ico" Prepend<home>\ LoadIconFile ;M --- 1201,1204 ---- *************** *** 1245,1249 **** WS_CLIPCHILDREN +Style: self self to TheProjectWindow - \ ProjectMenu SetMenuBar: self \ set in ClassInit ptoolbar to TheToolBar 1024 SetID: TheToolBar --- 1216,1219 ---- *************** *** 1288,1291 **** --- 1258,1263 ---- Options SaveSettings ProjectManager SaveSettings + false promgr-started + SaveRecentFiles SaveRecentFiles MenuHandle: CurrentMenu ?dup *************** *** 1795,1802 **** ?do GetName: [ Data@: ThisList ] zcount 2dup LibFile? NoLibfiles and IF 2drop [ also hidden ] -1 +to #FilesTobeZipped [ forth ] ! ELSE AddFileToBeZipped ( a.k.a +zfile ) ! THEN ! \ AddFileToBeZipped ( a.k.a +zfile ) ! >NextLink: ThisList loop cell +loop 0 to zprintcnt true to dirty? ThisPath count goZip! --- 1767,1773 ---- ?do GetName: [ Data@: ThisList ] zcount 2dup LibFile? NoLibfiles and IF 2drop [ also hidden ] -1 +to #FilesTobeZipped [ forth ] ! ELSE AddFileToBeZipped ( a.k.a +zfile ) ! THEN ! >NextLink: ThisList loop cell +loop 0 to zprintcnt true to dirty? ThisPath count goZip! *************** *** 1959,1975 **** then r> close-file drop ; ! : PM ( -- ) ! WindowSettings RestoreSettings ! Options RestoreSettings ! InitScintillaControl \ Dienstag, August 03 2004 dbu \+ sysgen read-path-file ! init-msg-buffer ! Start: ProjectWindow ! RestoreRecentFiles ! 6 SetNumber: RecentFiles \+ sysgen HandleCmdLine \+ sysgen PMAccelerators EnableAccelerators ! SetProjectTitle ! ; --- 1930,1947 ---- then r> close-file drop ; ! : PM ( -- ) ! WindowSettings RestoreSettings ! Options RestoreSettings ! InitScintillaControl \ Dienstag, August 03 2004 dbu \+ sysgen read-path-file ! init-msg-buffer ! Start: ProjectWindow ! \+ sysgen true promgr-started ! RestoreRecentFiles ! 6 SetNumber: RecentFiles \+ sysgen HandleCmdLine \+ sysgen PMAccelerators EnableAccelerators ! SetProjectTitle ! ; --- NEW FILE: HexViewer.f --- \ HexViewer.F Adapted from FileDump.f needs ExUtils.f :class HexViewer <super child-window int screen-cols int screen-rows 0 constant first-line# \ first line number int last-line# \ last line number int last-top-line# int cur-first-line \ current first line position 16 constant bytes/line int buff-len \ length of the buffer int buff-ptr \ address of the buffer int eob-ptr \ end of buffer pointer Font fdFont :m classinit: ( -- ) classinit: super NextID to ID 0 to buff-ptr 0 to buff-len 0 to eob-ptr 200 to last-line# last-line# 20 - to last-top-line# ;m :m home: ( -- ) first-line# to cur-first-line paint: self ;m : set-params ( -- ) temprect GetClientrect: self temprect.right to width temprect.bottom to height width char-width / to screen-cols height char-height / to screen-rows last-line# screen-rows - 0max to last-top-line# \ set the vertical scroll limits false last-top-line# first-line# SB_VERT GetHandle: self Call SetScrollRange drop ; : release-buffptr ( -- ) buff-ptr ?dup if release 0 to buff-ptr then ; : alloc-buffptr { size -- } release-buffptr size cell+ malloc to buff-ptr ; : hex-view ( a1 n1 -- ) dup to buff-len alloc-buffptr \ keep my own copy, just in case buff-ptr buff-len move hwnd 0= ?exit buff-len bytes/line /mod swap if 1+ then to last-line# buff-ptr buff-len + to eob-ptr set-params home: self ; :M Dump: ( addr cnt -- ) hex-view ;M :M On_Init: ( -- ) On_Init: super 8 Width: fdFont 14 Height: fdFont s" Courier" SetFaceName: fdFont Create: fdFont ;M :m on_size: ( -- ) set-params ;m :m startpos: 0 0 ;m :m startsize: 75 char-width * 20 char-height * ;m \ The following routines for hex viewing adapted from "Dump" in kernel : H.R ( n1 -- ) \ display n1 as a hex number right \ justified in a field of 8 characters BASE @ >R HEX 0 <# #S #> 8 OVER - +spaces append R> BASE ! ; : H.2 ( n1 -- ) \ display n1 as a HEX number of n2 digits BASE @ >R HEX 0 <# 2 0 ?DO # LOOP #> append R> BASE ! ; : EMIT. ( n -- ) DUP BL 255 BETWEEN 0= IF DROP [CHAR] . THEN cappend ; : dump-line { n -- addr cnt } ( hex byte format with ascii ) initbuffer n bytes/line * buff-ptr + dup 16 + eob-ptr >= \ limit dump if eob-ptr over - \ to available else bytes/line \ characters then over +no-wrap dup rot ?do i h.r s" | " append i 16 +no-wrap over umin i 2dup do i c@ h.2 bl cappend i j 7 + = if bl cappend then loop 2dup - 16 over - 3 * swap 8 < - +spaces s" |" append do i c@ emit. loop s" |" append 16 +loop drop TheBuffer ; :m on_paint: ( -- ) 0 0 GetSize: self WHITE FillArea: dc buff-ptr 0= ?exitm SaveDC: dc \ save device context Handle: fdFont SetFont: dc \ set the font to be used screen-rows 0 do 0 char-height i * i cur-first-line + dup last-line# >= if drop spcs 80 else dump-line then textout: dc loop RestoreDC: dc ;m :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super WS_VSCROLL or \ add vertical scroll bar ;M :m vposition: ( n -- ) \ move to position n 0max last-top-line# min to cur-first-line paint: self ;m :m vscroll: ( n -- ) \ move n lines up or down cur-first-line + vposition: self ;m :m end: ( -- ) \ move to end, in this case it's 100 bytes down to pad last-top-line# to cur-first-line paint: self ;m :m vpage: ( n -- ) \ down or up n pages screen-rows 1- * vscroll: self ;m :M WM_VSCROLL ( h m w l -- res ) swap word-split >r CASE SB_BOTTOM of End: self endof SB_TOP of Home: self endof SB_LINEDOWN of 1 VScroll: self endof SB_LINEUP of -1 VScroll: self endof SB_PAGEDOWN of 1 VPage: self endof SB_PAGEUP of -1 VPage: self endof SB_THUMBPOSITION of r@ VPosition: self endof SB_THUMBTRACK of r@ VPosition: self endof ENDCASE r>drop \ position the vertical button in the scroll bar TRUE cur-first-line SB_VERT GetHandle: self Call SetScrollPos drop 0 ;M :m on_done: ( -- ) release-buffptr Delete: fdFont on_done: super ;m :M AutoSize: ( -- ) tempRect.AddrOf GetClientRect: Parent 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M :M ~: ( -- ) release-buffptr ;m ;class \s |
|
From: Ezra B. <ezr...@us...> - 2005-11-01 23:14:17
|
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25341/apps/ForthForm Modified Files: CONTROLPROPERTYII.ff CreateToolBar.f FORMCONTROLS.F FORMOBJECT.F FORMPROPERTY.F FORMTOOLBAR.F FORTHFORM.F FormHelp.f FormMenu.f Forms.frm PREFERENCES.ff RECT.F Added Files: CreatePropertyForm.f CreatePropertyForm.ff EXFONT.F Log Message: ForthForm update 2.02.05 Index: RECT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/RECT.F,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** RECT.F 21 Aug 2005 06:22:00 -0000 1.2 --- RECT.F 1 Nov 2005 23:14:04 -0000 1.3 *************** *** 12,16 **** simple. ! Comment; anew -rect.f --- 12,16 ---- simple. ! Comment; anew -rect.f *************** *** 30,34 **** BLACK to drawcolor R2_NOT to drawmode \ inverse drawing by default ! Color: RED NewColor: DotColor PS_DOT Put: DotColor.PenStyle InitColor: DotColor --- 30,34 ---- BLACK to drawcolor R2_NOT to drawmode \ inverse drawing by default ! Color: BLACK NewColor: DotColor PS_DOT Put: DotColor.PenStyle InitColor: DotColor *************** *** 70,99 **** Addr: DotColor to drawcolor DrawNormal: self ! to drawmode to drawcolor ;M ! /* ! \ Works better on hi-color systems ! : XorPixel { x y -- } ! x y GetPixel: thedc ! 0x00FFFFFF xor ! y x GetHandle: thedc Call SetPixel drop ; ! ! : XorDrawRectangle ( -- ) ! right left - 1+ 0max 0 ! ?do left i + top XorPixel \ top horizontal ! loop bottom top - 1+ 0max 0 ! ?do left top i + XorPixel \ left and right ! right top i + XorPixel \ vertical ! loop right left - 1+ 0max 0 ! ?do left i + bottom XorPixel \ bottom horizontal ! loop ; ! ! :M XorDraw: ( -- ) ! thedc ! if XorDrawRectangle ! then ;M - :M XorErase: ( -- ) - XorDraw: self ;M - */ :M Sunken: { color1 color2 -- } thedc --- 70,76 ---- Addr: DotColor to drawcolor DrawNormal: self ! to drawmode to drawcolor ! ;M :M Sunken: { color1 color2 -- } thedc Index: CreateToolBar.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/CreateToolBar.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** CreateToolBar.f 25 Sep 2005 20:00:35 -0000 1.3 --- CreateToolBar.f 1 Nov 2005 23:14:04 -0000 1.4 *************** *** 2,5 **** --- 2,6 ---- \ needs CreateToolBarForm.frm + 0 value DesignToolBar :Object PreviewWindow <Super Window *************** *** 11,14 **** --- 12,18 ---- dint dimensions create title$ ," Bitmap Preview Window" 0 , + Rect bitmapbox + 0 value savex + 0 value savey : NoBitmap ( -- ) *************** *** 26,30 **** hwnd 0= if Start: self ! then BitmapFile count addr cnt caps-compare 0= ?exitm &bitmap ?dup if release 0 to &bitmap --- 30,34 ---- hwnd 0= if Start: self ! then BitmapFile count addr cnt istr= ?exitm &bitmap ?dup if release 0 to &bitmap *************** *** 48,55 **** dimensions ;M :M On_Paint: ( -- ) BitmapFile c@ 0<> &Bitmap 0<> and if &bitmap SetBitmap: TheBitmap ! 0 0 dc.hdc ShowBitmap: TheBitmap else 0 0 width height WHITE FillArea: dc then ;M --- 52,75 ---- dimensions ;M + : drawBox ( -- ) + get-dc + addr: dc + SetDC: BitmapBox + DrawNormal: BitmapBox + release-dc ; + + : eraseBox ( -- ) \ really same as drawbox + drawBox ; + + : ShowBox ( -- ) + erasebox + mousex mousey 2dup BitmapDimensions: DesignToolbar d+ SetRect: BitmapBox + drawbox ; + :M On_Paint: ( -- ) BitmapFile c@ 0<> &Bitmap 0<> and if &bitmap SetBitmap: TheBitmap ! \ width height dc.hdc ShowFittedBitmap: TheBitmap ! 0 0 dc.hdc ShowBitmap: TheBitmap else 0 0 width height WHITE FillArea: dc then ;M *************** *** 74,78 **** --- 94,103 ---- Title$ 1+ ;M + : savemouse ( -- ) + mousex to savex + mousey to savey ; + : showposition ( -- ) + ShowBox title$ count pad place s" (" pad +place *************** *** 86,91 **** On_Init: super ['] showposition settrackfunc: self ! ['] showposition setclickfunc: self ;M ! :M SetPos: ( x y -- ) 2to xypos ;M --- 111,124 ---- On_Init: super ['] showposition settrackfunc: self ! ['] showposition setclickfunc: self ! ['] savemouse setunclickfunc: self ! ;M ! /* ! :M WM_MOUSEMOVE ( h m w l -- ) ! \ over MK_LBUTTON and to mousedown \ mouse left button pressed? ! WM_MOUSEMOVE WM: Super ! showposition ! ;M ! */ :M SetPos: ( x y -- ) 2to xypos ;M *************** *** 205,208 **** --- 238,248 ---- ; + :M BitmapDimensions: ( -- w h ) + GetValue: updnBitmapWidth + GetValue: updnBitmapHeight 2dup or 0= \ if zero set default + if 2drop 16 15 + then ;M + + : GetBitmap ( -- ) hwnd Start: GetBitmapDlg dup c@ *************** *** 226,230 **** err 0= if ButtonTextList ButtonTextLength Write: TDFFile to err then Close: TDFFile \ close ! err 0= s" Success!" ?MessageBox else drop then ; --- 266,270 ---- err 0= if ButtonTextList ButtonTextLength Write: TDFFile to err then Close: TDFFile \ close ! err s" Save error!" ?MessageBox else drop then ; *************** *** 255,258 **** --- 295,300 ---- On_Init: Super + self to DesignToolBar + self Start: updn#Bitmaps GetHandle: txt#Bitmaps SetBuddy: updn#Bitmaps *************** *** 424,430 **** begin dup while readline-memory 2>r ! 2dup s" separator" caps-compare 0= if 2drop s" SeparatorButton," append&crlf ! else 2dup s" extra" caps-compare 0= if 2drop s" ToolBarTableExtraButtons:" append&crlf else write-tableline --- 466,472 ---- begin dup while readline-memory 2>r ! 2dup s" separator" istr= if 2drop s" SeparatorButton," append&crlf ! else 2dup s" extra" istr= if 2drop s" ToolBarTableExtraButtons:" append&crlf else write-tableline Index: Forms.frm =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/Forms.frm,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Forms.frm 25 Sep 2005 20:00:35 -0000 1.3 --- Forms.frm 1 Nov 2005 23:14:04 -0000 1.4 *************** *** 5,24 **** :Object frmPropertiesWindow <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form TabControl TabProperties \ Coordinates and dimensions for btnApply ! 22 value btnApplyX ! 287 value btnApplyY ! 108 value btnApplyW ! 40 value btnApplyH \ Coordinates and dimensions for btnClose ! 132 value btnCloseX ! 287 value btnCloseY ! 108 value btnCloseW ! 40 value btnCloseH :M ClassInit: ( -- ) --- 5,24 ---- :Object frmPropertiesWindow <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form TabControl TabProperties \ Coordinates and dimensions for btnApply ! 22 value btnApplyX ! 287 value btnApplyY ! 108 value btnApplyW ! 40 value btnApplyH \ Coordinates and dimensions for btnClose ! 132 value btnCloseX ! 287 value btnCloseY ! 108 value btnCloseW ! 40 value btnCloseH :M ClassInit: ( -- ) *************** *** 45,49 **** :M StartSize: ( -- width height ) ! 261 333 ;M --- 45,49 ---- :M StartSize: ( -- width height ) ! 261 333 ;M *************** *** 126,130 **** :Object frmEditProperties <Super Child-Window ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color --- 126,130 ---- :Object frmEditProperties <Super Child-Window ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color *************** *** 143,147 **** ClassInit: super +dialoglist \ allow handling of dialog messages ! 392 to id \ set child id, changeable \ Insert your code here ;M --- 143,147 ---- ClassInit: super +dialoglist \ allow handling of dialog messages ! 400 to id \ set child id, changeable \ Insert your code here ;M *************** *** 167,171 **** :M StartSize: ( -- width height ) ! 248 287 ;M --- 167,171 ---- :M StartSize: ( -- width height ) ! 248 287 ;M *************** *** 185,189 **** self Start: grpControls ! 8 192 141 43 Move: grpControls Handle: Winfont SetFont: grpControls BS_CENTER +Style: grpControls --- 185,189 ---- self Start: grpControls ! 8 198 141 43 Move: grpControls Handle: Winfont SetFont: grpControls BS_CENTER +Style: grpControls *************** *** 191,195 **** self Start: grpOrientation ! 8 130 141 60 Move: grpOrientation Handle: Winfont SetFont: grpOrientation BS_CENTER +Style: grpOrientation --- 191,195 ---- self Start: grpOrientation ! 8 136 141 60 Move: grpOrientation Handle: Winfont SetFont: grpOrientation BS_CENTER +Style: grpOrientation *************** *** 209,213 **** self Start: lblXpos ! 1 36 39 14 Move: lblXpos Handle: Winfont SetFont: lblXpos SS_RIGHT +Style: lblXpos --- 209,213 ---- self Start: lblXpos ! 1 41 39 14 Move: lblXpos Handle: Winfont SetFont: lblXpos SS_RIGHT +Style: lblXpos *************** *** 215,219 **** self Start: lblYPos ! 81 36 37 14 Move: lblYPos Handle: Winfont SetFont: lblYPos SS_RIGHT +Style: lblYPos --- 215,219 ---- self Start: lblYPos ! 81 42 37 14 Move: lblYPos Handle: Winfont SetFont: lblYPos SS_RIGHT +Style: lblYPos *************** *** 221,225 **** self Start: lblWidth ! 2 51 39 14 Move: lblWidth Handle: Winfont SetFont: lblWidth SS_RIGHT +Style: lblWidth --- 221,225 ---- self Start: lblWidth ! 2 57 39 14 Move: lblWidth Handle: Winfont SetFont: lblWidth SS_RIGHT +Style: lblWidth *************** *** 227,231 **** self Start: lblHeight ! 83 52 36 14 Move: lblHeight Handle: Winfont SetFont: lblHeight SS_RIGHT +Style: lblHeight --- 227,231 ---- self Start: lblHeight ! 83 58 36 14 Move: lblHeight Handle: Winfont SetFont: lblHeight SS_RIGHT +Style: lblHeight *************** *** 233,237 **** self Start: lblTooltip ! 1 70 39 14 Move: lblTooltip Handle: Winfont SetFont: lblTooltip SS_RIGHT +Style: lblTooltip --- 233,237 ---- self Start: lblTooltip ! 1 76 39 14 Move: lblTooltip Handle: Winfont SetFont: lblTooltip SS_RIGHT +Style: lblTooltip *************** *** 239,243 **** self Start: lblBitmap ! 1 87 39 14 Move: lblBitmap Handle: Winfont SetFont: lblBitmap SS_RIGHT +Style: lblBitmap --- 239,243 ---- self Start: lblBitmap ! 1 92 39 14 Move: lblBitmap Handle: Winfont SetFont: lblBitmap SS_RIGHT +Style: lblBitmap *************** *** 245,296 **** self Start: txtName ! 44 3 175 15 Move: txtName Handle: Winfont SetFont: txtName self Start: txtCaption ! 44 20 175 14 Move: txtCaption Handle: Winfont SetFont: txtCaption self Start: txtXPos ! 44 36 34 14 Move: txtXPos Handle: Winfont SetFont: txtXPos self Start: txtYPos ! 120 36 34 14 Move: txtYPos Handle: Winfont SetFont: txtYPos self Start: txtWidth ! 44 52 34 14 Move: txtWidth Handle: Winfont SetFont: txtWidth self Start: txtHeight ! 120 53 34 14 Move: txtHeight Handle: Winfont SetFont: txtHeight self Start: txtToolTip ! 44 70 175 15 Move: txtToolTip Handle: Winfont SetFont: txtToolTip self Start: txtBitmap ! 44 86 175 15 Move: txtBitmap Handle: Winfont SetFont: txtBitmap self Start: btnBrowse ! 223 87 18 14 Move: btnBrowse Handle: Winfont SetFont: btnBrowse s" ..." SetText: btnBrowse self Start: chkGroup ! 1 109 62 17 Move: chkGroup Handle: Winfont SetFont: chkGroup s" Group" SetText: chkGroup self Start: chkGlobal ! 70 108 62 17 Move: chkGlobal Handle: Winfont SetFont: chkGlobal s" Global" SetText: chkGlobal self Start: radLeft ! 12 144 50 17 Move: radLeft WS_GROUP +Style: radLeft Handle: Winfont SetFont: radLeft --- 245,296 ---- self Start: txtName ! 44 3 175 17 Move: txtName Handle: Winfont SetFont: txtName self Start: txtCaption ! 44 21 175 17 Move: txtCaption Handle: Winfont SetFont: txtCaption self Start: txtXPos ! 44 42 34 14 Move: txtXPos Handle: Winfont SetFont: txtXPos self Start: txtYPos ! 120 42 34 14 Move: txtYPos Handle: Winfont SetFont: txtYPos self Start: txtWidth ! 44 58 34 14 Move: txtWidth Handle: Winfont SetFont: txtWidth self Start: txtHeight ! 120 59 34 14 Move: txtHeight Handle: Winfont SetFont: txtHeight self Start: txtToolTip ! 44 76 175 15 Move: txtToolTip Handle: Winfont SetFont: txtToolTip self Start: txtBitmap ! 44 92 175 15 Move: txtBitmap Handle: Winfont SetFont: txtBitmap self Start: btnBrowse ! 223 92 18 14 Move: btnBrowse Handle: Winfont SetFont: btnBrowse s" ..." SetText: btnBrowse self Start: chkGroup ! 2 114 62 17 Move: chkGroup Handle: Winfont SetFont: chkGroup s" Group" SetText: chkGroup self Start: chkGlobal ! 70 114 62 17 Move: chkGlobal Handle: Winfont SetFont: chkGlobal s" Global" SetText: chkGlobal self Start: radLeft ! 12 150 50 17 Move: radLeft WS_GROUP +Style: radLeft Handle: Winfont SetFont: radLeft *************** *** 298,317 **** self Start: radCenter ! 83 144 50 16 Move: radCenter Handle: Winfont SetFont: radCenter s" Center" SetText: radCenter self Start: radRight ! 12 163 46 16 Move: radRight Handle: Winfont SetFont: radRight s" Right" SetText: radRight self Start: radLefttext ! 83 163 57 16 Move: radLefttext Handle: Winfont SetFont: radLefttext s" Lefttext" SetText: radLefttext self Start: btnPrevious ! 17 208 49 20 Move: btnPrevious WS_GROUP +Style: btnPrevious Handle: Winfont SetFont: btnPrevious --- 298,317 ---- self Start: radCenter ! 83 150 50 16 Move: radCenter Handle: Winfont SetFont: radCenter s" Center" SetText: radCenter self Start: radRight ! 12 169 46 16 Move: radRight Handle: Winfont SetFont: radRight s" Right" SetText: radRight self Start: radLefttext ! 83 169 57 16 Move: radLefttext Handle: Winfont SetFont: radLefttext s" Lefttext" SetText: radLefttext self Start: btnPrevious ! 17 214 49 20 Move: btnPrevious WS_GROUP +Style: btnPrevious Handle: Winfont SetFont: btnPrevious *************** *** 319,323 **** self Start: btnNext ! 90 208 49 20 Move: btnNext Handle: Winfont SetFont: btnNext s" &Next" SetText: btnNext --- 319,323 ---- self Start: btnNext ! 90 214 49 20 Move: btnNext Handle: Winfont SetFont: btnNext s" &Next" SetText: btnNext *************** *** 355,362 **** :Object frmDefineMenu <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 270 170 2value XYPos \ save screen location of form GroupBox grpFunction --- 355,362 ---- :Object frmDefineMenu <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 270 170 2value XYPos \ save screen location of form GroupBox grpFunction *************** *** 364,371 **** Label lblMenu \ Coordinates and dimensions for tvMenuTree ! 8 value tvMenuTreeX ! 28 value tvMenuTreeY ! 373 value tvMenuTreeW ! 115 value tvMenuTreeH Label lblMenuText TextBox txtMenutext --- 364,371 ---- Label lblMenu \ Coordinates and dimensions for tvMenuTree ! 8 value tvMenuTreeX ! 28 value tvMenuTreeY ! 373 value tvMenuTreeW ! 115 value tvMenuTreeH Label lblMenuText TextBox txtMenutext *************** *** 410,414 **** :M StartSize: ( -- width height ) ! 389 289 ;M --- 410,414 ---- :M StartSize: ( -- width height ) ! 389 289 ;M *************** *** 561,564 **** --- 561,727 ---- + \ CREATEPROPERTYFORM.FRM + \- textbox needs excontrols.f + + + :Object frmPropertyForm <Super DialogWindow + + Font WinFont \ default font + ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND + ColorObject FrmColor \ the background color + 350 285 2value XYPos \ save screen location of form + + GroupBox grpOptions + Label lblName + Label lblCaption + TextBox txtName + TextBox txtCaption + CheckBox chkDefault + CheckBox chkMultiLine + CheckBox chkButtonTabs + CheckBox chkComPile + PushButton btnTest + PushButton btnEdit + PushButton btnClipBoard + PushButton btnClose + + :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 ) + parent + ;M + + :M SetParent: ( hwndparent -- ) \ set owner window + to parent + ;M + + :M WindowTitle: ( -- ztitle ) + z" Compile Property Form" + ;M + + :M StartSize: ( -- width height ) + 359 187 + ;M + + :M StartPos: ( -- x y ) + XYPos + ;M + + :M Close: ( -- ) + \ 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: grpOptions + 63 61 158 115 Move: grpOptions + Handle: Winfont SetFont: grpOptions + s" Options" SetText: grpOptions + + self Start: lblName + 16 18 52 18 Move: lblName + Handle: Winfont SetFont: lblName + SS_RIGHT +Style: lblName + s" Name:" SetText: lblName + + self Start: lblCaption + 16 38 52 18 Move: lblCaption + Handle: Winfont SetFont: lblCaption + SS_RIGHT +Style: lblCaption + s" Caption:" SetText: lblCaption + + self Start: txtName + 72 16 150 18 Move: txtName + Handle: Winfont SetFont: txtName + + self Start: txtCaption + 72 36 150 18 Move: txtCaption + Handle: Winfont SetFont: txtCaption + + self Start: chkDefault + 72 75 139 22 Move: chkDefault + WS_GROUP +Style: chkDefault + Handle: Winfont SetFont: chkDefault + s" Add Default Buttons" SetText: chkDefault + + self Start: chkMultiLine + 72 99 139 22 Move: chkMultiLine + Handle: Winfont SetFont: chkMultiLine + s" Multi-Line Tabs" SetText: chkMultiLine + + self Start: chkButtonTabs + 72 123 139 22 Move: chkButtonTabs + Handle: Winfont SetFont: chkButtonTabs + s" Button Tabs" SetText: chkButtonTabs + + self Start: chkComPile + 72 147 139 22 Move: chkComPile + Handle: Winfont SetFont: chkComPile + s" Compile Forms to Disk" SetText: chkComPile + + self Start: btnTest + 244 15 97 23 Move: btnTest + WS_GROUP +Style: btnTest + Handle: Winfont SetFont: btnTest + s" &Test" SetText: btnTest + + self Start: btnEdit + 244 40 97 23 Move: btnEdit + Handle: Winfont SetFont: btnEdit + s" &Edit" SetText: btnEdit + + self Start: btnClipBoard + 244 65 97 23 Move: btnClipBoard + Handle: Winfont SetFont: btnClipBoard + s" Clip&Board" SetText: btnClipBoard + + self Start: btnClose + 244 90 97 23 Move: btnClose + Handle: Winfont SetFont: btnClose + s" &Close" SetText: btnClose + + ;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_Done: ( -- ) + Delete: WinFont + originx originy 2to XYPos + \ Insert your code here + On_Done: super + ;M + + ;Object + + \ CREATETOOLBARFORM.FRM \- textbox needs excontrols.f *************** *** 567,574 **** :Object frmDefineToolbar <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 210 225 2value XYPos \ save screen location of form GroupBox grpStyles --- 730,737 ---- :Object frmDefineToolbar <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 210 225 2value XYPos \ save screen location of form GroupBox grpStyles *************** *** 638,642 **** :M StartSize: ( -- width height ) ! 522 364 ;M --- 801,805 ---- :M StartSize: ( -- width height ) ! 522 364 ;M *************** *** 904,917 **** :Object frmFormPad <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form \ Coordinates and dimensions for scnEditor ! 3 value scnEditorX ! 10 value scnEditorY ! 484 value scnEditorW ! 305 value scnEditorH PushButton btnSaveToDisk PushButton btnCompile --- 1067,1080 ---- :Object frmFormPad <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form \ Coordinates and dimensions for scnEditor ! 3 value scnEditorX ! 10 value scnEditorY ! 484 value scnEditorW ! 305 value scnEditorH PushButton btnSaveToDisk PushButton btnCompile *************** *** 941,945 **** :M StartSize: ( -- width height ) ! 620 320 ;M --- 1104,1108 ---- :M StartSize: ( -- width height ) ! 620 320 ;M *************** *** 1017,1021 **** :Object frmEditFormProperties <Super Child-Window ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color --- 1180,1184 ---- :Object frmEditFormProperties <Super Child-Window ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color *************** *** 1046,1050 **** ClassInit: super +dialoglist \ allow handling of dialog messages ! 393 to id \ set child id, changeable \ Insert your code here ;M --- 1209,1213 ---- ClassInit: super +dialoglist \ allow handling of dialog messages ! 401 to id \ set child id, changeable \ Insert your code here ;M *************** *** 1070,1074 **** :M StartSize: ( -- width height ) ! 237 268 ;M --- 1233,1237 ---- :M StartSize: ( -- width height ) ! 237 268 ;M *************** *** 1225,1229 **** :Object frmGroupAction <Super Child-Window ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color --- 1388,1392 ---- :Object frmGroupAction <Super Child-Window ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color *************** *** 1249,1276 **** RadioButton radWidth \ Coordinates and dimensions for imgbtnUp ! 56 value imgbtnUpX ! 141 value imgbtnUpY ! 32 value imgbtnUpW ! 32 value imgbtnUpH \ Coordinates and dimensions for imgbtnRight ! 96 value imgbtnRightX ! 172 value imgbtnRightY ! 32 value imgbtnRightW ! 32 value imgbtnRightH \ Coordinates and dimensions for imgbtnDown ! 56 value imgbtnDownX ! 200 value imgbtnDownY ! 32 value imgbtnDownW ! 32 value imgbtnDownH \ Coordinates and dimensions for imgbtnLeft ! 16 value imgbtnLeftX ! 172 value imgbtnLeftY ! 32 value imgbtnLeftW ! 32 value imgbtnLeftH :M ClassInit: ( -- ) ClassInit: super +dialoglist \ allow handling of dialog messages ! 394 to id \ set child id, changeable \ Insert your code here ;M --- 1412,1439 ---- RadioButton radWidth \ Coordinates and dimensions for imgbtnUp ! 56 value imgbtnUpX ! 141 value imgbtnUpY ! 32 value imgbtnUpW ! 32 value imgbtnUpH \ Coordinates and dimensions for imgbtnRight ! 96 value imgbtnRightX ! 172 value imgbtnRightY ! 32 value imgbtnRightW ! 32 value imgbtnRightH \ Coordinates and dimensions for imgbtnDown ! 56 value imgbtnDownX ! 200 value imgbtnDownY ! 32 value imgbtnDownW ! 32 value imgbtnDownH \ Coordinates and dimensions for imgbtnLeft ! 16 value imgbtnLeftX ! 172 value imgbtnLeftY ! 32 value imgbtnLeftW ! 32 value imgbtnLeftH :M ClassInit: ( -- ) ClassInit: super +dialoglist \ allow handling of dialog messages ! 402 to id \ set child id, changeable \ Insert your code here ;M *************** *** 1296,1300 **** :M StartSize: ( -- width height ) ! 210 253 ;M --- 1459,1463 ---- :M StartSize: ( -- width height ) ! 210 253 ;M *************** *** 1445,1452 **** :Object frmPreferences <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form GroupBox grpOther --- 1608,1615 ---- :Object frmPreferences <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form GroupBox grpOther *************** *** 1476,1480 **** :M StartSize: ( -- width height ) ! 158 173 ;M --- 1639,1643 ---- :M StartSize: ( -- width height ) ! 158 173 ;M *************** *** 1500,1504 **** 11 81 139 50 Move: grpOther Handle: Winfont SetFont: grpOther ! s" Miscellaneous" SetText: grpOther self Start: grpToolBar --- 1663,1667 ---- 11 81 139 50 Move: grpOther Handle: Winfont SetFont: grpOther ! s" Options" SetText: grpOther self Start: grpToolBar *************** *** 1518,1522 **** self Start: chkShowMonitor ! 18 93 89 18 Move: chkShowMonitor Handle: Winfont SetFont: chkShowMonitor s" Show Monitor" SetText: chkShowMonitor --- 1681,1685 ---- self Start: chkShowMonitor ! 18 101 89 18 Move: chkShowMonitor Handle: Winfont SetFont: chkShowMonitor s" Show Monitor" SetText: chkShowMonitor *************** *** 1572,1611 **** :Object frmSplitterWindow <Super DialogWindow ! Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form GroupBox grpOptions \ Coordinates and dimensions for imgType1 ! 11 value imgType1X ! 17 value imgType1Y ! 90 value imgType1W ! 72 value imgType1H \ Coordinates and dimensions for imgType2 ! 104 value imgType2X ! 17 value imgType2Y ! 90 value imgType2W ! 72 value imgType2H \ Coordinates and dimensions for imgType3 ! 11 value imgType3X ! 92 value imgType3Y ! 90 value imgType3W ! 72 value imgType3H \ Coordinates and dimensions for imgType4 ! 104 value imgType4X ! 90 value imgType4Y ! 90 value imgType4W ! 71 value imgType4H \ Coordinates and dimensions for imgType5 ! 11 value imgType5X ! 165 value imgType5Y ! 90 value imgType5W ! 72 value imgType5H \ Coordinates and dimensions for imgType6 ! 104 value imgType6X ! 166 value imgType6Y ! 90 value imgType6W ! 72 value imgType6H RadioButton radTest RadioButton radEdit --- 1735,1774 ---- :Object frmSplitterWindow <Super DialogWindow ! Font WinFont \ default font ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color ! 150 175 2value XYPos \ save screen location of form GroupBox grpOptions \ Coordinates and dimensions for imgType1 ! 11 value imgType1X ! 17 value imgType1Y ! 90 value imgType1W ! 72 value imgType1H \ Coordinates and dimensions for imgType2 ! 104 value imgType2X ! 17 value imgType2Y ! 90 value imgType2W ! 72 value imgType2H \ Coordinates and dimensions for imgType3 ! 11 value imgType3X ! 92 value imgType3Y ! 90 value imgType3W ! 72 value imgType3H \ Coordinates and dimensions for imgType4 ! 104 value imgType4X ! 90 value imgType4Y ! 90 value imgType4W ! 71 value imgType4H \ Coordinates and dimensions for imgType5 ! 11 value imgType5X ! 165 value imgType5Y ! 90 value imgType5W ! 72 value imgType5H \ Coordinates and dimensions for imgType6 ! 104 value imgType6X ! 166 value imgType6Y ! 90 value imgType6W ! 72 value imgType6H RadioButton radTest RadioButton radEdit *************** *** 1637,1641 **** :M StartSize: ( -- width height ) ! 339 247 ;M --- 1800,1804 ---- :M StartSize: ( -- width height ) ! 339 247 ;M --- NEW FILE: CreatePropertyForm.ff --- (This appears to be a binary file; contents omitted.) Index: FormHelp.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FormHelp.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** FormHelp.f 21 Aug 2005 06:22:00 -0000 1.1 --- FormHelp.f 1 Nov 2005 23:14:04 -0000 1.2 *************** *** 1,4 **** \ FormHelp.f ! :Object FFHelpWindow <Super HtmlDisplayWindow --- 1,4 ---- \ FormHelp.f ! /* :Object FFHelpWindow <Super HtmlDisplayWindow *************** *** 25,27 **** --- 25,53 ---- then ; ' FormHelp is doFormHelp + */ + HtmlDisplayControl FFHelpWindow + 2005 SetID: FFHelpWindow + + : SizeHelpWindow ( -- ) + GetHandle: FFHelpWindow + if Canvas: TheMainWindow Move: FFHelpWindow + then ; + + : CloseHelpWindow ( -- ) + Close: FFHelpWindow + \+ withbgnd SW_SHOWNORMAL Show: BkGndImageWindow + UpdateSystem \ update toolbar help button + ; + + : FormHelp ( -- ) \ prepare dinner :-) + GetHandle: FFHelpwindow ?exit + s" doc\forthform\ForthForm.htm" "path-file 0= \ if help file found + if TheMainWindow Start: FFHelpWindow + asciiz SetUrl: FFHelpWindow \ show it + SizeHelpWindow + \+ withbgnd SW_HIDE Show: BkGndImageWindow + else 2drop true s" ForthForm.htm not found in path!" ?MessageBox \ sorry! + then UpdateSystem \ update toolbar help button + ; ' FormHelp is doFormHelp + \s Index: FORTHFORM.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORTHFORM.F,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** FORTHFORM.F 15 Sep 2005 16:36:08 -0000 1.8 --- FORTHFORM.F 1 Nov 2005 23:14:04 -0000 1.9 *************** *** 8,12 **** : sysgen ; ! \ add the ForthForm folder's to our path list \ September 20th, 2003 - 9:57 dbu --- 8,12 ---- : sysgen ; ! \ : withbgnd ; \ add the ForthForm folder's to our path list \ September 20th, 2003 - 9:57 dbu *************** *** 17,40 **** vocabulary forthform ! vocabulary testvocab forthform also definitions ! needs excontrols.f \ extended controls for Win32Forth needs ExUtils.f \ general utilities ! needs linklist.f \ very useful utility ! needs bitmap.f \ bitmap loading routines ! needs point.f \ simple point class ! needs rect.f \ class for drawing boxes ! needs fcases.f \ case extensions ! 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 ! needs multiopen.f \ open multiple forms needs rebarcontrol.f \ allow enhanced toolbar ! needs HtmlDisplayWindow.f \ for viewing the help file ! needs ScintillaControl.f ! needs FileLister.f \ directory viewer needs Win32Help.f needs Resources.f --- 17,41 ---- vocabulary forthform ! vocabulary testvocab \ for testing forms to avoid conflicts forthform also definitions ! needs excontrols.f \ extended controls for Win32Forth needs ExUtils.f \ general utilities ! needs linklist.f \ very useful utility ! needs bitmap.f \ bitmap loading routines ! needs point.f \ simple point class ! needs rect.f \ class for drawing boxes ! needs fcases.f \ case extensions ! 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 ! needs multiopen.f \ open multiple forms needs rebarcontrol.f \ allow enhanced toolbar ! needs HtmlDisplayControl.f \ for viewing the help file ! needs ScintillaControl.f \ editor for FormPad ! needs FileLister.f \ directory viewer ! needs exfont.f \ enhanced font class to allow runtime font selection needs Win32Help.f needs Resources.f *************** *** 66,74 **** 0 value TheMainWindow \ allow forward referencing 0 value FormList \ pointer to list of open forms 0 value ButtonID \ button to be unchecked 0 value TheControlToolBar 0 value NextControlType \ next control to be created GRAY value BackGroundColor \ default ! 0 value newcontrol? 0 value statuswindow \ pointer to status window object 0 value inconsole --- 67,76 ---- 0 value TheMainWindow \ allow forward referencing 0 value FormList \ pointer to list of open forms + 0 value formcount \ running total of created forms 0 value ButtonID \ button to be unchecked 0 value TheControlToolBar 0 value NextControlType \ next control to be created GRAY value BackGroundColor \ default ! false value newcontrol? 0 value statuswindow \ pointer to status window object 0 value inconsole *************** *** 76,98 **** 0 value staticbmp \ registry values ! 100 value WindowTop \ main window y position ! 100 value WindowLeft \ main window x position ! 600 value WindowWidth \ main window width ! 400 value WindowHeight \ main window height ! 536 value MonitorLeft \ monitor window x position ! 375 value MonitorTop \ default is same y position ! true value FlatToolBar? \ do we want a flat toolbar ? ! 0 value ButtonText? \ display button text ?, actually disabled ! true value ShowMonitor? ! 0 value session-error? \ did an error occurred while loading a session? ! WM_USER 256 + constant FF_PASTE \ mesage to tell SciEdit to paste source text ColorObject FormColor \ background form color ! Font ControlFont \ font for text to be written in control \+ withbgnd FreeImageWindow BkGndImageWindow \ create instance \ adapted from WinEd ! 20204 constant fform_version# \ 2.02.04 \ Version numbers: v.ww.rr --- 78,104 ---- 0 value staticbmp \ registry values ! 100 value WindowTop \ main window y position ! 100 value WindowLeft \ main window x position ! 600 value WindowWidth \ main window width ! 400 value WindowHeight \ main window height ! 536 value MonitorLeft \ monitor window x position ! 375 value MonitorTop \ default is same y position ! true value FlatToolBar? \ do we want a flat toolbar ? ! false value ButtonText? \ display button text ?, actually disabled ! true value ShowMonitor? \ display the window positioning monitor ! false value session-error? \ did an error occurred while loading a session? ! 0 value frmdata-size ! 0 value ctrldata-size ! WM_USER 256 + constant FF_PASTE \ message to tell SciEdit to paste source text ColorObject FormColor \ background form color ! Font ControlFont \ default font for text to be written in control \+ withbgnd FreeImageWindow BkGndImageWindow \ create instance + File MergeFile + File TheFile \ adapted from WinEd ! 20205 constant fform_version# \ 2.02.05 \ Version numbers: v.ww.rr *************** *** 111,114 **** --- 117,122 ---- : ExitOnError ( f -- ) S" A serious error has occurred in ForthForm!" ?TerminateBox ; + + macro ?abort " if abort then" \ define defer functions *************** *** 147,150 **** --- 155,170 ---- defer UpdateSystem defer (OpenForm) + defer doPropertyForm + + : Start-SciEditMdi ( -- ) + editor-present? not + if s" SciEditMdi.exe" PrePend<Home>\ + GetHandle: TheMainWindow ExecuteFile + then ; + + : Start-ProjectManager ( -- ) + ?promgr-started ?exit + s" Project.exe" PrePend<Home>\ + GetHandle: TheMainWindow ExecuteFile ; : set-base-path ( -- ) *************** *** 217,221 **** ArrangeHorizontal: ActiveForm ; ! :NoName ( -- ) ActiveForm 0= ?exit DeleteControl: ActiveForm ; is doDelete --- 237,241 ---- ArrangeHorizontal: ActiveForm ; ! :NoName ( -- ) ActiveForm 0= ?exit DeleteControl: ActiveForm ; is doDelete *************** *** 225,229 **** MoveToBack: ActiveForm ; is doMoveToBack ! :NoName ( -- ) ActiveForm 0= ?exit MoveToFront: ActiveForm ; is doMoveToFront --- 245,249 ---- MoveToBack: ActiveForm ; is doMoveToBack ! :NoName ( -- ) ActiveForm 0= ?exit MoveToFront: ActiveForm ; is doMoveToFront *************** *** 234,247 **** ActiveControl: Activeform 0= ?exit ChangeControl: ActiveForm ; ! ! : ?FormNumber { <object> -- n } \ given object address return position in list ! <object> 0= FormList 0= or ! if false exit ! then Link#: FormList >r >FirstLink: FormList 0 ! begin 1+ Data@: FormList <object> = ! LastLink?: FormList or ! >NextLink: FormList ! until r> >Link#: FormList ; ! : #Forms ( -- n ) \ return number of open forms FormList --- 254,272 ---- ActiveControl: Activeform 0= ?exit ChangeControl: ActiveForm ; ! ! : ChangeControlFont ( -- ) ! ActiveForm 0= ?exit ! ActiveControl: ActiveForm ?dup ! if GetUserFont: [ ] ! IsModified: ActiveForm ! then ; ! ! : ResetControlFont ( -- ) ! ActiveForm 0= ?exit ! ActiveControl: ActiveForm ?dup ! if DefaultFont: [ ] ! IsModified: ActiveForm ! then ; ! : #Forms ( -- n ) \ return number of open forms FormList *************** *** 253,256 **** --- 278,292 ---- then ; + : ?FormNumber { <object> -- n } \ given object address return position in list + <object> 0= FormList 0= or + if false exit + then >FirstLink: FormList + #Forms 1+ 1 + ?do Data@: FormList <object> = + if i unloop + exit + then >NextLink: FormList + loop 0 ; + FileOpenDialog OpenSessionDlg "Load Session File" "Session Files|*.ses|" FileSaveDialog SaveSessionDlg "Save Session File" "Session Files|*.ses|" *************** *** 273,277 **** needs SplitterWindow.f \ this is also an easy guess! needs CreateMenu.f \ now what could this file be for? ! :Object MiniWin <Super child-window --- 309,313 ---- needs SplitterWindow.f \ this is also an easy guess! needs CreateMenu.f \ now what could this file be for? ! needs CreatePropertyForm.f \ generate property sheet like template :Object MiniWin <Super child-window *************** *** 286,290 **** 0 to WasMoved? 0 to wx ! 0 to wy ;M :M WindowStyle: ( -- style ) --- 322,327 ---- 0 to WasMoved? 0 to wx ! 0 to wy ! 1 to ID ;M :M WindowStyle: ( -- style ) *************** *** 368,375 **** ;M - :M On_Init: ( -- ) - 1 SetID: MiniWin - ;M - :M On_Paint: ( -- ) 0 0 GetSize: self CYAN FillArea: dc --- 405,408 ---- *************** *** 430,435 **** Clear: FormPicker #Forms ?dup ! if Link#: FormList >r \ save link ! 1+ 1 ?do i >Link#: FormList Data@: FormList FormName: [ ] --- 463,467 ---- Clear: FormPicker #Forms ?dup ! if 1+ 1 ?do i >Link#: FormList Data@: FormList FormName: [ ] *************** *** 437,441 **** loop ActiveForm ?dup if ?FormNumber 1- 0max SetSelection: FormPicker ! then r> >Link#: FormList then ; --- 469,473 ---- loop ActiveForm ?dup if ?FormNumber 1- 0max SetSelection: FormPicker ! then then ; *************** *** 503,506 **** --- 535,547 ---- ; + : check-file { fname fcnt \ fsize -- f } \ check integrity of file before opening + fname fcnt SetName: TheFile \ + Open: TheFile ?dup ?exit + FileSize: TheFile drop to fsize \ larger than 4 gig .ff file? + Close: TheFile + fsize frmdata-size < ?dup ?exit \ must have at least a form header + fsize frmdata-size - ctrldata-size mod 0<> \ must be evenly divisible + ; + :NoName ( -- ) \ _NewForm AddNewForm *************** *** 509,513 **** new$ >r s" Form" r@ place ! #Forms (.) r@ +place r> count 2dup SetName: ThisForm IsFormTitle: ThisForm --- 550,554 ---- new$ >r s" Form" r@ place ! formcount (.) r@ +place r> count 2dup SetName: ThisForm IsFormTitle: ThisForm *************** *** 516,527 **** doupdate ; is doNew ! :NoName ( fname fcnt -- ) \ open form given its name ! AddNewForm Start: ThisForm ! SetFileName: ThisForm ! Load: ThisForm ! StartSize: ThisForm GetHandle: ThisForm AdjustWindowSize ! FormTitle: ThisForm count Settext: ThisForm ! Refresh: ThisForm Display: ThisForm doupdate ; is (OpenForm) --- 557,570 ---- doupdate ; is doNew ! :NoName { fname fcnt -- } \ open form given its name ! fname fcnt check-file ! if fname fcnt pad place ! s" is an invalid ForthForm file!" pad +place ! true pad count ?MessageBox ! exit ! then AddNewForm Start: ThisForm ! fname fcnt SetFileName: ThisForm ! Load: ThisForm Display: ThisForm doupdate ; is (OpenForm) *************** *** 534,540 **** then ; is doOpen ! :NoName ( -- ) ! ActiveForm 0= ?exit ! GetBuffer: ActiveForm FormName: ActiveForm count ShowSource ; is doEditor : strip-cmdline ( addr cnt -- addr2 cnt2 ) --- 577,583 ---- then ; is doOpen ! :NoName ( -- ) \ view/edit form ! ActiveForm 0= ?exit ! GetBuffer: ActiveForm FormName: ActiveForm count ShowSource ; is doEditor : strip-cmdline ( addr cnt -- addr2 cnt2 ) *************** *** 567,580 **** ActiveForm 0= ?exit s" anew _frm" evaluate GetBuffer: ActiveForm 2drop fload-buffer \ load actual form GetSuperClass: ActiveForm dup CHILD-CLASS = \ compiling as a child window? ! if drop TestChildDialog: ActiveForm fload-buffer else MDIDIALOG-CLASS = \ or as a MDI dialog? ! if TestMDIDialog: ActiveForm fload-buffer else s" Start: " new$ dup>r place FormName: ActiveForm count r@ +place \ no, as a dialog window ! r> count evaluate then ! then ; is doTest :NoName ( -- ) \ clean slate --- 610,625 ---- ActiveForm 0= ?exit s" anew _frm" evaluate + ChildState: ActiveForm >r \ we want to see the form if it is a child, so we + false IsChildState: Activeform \ save the state and change in case it is hidden GetBuffer: ActiveForm 2drop fload-buffer \ load actual form GetSuperClass: ActiveForm dup CHILD-CLASS = \ compiling as a child window? ! if drop TestChildDialog: ActiveForm fload-buffer else MDIDIALOG-CLASS = \ or as a MDI dialog? ! if TestMDIDialog: ActiveForm fload-buffer else s" Start: " new$ dup>r place FormName: ActiveForm count r@ +place \ no, as a dialog window ! r> count evaluate then ! then r> IsChildState: ActiveForm ; is doTest :NoName ( -- ) \ clean slate *************** *** 594,598 **** then ; is doSaveAll - File MergeFile :NoName { \ fname err - } \ compile all open forms to a single file #forms 2 < ?exit \ no use merging 1 form --- 639,642 ---- *************** *** 613,631 **** do Data@: FormList GetBuffer: [ ] 2drop +crlf +crlf \ couple blank lines ! TheBuffer Write: MergeFile dup to err ! ?leave >NextLink: FormList ! loop Close: MergeFile ! err 0= s" Forms successfully merged!" ?MessageBox ; is doMerge ! :NoName ( -- ) ! ActiveForm 0= ?exit ! GetBuffer: ActiveForm copy-clipboard ; is doCopy :Object MainWindow <Super Window MultiStatusbar controlstats \ status window - Rect aBox create bardivisions 136 , 250 , 400 , 460 , -1 , --- 657,672 ---- do Data@: FormList GetBuffer: [ ] 2drop +crlf +crlf \ couple blank lines ! TheBuffer Write: MergeFile ?leave >NextLink: FormList ! loop Close: MergeFile ClearName: MergeFile ; is doMerge ! :NoName ( -- ) \ copy to clipboard ! ActiveForm 0= ?exit ! GetBuffer: ActiveForm copy-clipboard ; is doCopy :Object MainWindow <Super Window MultiStatusbar controlstats \ status window create bardivisions 136 , 250 , 400 , 460 , -1 , *************** *** 662,666 **** 520 50 ;M - :M DefaultIcon: ( -- hIcon ) \ return the default icon handle for window LoadAppIcon ;M --- 703,706 ---- *************** *** 683,686 **** --- 723,727 ---- #IFDEF withbgnd self Start: BkGndImageWindow + \ WS_CLIPSIBLINGS WS_CLIPCHILDREN or +Style: BkGndImageWindow FIT_SIZE SetViewMode: BkGndImageWindow GetBackGroundImage *************** *** 712,721 **** InitScintillaControl \ for the editor ;M #IFDEF withbgnd :M ReDrawImage: ( -- ) ! 0 Height: TheRebar dup>r ( -- x y ) ! Width Height Height: statuswindow - r> - ! Move: BkGndImageWindow ;M #ENDIF --- 753,764 ---- InitScintillaControl \ for the editor ;M + + :M Canvas: ( -- x y w h ) + 0 Height: TheRebar dup>r ( -- x y ) + Width Height Height: statuswindow - r> - ;M #IFDEF withbgnd :M ReDrawImage: ( -- ) ! Canvas: self Move: BkGndImageWindow ;M #ENDIF *************** *** 725,729 **** \+ withbgnd ReDrawImage: self Redraw: statuswindow ! ;M /* ***************** Toolbar handlers *********************** */ --- 768,772 ---- \+ withbgnd ReDrawImage: self Redraw: statuswindow ! SizeHelpWindow ;M /* ***************** Toolbar handlers *********************** */ *************** *** 732,735 **** --- 775,779 ---- if \+ withbgnd RedrawImage: self + SizeHelpWindow then *************** *** 830,839 **** Close: Monitor \+ withbgnd Close: BkGndImageWindow ! Close: frmCreateToolBar Close: frmProperties++ ! Close: FFHelpWindow ! Close: frmCreateSplitterWindow ! Close: frmCreateMenuForm ! \ Close: SCIWIndow Close: super ;M --- 874,884 ---- Close: Monitor \+ withbgnd Close: BkGndImageWindow ! Close: frmCreateToolBar Close: frmProperties++ ! Close: FFHelpWindow ! Close: frmCreateSplitterWindow ! Close: frmCreateMenuForm ! Close: frmFormPad ! Close: frmCreatePropertyForm Close: super ;M *************** *** 856,860 **** ZeroMenu: CurrentMenu then Delete: ControlFont ! picturebmp ?dup if Call DeleteObject drop 0 to picturebmp --- 901,905 ---- ZeroMenu: CurrentMenu then Delete: ControlFont ! picturebmp ?dup if Call DeleteObject drop 0 to picturebmp *************** *** 864,868 **** then ExitScintillaControl \+ sysgen 0 Call PostQuitMessage ! \+ sysgen msg-buffer off \ set as no longer running On_Done: super 0 ;M --- 909,913 ---- then ExitScintillaControl \+ sysgen 0 Call PostQuitMessage ! \+ sysgen false fform-started \ set as no longer running On_Done: super 0 ;M *************** *** 900,904 **** #Forms 0= ?exit 0 to cnt \ reset - Link#: FormList >r param-buffer cell+ to tmp #Forms 1+ 1 --- 945,948 ---- *************** *** 911,915 **** else 2drop then ! loop r> >Link#: FormList ; : send-forms ( -- ) --- 955,959 ---- else 2drop then ! loop ; : send-forms ( -- ) *************** *** 942,948 **** ActiveControl: Activeform if Updat... [truncated message content] |
1040 messages has been excluded from this view by a project administrator.
