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: Jos v.d.V. <jo...@us...> - 2006-06-22 09:04:38
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv28711/src/lib Modified Files: treeview.f Log Message: Jos: Added some commands for joy stick browsing Index: treeview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/treeview.f,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** treeview.f 15 Jun 2006 18:43:54 -0000 1.9 --- treeview.f 22 Jun 2006 09:04:35 -0000 1.10 *************** *** 247,250 **** --- 247,251 ---- \ :M ToggleExpandItem: ( hItem -- ) TVE_TOGGLE Expand: self ;M :M CollapseReset: ( hItem -- ) TVE_COLLAPSERESET TVE_COLLAPSE or Expand: self ;M + :M Collapse: ( hItem -- ) TVE_COLLAPSE TVE_COLLAPSE or Expand: self ;M :M GetItemRect: ( hItem -- f ) ItemRect ! ItemRect true TVM_GETITEMRECT SendMessage:Self ;M :M SelectItem: ( flag hItem -- ) TVM_SELECTITEM SendMessage:SelfDrop ;M |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-22 09:03:37
|
Update of /cvsroot/win32forth/win32forth/apps/Player4 In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv28276/apps/Player4 Modified Files: Mediatree.f PLAYER4.F Log Message: Jos: Now joy stick browsing is possible. More improvements are needed to solve the long list problem. Index: PLAYER4.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v retrieving revision 1.58 retrieving revision 1.59 diff -C2 -d -r1.58 -r1.59 *** PLAYER4.F 10 Jun 2006 18:00:04 -0000 1.58 --- PLAYER4.F 22 Jun 2006 09:03:32 -0000 1.59 *************** *** 43,46 **** --- 43,49 ---- defer HandleJoystick ' noop is HandleJoystick + 0 value JoycenterX + 0 value JoycenterY + needs Pl_Toolset.f needs number.f *************** *** 244,249 **** FindFirstJoyStick dup to IDJoystick MaxJoysticks < ! if 0 200 1 hWnd Call SetTimer drop ! then ;M --- 247,256 ---- FindFirstJoyStick dup to IDJoystick MaxJoysticks < ! if [ *lpjoycapsa joycapsa wYmax ] literal @ ! [ *lpjoycapsa joycapsa wYmin ] literal @ - 2/ to JoycenterY ! [ *lpjoycapsa joycapsa wXmax ] literal @ ! [ *lpjoycapsa joycapsa wXmin ] literal @ - 2/ to JoycenterX ! 0 200 1 hWnd Call SetTimer drop ! then ;M *************** *** 392,412 **** : IncreaseVolume ( - ) ! begin GetVolume/timeOut + SetVolLevel ! ButtonIn? until ; ! :Noname ( - ) ! IDJoystick GetJoystickInfo ! dup JOY_BUTTON1 >= ! if case JOY_BUTTON1 of IDM_NEXT DoCommand endof JOY_BUTTON3 of DecreaseVolume endof JOY_BUTTON4 of IncreaseVolume endof JOY_BUTTON5 of IDM_PAUSE/RESUME DoCommand endof JOY_BUTTON6 of down endof ! endcase ! WaitTillDepressed 3drop ! else 4drop then --- 399,508 ---- : IncreaseVolume ( - ) ! begin GetVolume/timeOut 20 max + SetVolLevel ! ButtonIn? until ; ! : ChangeFont ( Big|small - ) ! to UseBigFont Delete: TreeViewFont SetfontTreeView: Catalog ! SW_SHOWMAXIMIZED Show: MainWindow ! ; ! ! : PlaymodeForJoystick ( button - ) ! case JOY_BUTTON1 of IDM_NEXT DoCommand endof + JOY_BUTTON2 of true ChangeFont endof JOY_BUTTON3 of DecreaseVolume endof JOY_BUTTON4 of IncreaseVolume endof JOY_BUTTON5 of IDM_PAUSE/RESUME DoCommand endof JOY_BUTTON6 of down endof ! endcase ! ; ! ! : PlayFromJoystick ! GetSelectedItem: Catalog ! GetLparm: Catalog dup -1 = ! if drop ! else to last-selected-rec PlaySelectedFromTreeView ! then ! ; ! ! : JoystickBrowser ( button - ) ! case ! JOY_BUTTON1 of PlayFromJoystick endof ! JOY_BUTTON8 of OpenChild: Catalog endof ! JOY_BUTTON7 of CloseChild: Catalog endof ! JOY_BUTTON2 of false ChangeFont endof ! endcase ! ! ; ! : DifToCenter? { pos } ( Joycenter pos - dif ) ! dup 2 / over pos - abs > ! if drop 0 ! else pos - negate ! then ! ; ! ! \ debug DifToCenter? 65000 JoycenterY swap DifToCenter? ! \ debug DifToCenter? 32767 JoycenterY swap DifToCenter? ! ! ! : XYDifCenter ( posx posy - difx dify ) ! JoycenterY swap DifToCenter? >r ! JoycenterX swap DifToCenter? r> ! ; ! ! 0 value incr-fact ! ! : ScrollFlag ( difx dify - f ) ! abs swap abs max dup 0= ! if to incr-fact ! else incr-fact JoycenterY >= ! if drop 0 to incr-fact ! else +to incr-fact ! then ! then ! incr-fact 0= ! ; ! ! : down/up ( Y - ) ! dup 0<> ! if 0> ! if DownInTree: Catalog ! else UpInTree: Catalog ! then ! else drop ! then ! ; ! ! : Left/Right ( X - ) ! dup 0<> ! if 0> ! if OpenChild: Catalog ! else CloseChild: Catalog ! then JoycenterY negate 2* to incr-fact ! else drop ! then ! ; ! ! : HandleMovesJoystickBrowser ( x y z button - ) ! 2drop XYDifCenter 2dup ScrollFlag ! if down/up Left/Right ! else 2drop ! then ! ! ; ! ! :Noname ( - >>> ) ! IDJoystick GetJoystickInfo ! dup JOY_BUTTON1 >= ! if UseBigFont ! if JoystickBrowser WaitTillDepressed 3drop ! else PlaymodeForJoystick WaitTillDepressed 3drop ! then ! else UseBigFont ! if HandleMovesJoystickBrowser ! else 4drop ! then then *************** *** 530,534 **** \ ----------------------------------------------------------------------------- ! : InitPlayer ( -- >>> ) Start: MainWindow Start: ControlCenter --- 626,630 ---- \ ----------------------------------------------------------------------------- ! : InitPlayer ( -- ) Start: MainWindow Start: ControlCenter Index: Mediatree.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v retrieving revision 1.32 retrieving revision 1.33 diff -C2 -d -r1.32 -r1.33 *** Mediatree.f 25 May 2006 15:36:50 -0000 1.32 --- Mediatree.f 22 Jun 2006 09:03:32 -0000 1.33 *************** *** 11,14 **** --- 11,16 ---- 0 value hItem-last-selected defer GetPositionCatalog + Font TreeViewFont + 0 value UseBigFont :Class MediaTree <super TreeViewControl *************** *** 216,230 **** then ; ! ! :M On_SelChanged: ( -- ) TVIF_PARAM TVIF_HANDLE or to mask - hItemNew to hItem 0 to pszText 0 to cchTextMax tvitem 0 TVM_GETITEMA hWnd Call SendMessage drop ! hItem to hItem-last-selected ! lParam dup to last-selected-rec -1 <> ! if StartPopupWindow then ;M --- 218,239 ---- then ; ! ! :M GetLparm: ( hItem - lParm ) ! to hItem TVIF_PARAM TVIF_HANDLE or to mask 0 to pszText 0 to cchTextMax tvitem 0 TVM_GETITEMA hWnd Call SendMessage drop ! hItem to hItem-last-selected ! lParam \ cr .s ! ;M ! ! :M On_SelChanged: ( -- ) ! hItemNew GetLparm: Self ! dup to last-selected-rec -1 <> ! if UseBigFont not ! if StartPopupWindow ! then then ;M *************** *** 248,251 **** --- 257,278 ---- int EnableNotify? + :M SetfontTreeView: ( - ) + UseBigFont + if 24 32 + else 8 16 + then + Height: TreeViewFont + Width: TreeViewFont + s" Times New Roman (TrueType)" SetFaceName: TreeViewFont + Create: TreeViewFont + true Handle: TreeViewFont WM_SETFONT + GetHandle: TreeView CALL SendMessage drop + ;M + + :M Start: ( Parent -- ) + Start: super + false to UseBigFont SetfontTreeView: Self + ;M + :M ExWindowStyle: ( -- style ) ExWindowStyle: Super *************** *** 277,280 **** --- 304,339 ---- drop AddDropFiles ;M + + \ GetNextItem: bij 0 terug dicht en next parent + : SelectTreeViewItem ( hitem - ) + dup 0<> + if TVGN_CARET SelectItem: TreeView + else drop + then + ; + + :M GetLparm: ( - hItem ) GetLparm: TreeView ;M + :M GetSelectedItem: ( - hItem ) 0 TVGN_CARET GetNextItem: TreeView ;M + + :M DownInTree: ( - ) + GetSelectedItem: Self TVGN_NEXT GetNextItem: TreeView + SelectTreeViewItem + ;M + + :M UpInTree: ( - ) + GetSelectedItem: Self GetPrevious: TreeView + SelectTreeViewItem + ;M + + :M OpenChild: ( - ) + GetSelectedItem: Self GetChild: TreeView + SelectTreeViewItem + ;M + + :M CloseChild: ( - ) + GetSelectedItem: Self GetParentItem: TreeView + Collapse: TreeView + ;M + :M On_Init: ( -- ) On_Init: super |
|
From: Rod O. <rod...@us...> - 2006-06-15 20:59:39
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24746/apps/Win32ForthIDE Modified Files: EdFilePane.f FileWindow.frm Log Message: Rod: Eliminated the flicker in the Directory Tab when resizing. Index: EdFilePane.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdFilePane.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** EdFilePane.f 14 Jun 2006 06:02:56 -0000 1.1 --- EdFilePane.f 15 Jun 2006 20:59:36 -0000 1.2 *************** *** 175,178 **** --- 175,179 ---- drvbitmap SetImage: imgDrvButton s" Change drive/folder" BInfo: imgDrvButton place \ tooltip + WS_CLIPSIBLINGS +Style: imgDrvButton \ allow user specified filespecs, N.B. changes lost when program exited *************** *** 182,185 **** --- 183,187 ---- specsbmp SetImage: imgSpecsButton s" Add file specification string e.g (*.f;*.4th)" Binfo: imgSpecsButton place + WS_CLIPSIBLINGS +Style: imgSpecsButton copybmp usebitmap map-3dcolors *************** *** 188,191 **** --- 190,194 ---- copybmp SetImage: imgCopyButton s" Copy selected file" Binfo: imgCopyButton place + WS_CLIPSIBLINGS +Style: imgCopyButton deletebmp usebitmap map-3dcolors *************** *** 194,197 **** --- 197,201 ---- deletebmp SetImage: imgDeleteButton s" Delete selected file" Binfo: imgDeleteButton place + WS_CLIPSIBLINGS +Style: imgDeleteButton dupebmp usebitmap map-3dcolors *************** *** 200,203 **** --- 204,208 ---- dupebmp SetImage: imgDupeButton s" Duplicate selected file" Binfo: imgDupeButton place + WS_CLIPSIBLINGS +Style: imgDupeButton \ true ReadOnly: cmblstPathPicker *************** *** 254,258 **** :M ExWindowStyle: ( -- ) WS_EX_CLIENTEDGE ;M ! :m classinit: classinit: super 1290 to id ;m --- 259,267 ---- :M ExWindowStyle: ( -- ) WS_EX_CLIENTEDGE ;M ! ! :M WndClassStyle: ( -- style ) ! \ CS_DBLCLKS only to prevent flicker in window on sizing. ! CS_DBLCLKS ;M ! :m classinit: classinit: super 1290 to id ;m Index: FileWindow.frm =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/FileWindow.frm,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** FileWindow.frm 14 Jun 2006 06:02:56 -0000 1.1 --- FileWindow.frm 15 Jun 2006 20:59:36 -0000 1.2 *************** *** 73,87 **** COLOR_BTNFACE Call GetSysColor NewColor: FrmColor - - self Start: cmblstPathPicker - 2 30 180 17 Move: cmblstPathPicker - Handle: Winfont SetFont: cmblstPathPicker - self Start: TheDirectory 2 50 180 371 Move: TheDirectory self Start: CmbLstFilters 2 423 180 23 Move: CmbLstFilters Handle: Winfont SetFont: CmbLstFilters ;M --- 73,90 ---- COLOR_BTNFACE Call GetSysColor NewColor: FrmColor self Start: TheDirectory 2 50 180 371 Move: TheDirectory + CS_DBLCLKS GCL_STYLE GetHandle: TheDirectory Call SetClassLong drop + WS_CLIPSIBLINGS +Style: TheDirectory self Start: CmbLstFilters 2 423 180 23 Move: CmbLstFilters Handle: Winfont SetFont: CmbLstFilters + WS_CLIPSIBLINGS +Style: CmbLstFilters + + self Start: cmblstPathPicker + 2 30 180 17 Move: cmblstPathPicker + Handle: Winfont SetFont: cmblstPathPicker + WS_CLIPSIBLINGS +Style: cmblstPathPicker ;M *************** *** 108,110 **** --- 111,117 ---- ;M + :M WndClassStyle: ( -- style ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS ;M + ;Object |
|
From: Rod O. <rod...@us...> - 2006-06-15 20:57:13
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23571/apps/Win32ForthIDE Modified Files: Main.f Log Message: Rod: Tidied up the sizing of the rebar. Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** Main.f 14 Jun 2006 11:15:52 -0000 1.14 --- Main.f 15 Jun 2006 20:57:10 -0000 1.15 *************** *** 19,23 **** only forth also editor definitions \ put all words into the EDITOR vocabulary ! true value sysgen s" apps\Win32ForthIDE" "fpath+ --- 19,23 ---- only forth also editor definitions \ put all words into the EDITOR vocabulary ! true value sysgen s" apps\Win32ForthIDE" "fpath+ *************** *** 169,173 **** : ClientHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - ; ! : AdjustWindowSize { width height win -- } [ SWP_SHOWWINDOW SWP_NOZORDER or SWP_NOMOVE or ] literal --- 169,173 ---- : ClientHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - ; ! (( : AdjustWindowSize { width height win -- } [ SWP_SHOWWINDOW SWP_NOZORDER or SWP_NOMOVE or ] literal *************** *** 176,182 **** 0 \ ignore z-order win Call SetWindowPos drop ; ! :M ReSize: ( -- ) ! ShowToolbar? if Height: TheRebar else 0 then to ToolBarHeight ShowStatusbar? if Height: ScintillaStatusbar else 0 then to StatusBarHeight --- 176,182 ---- 0 \ ignore z-order win Call SetWindowPos drop ; ! )) :M ReSize: ( -- ) ! ShowToolbar? if Height: TheRebar else 0 then to ToolBarHeight ShowStatusbar? if Height: ScintillaStatusbar else 0 then to StatusBarHeight *************** *** 188,192 **** LeftWidth ToolBarHeight thickness ClientHeight Move: Splitter ! ShowToolbar? if Width Height: TheRebar GetHandle: TheRebar AdjustWindowSize then ShowStatusbar? if Redraw: ScintillaStatusbar then ;M --- 188,193 ---- LeftWidth ToolBarHeight thickness ClientHeight Move: Splitter ! \ ShowToolbar? if Width Height: TheRebar GetHandle: TheRebar AdjustWindowSize then ! ShowToolbar? if AutoSize: TheRebar then ShowStatusbar? if Redraw: ScintillaStatusbar then ;M *************** *** 481,485 **** :M WM_NOTIFY { h m w l -- res } ! l 2 cells+ @ RBN_AUTOSIZE = \ has TheRebar size changed? if Resize: self then h m w l Handle_Notify: pToolBar \ must be first for some reason --- 482,487 ---- :M WM_NOTIFY { h m w l -- res } ! l 2 cells+ @ RBN_HEIGHTCHANGE = \ Rebar height has changed ! \ must NOT resize rebar on RBN_AUTOSIZE if Resize: self then h m w l Handle_Notify: pToolBar \ must be first for some reason |
|
From: Rod O. <rod...@us...> - 2006-06-15 20:55:14
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22425/apps/Win32ForthIDE Modified Files: EdToolbar.f Log Message: Rod: Removed divider from toolbars, added dividers between rebar bands. Index: EdToolbar.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdToolbar.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** EdToolbar.f 14 Jun 2006 06:02:56 -0000 1.2 --- EdToolbar.f 15 Jun 2006 20:55:08 -0000 1.3 *************** *** 167,171 **** WindowStyle: super [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or CCS_ADJUSTABLE or nostack1 ! CCS_NOPARENTALIGN or CCS_NORESIZE or ] LITERAL or FlatToolBar? if TBSTYLE_FLAT or --- 167,171 ---- WindowStyle: super [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or CCS_ADJUSTABLE or nostack1 ! CCS_NOPARENTALIGN or CCS_NORESIZE or CCS_NODIVIDER or ] LITERAL or FlatToolBar? if TBSTYLE_FLAT or *************** *** 246,250 **** WindowStyle: super [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or nostack1 ! CCS_NOPARENTALIGN or CCS_NORESIZE or ] LITERAL or FlatToolBar? if TBSTYLE_FLAT or --- 246,250 ---- WindowStyle: super [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or nostack1 ! CCS_NOPARENTALIGN or CCS_NORESIZE or CCS_NODIVIDER or ] LITERAL or FlatToolBar? if TBSTYLE_FLAT or *************** *** 335,339 **** :M WindowStyle: ( -- style ) WindowStyle: super ! [ WS_CLIPSIBLINGS WS_CLIPCHILDREN or CCS_NODIVIDER or RBS_VARHEIGHT or RBS_BANDBORDERS or RBS_AUTOSIZE or ] literal or ;M --- 335,339 ---- :M WindowStyle: ( -- style ) WindowStyle: super ! [ WS_CLIPSIBLINGS WS_CLIPCHILDREN or WS_BORDER or RBS_VARHEIGHT or RBS_BANDBORDERS or RBS_AUTOSIZE or ] literal or ;M |
|
From: Rod O. <rod...@us...> - 2006-06-15 18:48:49
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv17001/src/lib Modified Files: FileLister.f Log Message: Rod: Added null-check definition which is not present in TreeView class when derived from Control. Index: FileLister.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/FileLister.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** FileLister.f 14 Jun 2006 05:55:17 -0000 1.1 --- FileLister.f 15 Jun 2006 18:48:46 -0000 1.2 *************** *** 1,2 **** --- 1,4 ---- + \ $Id$ + \ FileLister.f List Files in a Folder \ Thursday, August 19 2004 - Ezra Boyce *************** *** 554,566 **** ['] 0> to sortorder ;M ! \ : null-check ( a1 -- a1 ) ! \ ?win-error-enabled 0= ! \ if dup 0= ! \ if drop ['] noop \ convert null to NOOP ! \ exit \ and exit ! \ then ! \ then ! \ dup 0= s" Attempt to execute a NULL function" ?TerminateBox ! \ ; : dosortorder ( n -- f ) --- 556,568 ---- ['] 0> to sortorder ;M ! : null-check ( a1 -- a1 ) ! ?win-error-enabled 0= ! if dup 0= ! if drop ['] noop \ convert null to NOOP ! exit \ and exit ! then ! then ! dup 0= s" Attempt to execute a NULL function" ?TerminateBox ! ; : dosortorder ( n -- f ) |
|
From: Rod O. <rod...@us...> - 2006-06-15 18:44:01
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14293/src/lib Modified Files: treeview.f Log Message: Rod: Changed back to use Control rather than Child-Window. Added StartSize: method. Index: treeview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/treeview.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** treeview.f 13 Jun 2006 18:46:49 -0000 1.8 --- treeview.f 15 Jun 2006 18:43:54 -0000 1.9 *************** *** 1,4 **** --- 1,10 ---- \ $Id$ + \ TreeView.f Thursday, June 15 2006 Rod + \ Changed to use Control rather than Child-Window + \ On creation needs a sensible StartSize: ( default set to size of parent ) + \ Class control does not have the definition "null-check" which is in + \ class Window and hence Child-Window. + (( TreeView.F A rudimentary TreeView class by Michael Hillerström mic...@us... *************** *** 86,93 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ :Class TreeViewControl <super control ! \ converted back into a child window as a quick an dirty fix for the ! \ FileLister class (Montag, Juni 12 2006 - dbu) ! :Class TreeViewControl <super child-window Record: nmhdr --- 92,96 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! :Class TreeViewControl <super control Record: nmhdr *************** *** 183,231 **** \ -------------------- Create Tree-View Control -------------------- - create treeview-class z," SysTreeView32" \ Pre-registered class - :M WindowStyle: ( -- style ) [ WS_CHILD WS_VISIBLE or ] literal ;M ! \ :M Start: ( Parent -- ) ! \ hWnd ! \ if drop ! \ SW_SHOWNOACTIVATE Show: self ! \ else to Parent ! \ Call InitCommonControls drop ! \ treeview-class Create-Control ! \ then ;M ! ! : create-treeview ( -- hWnd ) ! \ Make sure Common Controls are loaded ! Call InitCommonControls drop ! ! NULL \ Creation parameter ! appInst \ Instance handle ! id \ Child id ! Parent conhndl = ! if conhndl ! else GetHandle: Parent \ parent window handle ! then ! tempRect.AddrOf GetClientRect: Parent ! Bottom: tempRect Right: tempRect \ Size h,w ! 0 0 \ Position y,x ! WindowStyle: [ self ] \ Style ! NULL \ Window name ! treeview-class \ Pre-registered class ! 0 \ Extended style ! Call CreateWindowEx ! ; :M Start: ( Parent -- ) hWnd ! if drop ! SW_SHOWNOACTIVATE Show: self ! else ! to Parent ! create-treeview to hWnd ! then ! ;M :M Handle_Notify: ( h m w l -- f ) --- 186,203 ---- \ -------------------- Create Tree-View Control -------------------- :M WindowStyle: ( -- style ) [ WS_CHILD WS_VISIBLE or ] literal ;M ! :M StartSize: ( -- w h ) width: parent height: parent ;M :M Start: ( Parent -- ) hWnd ! if drop ! SW_SHOWNOACTIVATE Show: self ! else to Parent ! \ Call InitCommonControls drop ! z" SysTreeView32" Create-Control ! then ;M :M Handle_Notify: ( h m w l -- f ) |
|
From: George H. <geo...@us...> - 2006-06-14 11:31:30
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv2066/win32forth/apps/Win32ForthIDE Modified Files: Main.f Log Message: gah: set sysgen to build system Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** Main.f 14 Jun 2006 06:02:56 -0000 1.13 --- Main.f 14 Jun 2006 11:15:52 -0000 1.14 *************** *** 19,23 **** only forth also editor definitions \ put all words into the EDITOR vocabulary ! \ true value sysgen s" apps\Win32ForthIDE" "fpath+ --- 19,23 ---- only forth also editor definitions \ put all words into the EDITOR vocabulary ! true value sysgen s" apps\Win32ForthIDE" "fpath+ |
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv16317 Modified Files: CommandID.f EdImageWindow.f EdTabControl.f EdToolbar.f Main.f ProjectTree.f Added Files: EdFilePane.f FileWindow.frm Log Message: .Added directory window and project toolbar. EAB Index: EdTabControl.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdTabControl.f,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** EdTabControl.f 11 Jun 2006 18:04:10 -0000 1.9 --- EdTabControl.f 14 Jun 2006 06:02:56 -0000 1.10 *************** *** 166,169 **** --- 166,171 ---- ;class + fload edfilepane.f + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ an extended TabControl class *************** *** 189,192 **** --- 191,195 ---- ClassBrowserWindow cVocTree + :M WndClassStyle: ( -- style ) \ Set the style member of the the WNDCLASS structure. *************** *** 200,205 **** 4dup Move: cFileList 4dup Move: cProjectTree ! 4dup Move: cClassTree ! Move: cVocTree ;M --- 203,209 ---- 4dup Move: cFileList 4dup Move: cProjectTree ! 4dup Move: cClassTree ! 4dup Move: cVocTree ! Move: TheFolderView ;M *************** *** 213,216 **** --- 217,221 ---- SW_HIDE Show: cVocTree SW_HIDE Show: cClassTree + SW_HIDE Show: TheFolderView ; *************** *** 220,223 **** --- 225,229 ---- SW_HIDE Show: cVocTree SW_HIDE Show: cClassTree + SW_HIDE Show: TheFolderView ; *************** *** 227,230 **** --- 233,237 ---- SW_HIDE Show: cProjectTree SW_HIDE Show: cClassTree + SW_HIDE Show: TheFolderView ; *************** *** 234,237 **** --- 241,253 ---- SW_HIDE Show: cProjectTree SW_HIDE Show: cVocTree + SW_HIDE Show: TheFolderView + ; + + : ShowFolderView ( -- ) + SW_HIDE Show: cClassTree + SW_HIDE Show: cFileList + SW_HIDE Show: cProjectTree + SW_HIDE Show: cVocTree + SW_SHOW Show: TheFolderView ; *************** *** 243,250 **** \ Show the control for the currently selected tab. GetSelectedTab: cTab ! case 0 of ShowFiles endof ! 1 of ShowProject endof ! 2 of ShowVocs endof ! 3 of ShowClasses endof endcase ;M --- 259,267 ---- \ Show the control for the currently selected tab. GetSelectedTab: cTab ! case 0 of ShowFiles endof ! 1 of ShowProject endof ! 2 of ShowFolderView endof ! 3 of ShowVocs endof ! 4 of ShowClasses endof endcase ;M *************** *** 278,281 **** --- 295,299 ---- self Start: cVocTree self Start: cClassTree + self Start: TheFolderView self Start: cTab \ must be started last *************** *** 293,302 **** TCIF_TEXT IsMask: cTab ! z" Vocabularies" IsPszText: cTab 3 InsertTab: cTab TCIF_TEXT IsMask: cTab z" Classes" IsPszText: cTab ! 4 InsertTab: cTab \ ------------------------------------------------------------------------ --- 311,324 ---- TCIF_TEXT IsMask: cTab ! z" Directory" IsPszText: cTab 3 InsertTab: cTab + + TCIF_TEXT IsMask: cTab + z" Vocabularies" IsPszText: cTab + 4 InsertTab: cTab TCIF_TEXT IsMask: cTab z" Classes" IsPszText: cTab ! 5 InsertTab: cTab \ ------------------------------------------------------------------------ Index: EdImageWindow.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdImageWindow.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** EdImageWindow.f 9 Jun 2006 17:03:35 -0000 1.2 --- EdImageWindow.f 14 Jun 2006 06:02:56 -0000 1.3 *************** *** 3,7 **** cr .( Loading Image Viewer...) ! fload apps\forthform\imagewindow.f create imagefiles \ image files that can be viewed --- 3,7 ---- cr .( Loading Image Viewer...) ! needs imagewindow.f create imagefiles \ image files that can be viewed --- NEW FILE: FileWindow.frm --- \ FILEWINDOW.FRM \- textbox needs excontrols.f \- -filelister.f needs filelister.f \ folder browser \ Coordinates and dimensions for imgButton1 9 value imgButton1X 4 value imgButton1Y 24 value imgButton1W 22 value imgButton1H \ Coordinates and dimensions for ImgButton2 43 value ImgButton2X 4 value ImgButton2Y 24 value ImgButton2W 22 value ImgButton2H \ Coordinates and dimensions for ImgButton3 77 value ImgButton3X 4 value ImgButton3Y 24 value ImgButton3W 22 value ImgButton3H \ Coordinates and dimensions for ImgButton4 111 value ImgButton4X 4 value ImgButton4Y 24 value ImgButton4W 22 value ImgButton4H \ Coordinates and dimensions for ImgButton5 145 value ImgButton5X 4 value ImgButton5Y 24 value ImgButton5W 22 value ImgButton5H ComboListBox cmblstPathPicker FileWindow TheDirectory ComboListBox CmbLstFilters :Object frmFileWindow <Super Child-Window Font WinFont ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND ColorObject FrmColor \ the background color :M ClassInit: ( -- ) ClassInit: super +dialoglist \ allow handling of dialog messages 384 to id \ set child id, changeable \ Insert your code here ;M :M Display: ( -- ) \ unhide the child window SW_SHOWNORMAL Show: self ;M :M Hide: ( -- ) \ hide the...aughhh but you know that! SW_HIDE Show: self ;M :M WindowTitle: ( -- ztitle ) z" Select File" ;M :M StartSize: ( -- width height ) 184 449 ;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: cmblstPathPicker 2 30 180 17 Move: cmblstPathPicker Handle: Winfont SetFont: cmblstPathPicker self Start: TheDirectory 2 50 180 371 Move: TheDirectory self Start: CmbLstFilters 2 423 180 23 Move: CmbLstFilters Handle: Winfont SetFont: CmbLstFilters ;M :M WM_COMMAND ( h m w l -- res ) over LOWORD ( ID ) self \ object address on stack WMCommand-Func ?dup \ must not be zero if execute else 2drop \ drop ID and object address then 0 ;M :M SetCommand: ( cfa -- ) \ set WMCommand function to WMCommand-Func ;M :M On_Paint: ( -- ) 0 0 GetSize: self Addr: FrmColor FillArea: dc ;M :M On_Done: ( -- ) Delete: WinFont \ Insert your code here On_Done: super ;M ;Object Index: ProjectTree.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ProjectTree.f,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** ProjectTree.f 13 Jun 2006 19:14:50 -0000 1.9 --- ProjectTree.f 14 Jun 2006 06:02:56 -0000 1.10 *************** *** 9,14 **** needs fcases.f - s" apps\ProMgr\res" "fpath+ - true value name-only? true value no-duplicates? --- 9,12 ---- *************** *** 19,23 **** --- 17,24 ---- 0 value ThisList \ temp pointer to list being used 0 value ThisItem \ temp pointer to new item + \ 0 value TheProject + \ 0 value TheStatusBar 0 value TheStatusBar + 0 value dirty? 0 value Modified *************** *** 371,382 **** : .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? ; --- 372,383 ---- : .buildfile ( -- ) ! mainfile c@ dup ! if s" " ! 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> count SetText: ProjInfo false to dirty? ; *************** *** 480,491 **** :M On_SelChanged: ( -- f ) lparamNew to SelectedItem itemid: SelectedItem ! if ReleaseBuffer: viewerfile ! FileExt off ! else GetName: SelectedItem zcount pad place ! pad IDM_OPEN_RECENT_FILE DoCommand ! then false ;M :M SelectItem: ( hItem -- ) TVGN_CARET TVM_SELECTITEM SendMessage:SelfDrop ;M --- 481,507 ---- :M On_SelChanged: ( -- f ) + new$ >r lparamNew to SelectedItem itemid: SelectedItem ! \ <<<<<<< ProjectTree.f ! if ! s" Number of files = " r@ place ! #items: SelectedItem (.) r@ +place ! r@ ! FileExt off ! else ! GetName: SelectedItem dup zcount ! 2dup ".ext-only" 2dup lower FileExt place \ set FileExt ! ! GetName: SelectedItem zcount r@ place ! r@ dup IDM_OPEN_RECENT_FILE DoCommand ! ! then ! count Settext: ProjStatus .buildfile ! SetFocus: self \ ProjectManager.htm item lost focus before ! false ! r>drop ! ;M :M SelectItem: ( hItem -- ) TVGN_CARET TVM_SELECTITEM SendMessage:SelfDrop ;M *************** *** 980,988 **** if 2dup addfile ! \ 2dup asciiz 0 SetText: ProjectStatusBar dialog? IF 2dup pad place -2 pad c+! s" .res" pad +place pad count addfile ! \ 2dup asciiz 0 SetText: ProjectStatusBar THEN skip-recurse? --- 996,1004 ---- if 2dup addfile ! 2dup SetText: ProjStatus dialog? IF 2dup pad place -2 pad c+! s" .res" pad +place pad count addfile ! 2dup SetText: ProjStatus THEN skip-recurse? *************** *** 1000,1011 **** reset-results GetBuildFile: TheProject nip 0= ! if SelectAFile c@ ! if 0 GetFile: GetFilesDialog ! SetBuildFile: TheProject ! else 2drop exit ! then then - if Clear: TheProject then GetBuildFile: TheProject ModuleList: TheProject AddItem: TheProject --- 1016,1029 ---- reset-results GetBuildFile: TheProject nip 0= ! if SelectAFile c@ ! if 0 GetFile: GetFilesDialog ! SetBuildFile: TheProject ! else drop exit ! then GetBuildFile: TheProject ModuleList: TheProject ! AddItem: TheProject ! true to Modified then if Clear: TheProject then + s" " SetText: ProjStatus GetBuildFile: TheProject ModuleList: TheProject AddItem: TheProject *************** *** 1014,1027 **** \ clear-status-bar GetBuildFile: TheProject BuildNeededFiles SortParentLists: TheProject - \ #addedfiles Modified or to Modified - \ #addedfiles (.) pad place - \ s" files added " pad +place - \ #linecount (.) pad +place - \ s" total lines search of " pad +place - \ total-size (.) pad +place - \ s" bytes" pad +place - \ pad +NULL - \ pad 1+ 0 SetText: ProjectStatusBar ; IDM_BUILD_PRJ SetCommand --- 1032,1046 ---- \ clear-status-bar GetBuildFile: TheProject BuildNeededFiles + #addedfiles Modified or to Modified + #addedfiles (.) pad place + s" files added " pad +place + #linecount (.) pad +place + s" total lines search of " pad +place + total-size (.) pad +place + s" bytes" pad +place + pad count SetText: ProjStatus + GetBuildFile: TheProject SetBuildFile: TheProject \ update info + SortParentLists: TheProject ; IDM_BUILD_PRJ SetCommand Index: EdToolbar.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdToolbar.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** EdToolbar.f 5 Jun 2006 09:19:00 -0000 1.1 --- EdToolbar.f 14 Jun 2006 06:02:56 -0000 1.2 *************** *** 21,26 **** --- 21,40 ---- anew -ScintillaToolbar.f + TextBox ProjStatus + TextBox ProjInfo + INTERNAL + EXTERNAL + + false value ButtonText? + true value FlatToolBar? + + \ ----------------------------------------------------------------------------------- + \ Main-Toolbar + \ ----------------------------------------------------------------------------------- + + :Object ControlToolbar <super Win32ToolBar + load-bitmap ControlBitmaps "res\toolbar.bmp" *************** *** 101,115 **** ;ToolBarTable - EXTERNAL - - false value ButtonText? - true value FlatToolBar? - - \ ----------------------------------------------------------------------------------- - \ Main-Toolbar - \ ----------------------------------------------------------------------------------- - - :Object ControlToolbar <super Win32ToolBar - int hbitmap 72 constant LargeButtonWidth \ for buttons with text --- 115,118 ---- *************** *** 117,121 **** 24 constant SmallButtonWidth \ a little bigger than Windows default 18 constant SmallButtonHeight ! 30 constant #buttons :M ClassInit: ( -- ) --- 120,124 ---- 24 constant SmallButtonWidth \ a little bigger than Windows default 18 constant SmallButtonHeight ! 17 constant #buttons :M ClassInit: ( -- ) *************** *** 183,186 **** --- 186,264 ---- ;Object + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ \\\\\ The Project Toolbar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + :Object ptoolbar <Super Win32Toolbar + + load-bitmap ptoolbarBitmap "ToolbarBitmaps.bmp" + + :ToolStrings ptoolbarTooltips + ts," New Project" + ts," Open Project" + ts," Save Project" + ts," Delete item" + ts," Build Project" + ts," Archive project" + ts," Add files" + ts," Copy project files" + ;ToolStrings + + :ToolBarTable ptoolbarTable + \ Bmp ndx ID Initial Style Initial State Tooltip Ndx + \ The default state and style for all buttons are enabled and button style + \ You can modify as desired + 0 IDM_NEW_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 0 ToolBarButton, + 1 IDM_OPEN_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 1 ToolBarButton, + 2 IDM_SAVE_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 2 ToolBarButton, + 3 IDM_DELETE_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 3 ToolBarButton, + 4 IDM_BUILD_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 4 ToolBarButton, + 5 IDM_ZIP_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 5 ToolBarButton, + 6 IDM_ADD_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 6 ToolBarButton, + 7 IDM_COPY_PRJ TBSTATE_ENABLED TBSTYLE_BUTTON 7 ToolBarButton, + ;ToolBarTable + + int hbitmap + + :M ClassInit: ( -- ) + ClassInit: super + 0 to hbitmap + ;M + + :M Start: ( parent -- ) + ptoolbarTable IsButtonTable: self + ptoolbarTooltips IsTooltips: self + + Start: super + + 16 18 word-join 0 TB_SETBITMAPSIZE hwnd call SendMessage drop \ smaller height of toolbar + + ptoolbarbitmap usebitmap + map-3Dcolors \ use system colors for background + GetDc: self dup CreateDIBitmap to hbitmap \ create bitmap handle from memory image + ReleaseDc: self + hbitmap \ do we have a handle? + if 0 hbitmap 8 AddBitmaps: self drop + then + ;M + + :M WindowStyle: ( -- style ) + WindowStyle: super + [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or nostack1 + CCS_NOPARENTALIGN or CCS_NORESIZE or ] LITERAL or + FlatToolBar? + if TBSTYLE_FLAT or + then + ;M + + :M On_Done: ( -- ) + hbitmap + if hbitmap Call DeleteObject drop + 0 to hbitmap + then On_Done: super + ;M + + ;Object + \ ----------------------------------------------------------------------------------- \ Rebar *************** *** 189,204 **** :Object TheRebar <super RebarControl ! : insert-band ( hWnd fstyle -- ) to fstyle to hWndChild ! [ RBBIM_CHILD RBBIM_CHILDSIZE or RBBIM_STYLE or RBBIM_SIZE or ] LITERAL to bfmask 0 to cxMinChild ! 25 to cyMinChild 25 to cyChild \ band height 200 to cyMaxChild \ max band height 1 to cyIntegral ! 200 to cx \ band width InsertBand: self ; --- 267,285 ---- :Object TheRebar <super RebarControl ! Font TextFont ! ! : insert-band ( hWnd fstyle size -- ) ! to cx to fstyle to hWndChild ! [ RBBIM_CHILD RBBIM_CHILDSIZE or RBBIM_STYLE or RBBIM_SIZE or RBBIM_TEXT or ] LITERAL to bfmask 0 to cxMinChild ! 22 to cyMinChild 25 to cyChild \ band height 200 to cyMaxChild \ max band height 1 to cyIntegral ! \ 450 to cx \ band width InsertBand: self ; *************** *** 209,218 **** eraseband-info GetHandle: ControlToolBar ! [ RBBS_GRIPPERALWAYS RBBS_CHILDEDGE or ] literal insert-band ; :M Start: ( parent -- ) Start: super ! hwnd if add-toolbars then ;M :M WindowStyle: ( -- style ) --- 290,335 ---- eraseband-info GetHandle: ControlToolBar ! [ RBBS_GRIPPERALWAYS RBBS_CHILDEDGE or ] literal 450 insert-band ! ; ! ! : add-projStat ( -- ) ! self Start: ProjStatus ! true ReadOnly: ProjStatus ! ! eraseband-info GetHandle: ProjStatus ! z" Project Status:" to lptext ! [ RBBS_GRIPPERALWAYS RBBS_CHILDEDGE or ] literal 200 insert-band ! ; ! ! : add-projInfo ( -- ) ! self Start: ProjInfo ! true ReadOnly: ProjInfo ! ! eraseband-info GetHandle: ProjInfo ! z" Build File:" to lptext ! [ RBBS_GRIPPERALWAYS RBBS_CHILDEDGE or ] literal 200 insert-band ! ; ! ! : add-projtoolbar ( -- ) ! self Start: pToolBar ! ! eraseband-info GetHandle: pToolBar ! [ RBBS_GRIPPERALWAYS RBBS_CHILDEDGE or ] literal 200 insert-band ; :M Start: ( parent -- ) + + s" MS Sans Serif" SetFaceName: TextFont + 8 Width: TextFont + Create: TextFont + Start: super ! hwnd ! if add-toolbars ! add-projstat ! add-projtoolbar ! add-projinfo ! Handle: textFont dup SetFont: ProjStatus SetFont: ProjInfo ! then ;M :M WindowStyle: ( -- style ) *************** *** 223,226 **** --- 340,345 ---- :M Close: ( -- ) Close: ControlToolBar + Close: pToolBar + Delete: TextFont Close: super ;M *************** *** 292,294 **** ! |
|
From: Ezra B. <ezr...@us...> - 2006-06-14 06:02:59
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/res In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv16317/res Added Files: copy.bmp delete.bmp drive.bmp dupe.bmp specs.bmp Log Message: .Added directory window and project toolbar. EAB --- NEW FILE: copy.bmp --- (This appears to be a binary file; contents omitted.) --- NEW FILE: dupe.bmp --- (This appears to be a binary file; contents omitted.) --- NEW FILE: delete.bmp --- (This appears to be a binary file; contents omitted.) --- NEW FILE: drive.bmp --- (This appears to be a binary file; contents omitted.) --- NEW FILE: specs.bmp --- (This appears to be a binary file; contents omitted.) |
|
From: Ezra B. <ezr...@us...> - 2006-06-14 05:59:04
|
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14799/apps/ForthForm Modified Files: EXAMPLE.ff EXAMPLE.frm Removed Files: FileLister.f IMAGEWINDOW.F Log Message: Some file shifting. EAB --- IMAGEWINDOW.F DELETED --- --- FileLister.f DELETED --- Index: EXAMPLE.ff =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/EXAMPLE.ff,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 Binary files /tmp/cvsaWPYgH and /tmp/cvsYONzPV differ Index: EXAMPLE.frm =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/EXAMPLE.frm,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** EXAMPLE.frm 21 Dec 2004 00:18:45 -0000 1.1 --- EXAMPLE.frm 14 Jun 2006 05:59:01 -0000 1.2 *************** *** 1,67 **** ! anew tstfrmExample ! needs excontrols.f ! ! TextBox txtName ! TextBox txtAddress ! TextBox txtCity ! TextBox txtCountry ! CheckBox chkWin32Forth ! CheckBox chkSwiftForth ! CheckBox chkOther ! TextBox txtFileName ! PushButton btnBrowse ! PushButton btnOk ! PushButton btnCancel ! PushButton Button4 ! CheckBox Check4 ! colorobject formcolor ! :Object frmExample <Super Child-Window ! Font WinFont ! 0 value hparent \ pointer to parent of form ! ' 2drop value OnWmCommand \ function pointer for WM_COMMAND ! Label lblName ! Label lblAddress ! Label lblCity ! Label lblCountry ! GroupBox grpForthProgrammer ! Label lblFile ! RadioButton Radio1 ! Label Label6 :M ClassInit: ( -- ) ClassInit: super ! +dialoglist ;M :M WindowStyle: ( -- style ) ! windowstyle: super ;M \ if this form is a modal form a non-zero parent must be set ! :M ParentWindow: ( -- parent | 0 if no parent ) ! hparent ;M ! :M SetParent: ( parentwindow -- ) \ set owner window ! to hparent ;M :M WindowTitle: ( -- ztitle ) ! z" Forthform Example" ;M :M StartSize: ( -- width height ) ! 505 262 ;M :M StartPos: ( -- x y ) ! 64 213 ;M :M Close: ( -- ) \ Insert your code here Close: super --- 1,54 ---- ! \ EXAMPLE.FRM ! \- textbox needs excontrols.f ! \- -filelister.f needs filelister.f \ folder browser ! FileWindow dirbox ! TextBox txtpath ! PushButton btnDelete ! PushButton btnChoose ! PushButton btnClose ! ComboListBox CmbLstFilters ! :Object frmExample <Super DialogWindow + Font WinFont \ default font + ' 2drop value WmCommand-Func \ function pointer for WM_COMMAND + ColorObject FrmColor \ the background color + StatusBar TheStatusBar ! Label lblPath :M ClassInit: ( -- ) ClassInit: super ! \ Insert your code here ;M :M WindowStyle: ( -- style ) ! WS_POPUPWINDOW WS_DLGFRAME or ;M \ if this form is a modal form a non-zero parent must be set ! :M ParentWindow: ( -- hwndparent | 0 if no parent ) ! parent ;M ! :M SetParent: ( hwndparent -- ) \ set owner window ! to parent ;M :M WindowTitle: ( -- ztitle ) ! z" Example - Directory Viewer" ;M :M StartSize: ( -- width height ) ! 345 455 ;M :M StartPos: ( -- x y ) ! 150 175 ;M :M Close: ( -- ) + Close: dirbox \ Insert your code here Close: super *************** *** 71,211 **** s" MS Sans Serif" SetFaceName: WinFont 8 Width: WinFont ! Create: WinFont ! ! color_btnface call GetSysColor NewColor: formcolor ! ! self Start: lblName ! 33 22 45 17 Move: lblName ! Handle: Winfont SetFont: lblName ! SS_RIGHT +Style: lblName ! s" Name:" SetText: lblName ! ! self Start: lblAddress ! 33 41 45 17 Move: lblAddress ! Handle: Winfont SetFont: lblAddress ! SS_RIGHT +Style: lblAddress ! s" Address:" SetText: lblAddress ! ! self Start: lblCity ! 33 60 45 17 Move: lblCity ! Handle: Winfont SetFont: lblCity ! SS_RIGHT +Style: lblCity ! s" City:" SetText: lblCity ! ! self Start: lblCountry ! 33 79 45 17 Move: lblCountry ! Handle: Winfont SetFont: lblCountry ! SS_RIGHT +Style: lblCountry ! s" Country:" SetText: lblCountry ! ! self Start: txtName ! 83 22 236 17 Move: txtName ! Handle: Winfont SetFont: txtName ! ! self Start: txtAddress ! 83 41 236 17 Move: txtAddress ! Handle: Winfont SetFont: txtAddress ! ! self Start: txtCity ! 83 60 236 17 Move: txtCity ! Handle: Winfont SetFont: txtCity ! ! self Start: txtCountry ! 83 79 236 17 Move: txtCountry ! Handle: Winfont SetFont: txtCountry ! ! self Start: grpForthProgrammer ! 28 109 270 63 Move: grpForthProgrammer ! Handle: Winfont SetFont: grpForthProgrammer ! s" Forth Programmer" SetText: grpForthProgrammer ! ! self Start: chkWin32Forth ! 44 127 81 19 Move: chkWin32Forth ! WS_GROUP +Style: chkWin32Forth ! Handle: Winfont SetFont: chkWin32Forth ! s" Win32Forth" SetText: chkWin32Forth ! ! self Start: chkSwiftForth ! 127 127 81 19 Move: chkSwiftForth ! Handle: Winfont SetFont: chkSwiftForth ! s" SwiftForth" SetText: chkSwiftForth ! self Start: chkOther ! 210 127 81 19 Move: chkOther ! Handle: Winfont SetFont: chkOther ! s" Other" SetText: chkOther ! self Start: txtFileName ! 61 184 221 18 Move: txtFileName ! Handle: Winfont SetFont: txtFileName - self Start: btnBrowse - 289 184 62 19 Move: btnBrowse - Handle: Winfont SetFont: btnBrowse - s" Browse" SetText: btnBrowse ! self Start: btnOk ! 40 227 119 31 Move: btnOk ! WS_GROUP +Style: btnOk ! Handle: Winfont SetFont: btnOk ! s" &Ok" SetText: btnOk ! self Start: btnCancel ! 200 227 119 31 Move: btnCancel ! Handle: Winfont SetFont: btnCancel ! s" &Cancel" SetText: btnCancel ! self Start: lblFile ! 16 184 42 16 Move: lblFile ! Handle: Winfont SetFont: lblFile ! SS_RIGHT +Style: lblFile ! s" File:" SetText: lblFile ! self Start: Button4 ! 382 23 103 23 Move: Button4 ! Handle: Winfont SetFont: Button4 ! s" These were" SetText: Button4 ! self Start: Check4 ! 382 52 98 19 Move: Check4 ! Handle: Winfont SetFont: Check4 ! s" added after" SetText: Check4 ! self Start: Radio1 ! 382 80 95 18 Move: Radio1 ! Handle: Winfont SetFont: Radio1 ! s" the demo" SetText: Radio1 ! self Start: Label6 ! 382 114 91 17 Move: Label6 ! Handle: Winfont SetFont: Label6 ! s" was written" SetText: Label6 - ParentWindow: self \ if this is a modal form disable parent - if 0 ParentWindow: self Call EnableWindow drop then ;M :M WM_COMMAND ( h m w l -- res ) over LOWORD ( ID ) self \ object address on stack ! OnWMCommand ?dup \ must not be zero if execute else 2drop \ drop ID and object address then 0 ;M ! :M SetCommand: ( cfa -- ) \ set OnWMCommand function ! to OnWMCommand ;M :M On_Paint: ( -- ) ! 0 0 GetSize: self formcolor FillArea: dc ;M :M On_Done: ( -- ) Delete: WinFont - ParentWindow: self \ if modal form re-enable parent - if 1 ParentWindow: self Call EnableWindow drop - \ reset focus to parent if we have one - ParentWindow: self Call SetFocus drop - then \ Insert your code here On_Done: super --- 58,123 ---- s" MS Sans Serif" SetFaceName: WinFont 8 Width: WinFont ! Create: WinFont drop \ not testing return flag ! \ set form color to system color ! COLOR_BTNFACE Call GetSysColor NewColor: FrmColor ! self Start: TheStatusBar ! self Start: dirbox ! 8 37 225 358 Move: dirbox ! self Start: lblPath ! 9 9 72 19 Move: lblPath ! Handle: Winfont SetFont: lblPath ! s" Selected Path:" SetText: lblPath ! self Start: txtpath ! 83 9 247 21 Move: txtpath ! Handle: Winfont SetFont: txtpath ! self Start: btnDelete ! 239 40 100 25 Move: btnDelete ! Handle: Winfont SetFont: btnDelete ! s" &Delete File" SetText: btnDelete ! self Start: btnChoose ! 239 69 100 25 Move: btnChoose ! Handle: Winfont SetFont: btnChoose ! s" Choose &Folder" SetText: btnChoose ! self Start: btnClose ! 239 364 100 25 Move: btnClose ! Handle: Winfont SetFont: btnClose ! s" &Close" SetText: btnClose ! self Start: CmbLstFilters ! 8 401 224 20 Move: CmbLstFilters ! Handle: Winfont SetFont: CmbLstFilters ;M :M WM_COMMAND ( h m w l -- res ) over LOWORD ( ID ) self \ object address on stack ! WMCommand-Func ?dup \ must not be zero if execute else 2drop \ drop ID and object address then 0 ;M ! :M SetCommand: ( cfa -- ) \ set WMCommand function ! to WMCommand-Func ;M :M On_Paint: ( -- ) ! 0 0 GetSize: self Addr: FrmColor FillArea: dc ! ;M ! ! :M On_Size: ( -- ) ! Redraw: TheStatusBar ;M :M On_Done: ( -- ) Delete: WinFont \ Insert your code here On_Done: super *************** *** 213,219 **** ;Object - - window mywin start: mywin - 1 setid: frmexample - mywin start: frmexample - 0 0 startsize: frmexample move: frmexample \ No newline at end of file --- 125,126 ---- |
|
From: Ezra B. <ezr...@us...> - 2006-06-14 05:55:26
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13205/src/lib Modified Files: ExUtils.f Added Files: FileLister.f IMAGEWINDOW.F Log Message: Some file shifting. EAB --- NEW FILE: IMAGEWINDOW.F --- \ FreeImageWindow.f \ Routines to define object class for viewing bitmaps in a window \ Some code extracted from 4FreeImage.f by J.v.d.Ven \ August 31, 2004 - updated to use DrawDibDraw function for displaying bitmaps \ July 12th, 2003 - 21:44 \ November 22nd, 2003 - 22:29 - updated to be more versatile with \ image handling & manipulation. Added functions from FreeImage.dll version 3.0 \ September 8th, 2003 - 18:08 - added Wipe: to imagewindow class to allow just \ blanking a window. \ only forth also definitions WinLibrary FreeImage.dll WINLIBRARY msvfw32.dll 0x0004 constant DDF_SAME_HDC needs enum.f \ enumerated constants \- as >SYSTEM : AS WINPROC-LAST @ PROC>CFA ALIAS ; SYSTEM> \- ?exitm macro ?exitm " if exitm then" INTERNAL \ FreeImage Load / Save flag constants #define BMP_DEFAULT 0 #define BMP_SAVE_RLE 1 #define CUT_DEFAULT 0 #define ICO_DEFAULT 0 #define ICO_FIRST 0 #define ICO_SECOND 0 #define ICO_THIRD 0 #define IFF_DEFAULT 0 #define JPEG_DEFAULT 0 #define JPEG_FAST 1 #define JPEG_ACCURATE 2 #define JPEG_QUALITYSUPERB 0x80 #define JPEG_QUALITYGOOD 0x100 #define JPEG_QUALITYNORMAL 0x200 #define JPEG_QUALITYAVERAGE 0x400 #define JPEG_QUALITYBAD 0x800 #define KOALA_DEFAULT 0 #define LBM_DEFAULT 0 #define MNG_DEFAULT 0 #define PCD_DEFAULT 0 #define PCD_BASE 1 #define PCD_BASEDIV4 2 #define PCD_BASEDIV16 3 #define PCX_DEFAULT 0 #define PNG_DEFAULT 0 #define PNG_IGNOREGAMMA 1 // avoid gamma correction #define PNM_DEFAULT 0 #define PNM_SAVE_RAW 0 // If set the writer saves in RAW format (i.e. P4, P5 or P6) #define PNM_SAVE_ASCII 1 // If set the writer saves in ASCII format (i.e. P1, P2 or P3) #define PSD_DEFAULT 0 #define RAS_DEFAULT 0 #define TARGA_DEFAULT 0 #define TARGA_LOAD_RGB888 1 // If set the loader converts RGB555 and ARGB8888 -> RGB888. #define TARGA_LOAD_RGB555 2 // This flag is obsolete #define TIFF_DEFAULT 0 #define TIFF_CMYK 0x0001 // reads/stores tags for separated CMYK (use | to combine with compression flags) #define TIFF_PACKBITS 0x0100 // save using PACKBITS compression #define TIFF_DEFLATE 0x0200 // save using DEFLATE compression #define TIFF_ADOBE_DEFLATE 0x0400 // save using ADOBE DEFLATE compression #define TIFF_NONE 0x0800 // save without any compression #define WBMP_DEFAULT 0 #define XBM_DEFAULT 0 #define XPM_DEFAULT 0 \ possible FreeImage file types -1 to enum-value 1 to increment enum: FIF_UNKNOWN FIF_BMP FIF_ICO FIF_JPEG FIF_JNG FIF_KOALA FIF_LBM FIF_MNG FIF_PBM FIF_PBMRAW FIF_PCD FIF_PCX FIF_PGM FIF_PGMRAW FIF_PNG FIF_PPM FIF_PPMRAW FIF_RAS FIF_TARGA FIF_TIFF FIF_WBMP FIF_PSD FIF_CUT FIF_XBM FIF_XPM FIF_GIF ; FIF_LBM Constant FIF_IFF /* * Image type used in FreeImage. */ 0 to enum-value enum: FIT_UNKNOWN // unknown type FIT_BITMAP // standard image : 1-, 4-, 8-, 16-, 24-, 32-bit FIT_UINT16 // array of unsigned short : unsigned 16-bit FIT_INT16 // array of short : signed 16-bit FIT_UINT32 // array of unsigned long : unsigned 32-bit FIT_INT32 // array of long : signed 32-bit FIT_FLOAT // array of float : 32-bit IEEE floating point FIT_DOUBLE // array of double : 64-bit IEEE floating point FIT_COMPLEX // array of FICOMPLEX : 2 x 64-bit IEEE floating point ; /* Image color type used in FreeImage. */ 0 to enum-value enum: FIC_MINISWHITE // min value is white FIC_MINISBLACK // min value is black FIC_RGB // RGB color model FIC_PALETTE // color map indexed FIC_RGBALPHA // RGB color model with alpha channel FIC_CMYK // CMYK color model ; /* Color quantization algorithms. Constants used in FreeImage_ColorQuantize. */ 0 to enum-value enum: FIQ_WUQUANT // Xiaolin Wu color quantization algorithm FIQ_NNQUANT // NeuQuant neural-net quantization algorithm by Anthony Dekker ; /* Dithering algorithms. Constants used FreeImage_Dither. */ 0 to enum-value enum: FID_FS // Floyd & Steinberg error diffusion FID_BAYER4x4 // Bayer ordered dispersed dot dithering (order 2 dithering matrix) FID_BAYER8x8 // Bayer ordered dispersed dot dithering (order 3 dithering matrix) FID_CLUSTER6x6 // Ordered clustered dot dithering (order 3 - 6x6 matrix) FID_CLUSTER8x8 // Ordered clustered dot dithering (order 4 - 8x8 matrix) FID_CLUSTER16x16 // Ordered clustered dot dithering (order 8 - 16x16 matrix) ; /* Upsampling / downsampling filters. Constants used in FreeImage_Rescale. */ 0 to enum-value enum: FILTER_BOX // Box, pulse, Fourier window, 1st order (constant) b-spline FILTER_BICUBIC // Mitchell & Netravali's two-param cubic filter FILTER_BILINEAR // Bilinear filter FILTER_BSPLINE // 4th order (cubic) b-spline FILTER_CATMULLROM // Catmull-Rom spline, Overhauser spline FILTER_LANCZOS3 // Lanczos3 filter ; /* Color channels. Constants used in color manipulation routines. */ 0 to enum-value enum: FICC_RGB // Use red, green and blue channels FICC_RED // Use red channel FICC_GREEN // Use green channel FICC_BLUE // Use blue channel FICC_ALPHA // Use alpha channel FICC_BLACK // Use black channel FICC_REAL // Complex images: use real part FICC_IMAG // Complex images: use imaginary part FICC_MAG // Complex images: use magnitude FICC_PHASE // Complex images: use phase ; EXTERNAL 1 proc _FreeImage_GetWidth@4 as FIGetWidth 1 proc _FreeImage_GetHeight@4 as FIGetHeight 4 proc _FreeImage_Save@16 as FISave 1 proc _FreeImage_GetInfo@4 as FIGetInfo 1 proc _FreeImage_GetBits@4 as FIGetBits 1 proc _FreeImage_Unload@4 as FIUnload 3 proc _FreeImage_Load@12 as FILoad 1 proc _FreeImage_GetFIFFromFilename@4 as FIGetInfoFromFilename 9 proc _FreeImage_ConvertFromRawBits@36 as FIConvertFromRawBits 2 proc _FreeImage_GetFileType@8 as FIGetFileType 0 proc _FreeImage_GetVersion@0 as FIGetVersion 1 proc _FreeImage_FlipVertical@4 as FIFlipVertical 1 proc _FreeImage_FlipHorizontal@4 as FIFlipHorizontal 1 proc _FreeImage_ConvertTo8Bits@4 as FIConvertTo8Bits 1 proc _FreeImage_ConvertTo16Bits565@4 as FIConvertTo16Bits 1 proc _FreeImage_ConvertTo24Bits@4 as FIConvertTo24Bits 1 proc _FreeImage_ConvertTo32Bits@4 as FIConvertTo32Bits 2 proc _FreeImage_RotateClassic@12 as FIRotate 2 proc _FreeImage_AdjustBrightness@12 as FIAdjustBrightness 2 proc _FreeImage_AdjustContrast@12 as FIAdjustContrast 0 proc _FreeImage_Invert@4 as FIInvert 1 proc _FreeImage_Clone@4 as FIClone 1 proc _FreeImage_GetBPP@4 as FIBitsPerPixel 4 proc _FreeImage_Rescale@16 as FIReScale 2 proc _FreeImage_AdjustGamma@12 as FIAdjustGamma 4 proc _FreeImage_LoadFromHandle@16 as FILoadFromHandle 1 to enum-value enum: NORMAL_FIT BEST_FIT FIT_SIZE ; INTERNAL 0 value ThisImage \ allow forward referencing for right click 0 value wincnt \ count of open image windows PopUpBar ImagePopupBar PopUp "" MenuItem "Open image file" OpenImageFile: ThisImage ; MenuItem "Erase image" Wipe: ThisImage ; MenuItem "Restore original image" Reload: ThisImage ; MenuSeparator SubMenu "Save image as" MenuItem "Bitmap" SaveAsBitmap: ThisImage ; MenuItem "Jpeg" SaveAsJpeg: ThisImage ; MenuItem "Png" SaveAsPng: ThisImage ; EndSubMenu MenuSeparator false MENUMESSAGE "Action" MenuSeparator MenuItem "Invert image" InvertImage: ThisImage ; SubMenu "Flip" MenuItem "Horizontal" FlipHorizontal: ThisImage ; MenuItem "Vertical" FlipVertical: ThisImage ; EndSubMenu SubMenu "Rotate" MenuItem "90 degrees" 90.0e RotateImage: ThisImage ; MenuItem "180 degrees" 180.0e RotateImage: ThisImage ; MenuItem "270 degrees" 270.0e RotateImage: ThisImage ; EndSubMenu SubMenu "Convert image to" :MenuItem mnu8 "8 bits" ConvertTo8Bits: ThisImage ; :MenuItem mnu16 "16 bits" ConvertTo16Bits: ThisImage ; :MenuItem mnu24 "24 bits" ConvertTo24Bits: ThisImage ; :MenuItem mnu32 "32 bits" ConvertTo32Bits: ThisImage ; EndSubmenu MenuSeparator SubMenu "View Mode" :MenuItem mnunorm "Normal" NORMAL_FIT SetViewMode: ThisImage ; :MenuItem mnuscale "Best Fit" BEST_FIT SetViewMode: ThisImage ; :MenuItem mnufit "Fit to size" FIT_SIZE SetViewMode: ThisImage ; EndSubMenu MenuSeparator SubMenu "BackGround" :MenuItem mnublack "BLACK" BLACK SetBackGroundColor: ThisImage ; :MenuItem mnuwhite "WHITE" WHITE SetBackGroundColor: ThisImage ; EndSubMenu Endbar EXTERNAL FileOpenDialog GetImageFile "Select Image File" "Image Files|*.bmp;*.dib;*.rle;*.jpg;*.jpeg;*.ico;*.pcd;*.psd;*.pcx;*.ppm;*.pgm;*.pbm;*.png;*.ras;*.tga;*.tif;*.gif|All Files (*.*)|*.*|" FileSaveDialog SaveAsBitmapDlg "Save Image File:" "Bitmap|*.bmp;*.dib|Jpeg|*.jpg;*.jpeg|Png|*.png|All Image Files|*.bmp;*.dib;*.rle;*.jpg;*.jpeg;*.ico;*.pcd;*.psd;*.pcx;*.ppm;*.pgm;*.pbm;*.png;*.ras;*.tga;*.tif;*.gif|All Files (*.*)|*.*|" :Class FreeImageWindow <Super Child-Window WinDC ImageDC int FIBITMAP \ pointer to FreeImage bitmap structure int BackGroundColor int ViewMode int dopopup? max-path bytes ImageFileName 256 value image-id int &bitmap int >&bitmap int DrawDibDC 4 CallBack: FIReadProc { &buffer size cnt fihandle -- cnt } fihandle &bitmap <> abort" Attempted read from wrong bitmap!" cnt 0 do >&bitmap &buffer size move size +to >&bitmap size +to &buffer loop cnt ; 4 CallBack: FIWriteProc { &buffer size cnt fihandle -- size } size ; 3 CallBack: FISeekProc { fihandle offset origin -- 0 } fihandle &bitmap <> abort" Attempted seek from wrong bitmap!" origin case SEEK_SET of fihandle offset + to >&bitmap endof SEEK_END of abort" Invalid seek" endof offset +to >&bitmap endcase 0 ; 1 CallBack: FITellProc { fihandle -- res } fihandle &bitmap <> abort" Attempted query from wrong bitmap!" fihandle >&bitmap > abort" Invalid handle!" >&bitmap fihandle - ; create IOProcs &FIReadProc , &FIWriteProc , &FISeekProc , &FITellProc , :M LoadFromHandle: { FIF_FORMAT addr -- FIBITMP } addr to &bitmap addr to >&bitmap 0 &bitmap IOProcs FIF_FORMAT FILoadFromHandle ;M : gen-id ( -- id ) image-id 1 +to image-id ; : ValidImage? ( -- f ) FIBITMAP 0<> hwnd 0<> and ; :M ImageWidth: ( -- w ) FIBITMAP FIGetWidth ;M :M ImageHeight: ( -- h ) FIBITMAP FIGetHeight ;M :M SaveImage: { imgtype imgparam -- } \ At the same size ValidImage? not ?exitm hwnd Start: SaveAsBitmapDlg dup c@ 0= if drop exitm then count new$ dup>r place r@ count ".ext-only" nip 0= if imgtype case FIF_BMP of s" .bmp" endof FIF_JPEG of s" .jpg" endof FIF_PNG of s" .png" endof \ FIF_BMP to imgtype s" .bmp" rot s" .img" rot \ default extension endcase r@ +place then imgparam r> 1+ FIBITMAP imgtype FISave drop ;M : CalcImageSize { \ cxDib cyDib - wDib hDib } ImageWidth: self to cxDib ImageHeight: self to cyDib \ calc scale factor Width s>f cxDib s>f f/ \ dxScale Height s>f cyDib s>f f/ \ dyScale fmin \ dScale \ remove this line, if the Image should be scaled to max window size \ fdup f1.0 f> if fdrop f1.0 then \ dScale \ calc bitmap size cyDib s>f fover f* f0.5 f+ \ dScale dHeight cxDib s>f frot f* f0.5 f+ \ dHeight dWidth f>s f>s ; \ wWidth hHeight : ErasePartOfWindow ( left top right bottom ) BackGroundColor FillArea: ImageDC ; : wipe-window ( -- ) temprect GetClientRect: self 0 0 Right: Temprect Bottom: Temprect ErasePartOfWindow ; : ShowScaledImage ( --) \ load and draw Image; keep aspect ratio DDF_SAME_HDC ImageHeight: self \ nSrcHeight ImageWidth: self \ nSrcWidth 0 \ y-coord of source upper-left corner 0 \ x-coord of source upper-left corner FIBITMAP FIGetBits \ *lpBits FIBITMAP FIGetInfo \ *lpBitsInfo CalcImageSize swap \ nDestHeight nDestWidth \ center bitmap in window 2dup Height rot - 2/ dup 0> \ YDest if 0 0 Width 3 pick ErasePartOfWindow \ top 0 Height 2 pick - 1- Width Height ErasePartOfWindow \ bottom then Width rot - 2/ dup 0> \ XDest if 0 0 2 pick Height ErasePartOfWindow \ left Width over - 1- 0 Width Height ErasePartOfWindow \ right then ImageDC.hdc DrawDIBDC Call DrawDibDraw drop ; : ShowImageInFixedWindow ( -- ) \ load and draw Image; fit to window DDF_SAME_HDC ImageHeight: self \ cScanlines ImageWidth: self \ dwWidth 0 \ Ysrc 0 \ Xsrc FIBITMAP FIGetBits \ *lpvBits FIBITMAP FIGetInfo \ *lpBmi Height Width 0 ( y-coord of dest upper-left corner ) \ ydest 0 ( x-coord of dest upper-left corner ) \ xdest ImageDC.hdc DrawDIBDC Call DrawDibDraw drop ; : ShowImage ( -- ) \ load and draw Image; keep Image size wipe-window DDF_SAME_HDC ImageHeight: self \ cScanlines ImageWidth: self \ dwWidth 0 \ Ysrc 0 \ Xsrc FIBITMAP FIGetBits \ *lpvBits FIBITMAP FIGetInfo \ *lpBmi -1 \ use -1 \ image size 0 ( y-coord of dest upper-left corner ) \ ydest 0 ( x-coord of dest upper-left corner ) \ xdest ImageDC.hdc \ hdc DrawDIBDC Call DrawDibDraw drop ; : check-bits ( -- ) BitsPerPixel: [ self ] case 8 of true Check: mnu8 false Enable: mnu8 false Check: mnu16 false Check: mnu24 false Check: mnu32 true Enable: mnu16 true Enable: mnu24 true Enable: mnu32 endof 16 of true Check: mnu16 false Enable: mnu16 false Check: mnu8 false Check: mnu24 false Check: mnu32 true Enable: mnu8 true Enable: mnu24 true Enable: mnu32 endof 24 of true Check: mnu24 false Enable: mnu24 false Check: mnu8 false Check: mnu16 false Check: mnu32 true Enable: mnu8 true Enable: mnu16 true Enable: mnu32 endof 32 of true Check: mnu32 false Enable: mnu32 false Check: mnu8 false Check: mnu16 false Check: mnu24 true Enable: mnu8 true Enable: mnu16 true Enable: mnu24 endof ( default ) false Check: mnu8 false Check: mnu16 false Check: mnu24 false Check: mnu32 true Enable: mnu8 true Enable: mnu16 true Enable: mnu24 true Enable: mnu32 endcase ; : check-mode ( -- ) ViewMode case NORMAL_FIT of true Check: mnunorm false Check: mnuscale false Check: mnufit endof BEST_FIT of false Check: mnunorm true Check: mnuscale false Check: mnufit endof FIT_SIZE of false Check: mnunorm false Check: mnuscale true Check: mnufit endof ( default ) false Check: mnunorm false Check: mnuscale false Check: mnufit endcase BackGroundColor WHITE = dup not Check: mnuBlack Check: mnuWhite check-bits ; : DisplayImage ( -- ) ValidImage? not if wipe-window exit then ViewMode case NORMAL_FIT of ShowImage endof BEST_FIT of ShowScaledImage endof FIT_SIZE of ShowImageInFixedWindow endof endcase check-mode ; :M SetViewMode: ( f -- ) to ViewMode hwnd if DisplayImage then ;M :M SetBackGroundColor: ( color_object -- ) to BackGroundColor hwnd if DisplayImage then ;M :M UnLoadImage: ( -- ) ValidImage? if FIBITMAP FIUnload drop 0 to FIBITMAP then ;M : LoadImage ( -- ) UnLoadImage: self ImageFileName c@ 0<> if \ get filetype 0 ImageFileName 1+ dup>r FIGetFileType dup FIF_UNKNOWN = if \ on some filetype's _FreeImage_GetFileType fails, so \ try to get the filetype from the filename drop r@ FIGetInfoFromFilename then dup FIF_UNKNOWN <> if \ open file 0 r@ rot FILoad to FIBITMAP else drop then r>drop then ; :M SetImageFile: ( addr cnt -- ) \ filename for image ImageFileName dup>r place r> +null LoadImage DisplayImage ;M :M Wipe: ( -- ) \ clear any image from window UnLoadImage: self DisplayImage ;M :M ImageFileName: ( -- addr cnt ) \ return name of image file FIBITMAP if ImageFileName count else pad 0 then ;M :M OpenImageFile: ( -- ) hwnd ?dup if Start: GetImageFile dup c@ if count SetImageFile: self else drop then then ;M :M SetImageFromMemory: ( flag blue green red depth pitch height width lpvbits -- ) FIConvertFromRawBits dup FIF_UNKNOWN <> if UnLoadImage: self to FIBITMAP DisplayImage else drop then ;M :M LoadMemoryBitmap: ( &bitmap -- ) FIF_BMP swap LoadFromHandle: self dup FIF_UNKNOWN <> if UnLoadImage: self to FIBITMAP DisplayImage else drop then ;M :M ReLoad: ( -- ) \ redraw using earlier set image LoadImage DisplayImage ;M :M Refresh: ( -- ) DisplayImage ;M : open-image ( -- ) OpenImageFile: self ; :M ClassInit: ( -- ) ClassInit: Super 0 to FIBITMAP WHITE to BackGroundColor NORMAL_FIT to ViewMode ImageFileName max-path erase true to dopopup? gen-id to id ['] open-image SetDblClickFunc: self \ double click opens file 0 to DrawDibDC ;M :M On_Paint: ( -- ) Refresh: self ;M :M On_Init: ( -- ) On_Init: super ImagePopupBar SetPopupBar: self GetDc: self dup Puthandle: ImageDC HALFTONE swap Call SetStretchBltMode drop \ better image quality Call DrawDibOpen to DrawDIBDC ;M :M On_Done: ( -- ) GetHandle: ImageDC ReleaseDC: self DrawDIBDC Call DrawDibClose drop UnLoadImage: self On_Done: super ;M :M WM_RBUTTONDOWN ( h m w l -- ) dopopup? if self to ThisImage check-mode \ for popup menu WM_RBUTTONDOWN WM: Super else DefWindowProc: self then ;M :M WM_LBUTTONDBLCLK ( h w m l -- ) dopopup? if WM_LBUTTONDBLCLK WM: Super else DefWindowProc: self then ;M :M EnablePopup: ( -- ) true to dopopup? ;M :M DisablePopup: ( -- ) false to dopopup? ;M : ?version3+ ( -- f ) FIGetVersion c@ '0' - 3 >= dup 0= s" Version 3.xx of FreeImage library required for this function" ?MessageBox ; :M FlipVertical: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIFlipVertical drop Refresh: self ;M :M FlipHorizontal: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIFlipHorizontal drop Refresh: self ;M :M SaveAsJpeg: ( -- ) FIF_JPEG JPEG_QUALITYGOOD SaveImage: self ;M :M SaveAsBmp: ( -- ) FIF_BMP BMP_DEFAULT SaveImage: self ;M :M SaveAsPng: ( -- ) FIF_PNG PNG_DEFAULT SaveImage: self ;M :M BitsPerPixel: ( -- n ) ValidImage? if FIBITMAP FIBitsPerPixel else 0 then ;M :M ConvertTo8Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 8 = ?exitm FIBITMAP FIConvertTo8Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo16Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 16 = ?exitm FIBITMAP FIConvertTo16Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo24Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 24 = ?exitm FIBITMAP FIConvertTo24Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo32Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 32 = ?exitm FIBITMAP FIConvertTo32Bits UnLoadImage: self to FIBITMAP Refresh: self ;M \ the following routines require floating point parameters :M RotateImage: ( fs: degrees -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FiRotate UnLoadImage: self to FIBITMAP Refresh: self ;M :M AdjustBrightness: ( fs: percentage -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FIAdjustBrightness drop Refresh: self ;M :M AdjustContrast: ( fs: percentage -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FIAdjustContrast drop Refresh: self ;M :M InvertImage: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIInvert drop Refresh: self ;M :M ImageHandle: ( -- fibitmap ) FIBITMAP ;M :M SetImageHandle: ( fibitmap -- ) UnLoadImage: self to FIBITMAP ;M :M Clone: ( -- fibitmap ) ValidImage? if FIBITMAP FIClone else 0 then ;M :M Zoom: { w h -- } ValidImage? not ?exitm ?version3+ not ?exitm BitsPerPixel: self 32 <> if ConvertTo32Bits: self then FILTER_BILINEAR h w FIBITMAP FIReScale UnLoadImage: self to FIBITMAP Refresh: self ;M \ Performs gamma correction on a 8-, 24- or 32-bit image. The gamma parameter \ represents the gamma value to use (gamma > 0). A value of 1.0 leaves the image \ alone, less than one darkens it, and greater than one lightens it. :M AdjustGamma: ( fs: gamma -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then BitsPerPixel: self 8 < if 2drop exitm then FIBITMAP FIAdjustGamma drop Refresh: self ;M ;Class MODULE \s >SYSTEM : AS WINPROC-LAST @ PROC>CFA ALIAS ; SYSTEM> \ Usage 1 proc ExitThread as EXIT-TASK \ creates a Word that compiles or executes the Function call All exported functions from FreeImage.dll version 3.xx+ _FreeImage_AdjustBrightness@12 _FreeImage_AdjustContrast@12 _FreeImage_AdjustCurve@12 _FreeImage_AdjustGamma@12 _FreeImage_Allocate@24 _FreeImage_AppendPage@8 _FreeImage_Clone@4 _FreeImage_CloseMultiBitmap@8 _FreeImage_ColorQuantize@8 _FreeImage_ConvertFromRawBits@36 _FreeImage_ConvertLine16To24_555@12 _FreeImage_ConvertLine16To24_565@12 _FreeImage_ConvertLine16To32_555@12 _FreeImage_ConvertLine16To32_565@12 _FreeImage_ConvertLine16To8_555@12 _FreeImage_ConvertLine16To8_565@12 _FreeImage_ConvertLine16_555_To16_565@12 _FreeImage_ConvertLine16_565_To16_555@12 _FreeImage_ConvertLine1To16_555@16 _FreeImage_ConvertLine1To16_565@16 _FreeImage_ConvertLine1To24@16 _FreeImage_ConvertLine1To32@16 _FreeImage_ConvertLine1To8@12 _FreeImage_ConvertLine24To16_555@12 _FreeImage_ConvertLine24To16_565@12 _FreeImage_ConvertLine24To32@12 _FreeImage_ConvertLine24To8@12 _FreeImage_ConvertLine32To16_555@12 _FreeImage_ConvertLine32To16_565@12 _FreeImage_ConvertLine32To24@12 _FreeImage_ConvertLine32To8@12 _FreeImage_ConvertLine4To16_555@16 _FreeImage_ConvertLine4To16_565@16 _FreeImage_ConvertLine4To24@16 _FreeImage_ConvertLine4To32@16 _FreeImage_ConvertLine4To8@12 _FreeImage_ConvertLine8To16_555@16 _FreeImage_ConvertLine8To16_565@16 _FreeImage_ConvertLine8To24@16 _FreeImage_ConvertLine8To32@16 _FreeImage_ConvertTo16Bits555@4 _FreeImage_ConvertTo16Bits565@4 _FreeImage_ConvertTo24Bits@4 _FreeImage_ConvertTo32Bits@4 _FreeImage_ConvertTo8Bits@4 _FreeImage_ConvertToRawBits@32 _FreeImage_Copy@20 _FreeImage_CreateICCProfile@12 _FreeImage_DeInitialise@0 _FreeImage_DeletePage@8 _FreeImage_DestroyICCProfile@4 _FreeImage_Dither@8 _FreeImage_FIFSupportsExportBPP@8 _FreeImage_FIFSupportsICCProfiles@4 _FreeImage_FIFSupportsReading@4 _FreeImage_FIFSupportsWriting@4 _FreeImage_FlipHorizontal@4 _FreeImage_FlipVertical@4 _FreeImage_GetBPP@4 _FreeImage_GetBits@4 _FreeImage_GetBlueMask@4 _FreeImage_GetChannel@8 _FreeImage_GetColorType@4 _FreeImage_GetColorsUsed@4 _FreeImage_GetCopyrightMessage@0 _FreeImage_GetDIBSize@4 _FreeImage_GetDotsPerMeterX@4 _FreeImage_GetDotsPerMeterY@4 _FreeImage_GetFIFCount@0 _FreeImage_GetFIFDescription@4 _FreeImage_GetFIFExtensionList@4 _FreeImage_GetFIFFromFilename@4 _FreeImage_GetFIFFromFormat@4 _FreeImage_GetFIFFromMime@4 _FreeImage_GetFIFRegExpr@4 _FreeImage_GetFileType@8 _FreeImage_GetFileTypeFromHandle@12 _FreeImage_GetFormatFromFIF@4 _FreeImage_GetGreenMask@4 _FreeImage_GetHeight@4 _FreeImage_GetHistogram@12 _FreeImage_GetICCProfile@4 _FreeImage_GetInfo@4 _FreeImage_GetInfoHeader@4 _FreeImage_GetLine@4 _FreeImage_GetLockedPageNumbers@12 _FreeImage_GetPageCount@4 _FreeImage_GetPalette@4 _FreeImage_GetPitch@4 _FreeImage_GetRedMask@4 _FreeImage_GetScanLine@8 _FreeImage_GetTransparencyCount@4 _FreeImage_GetTransparencyTable@4 _FreeImage_GetVersion@0 _FreeImage_GetWidth@4 _FreeImage_Initialise@4 _FreeImage_InsertPage@12 _FreeImage_Invert@4 _FreeImage_IsLittleEndian@0 _FreeImage_IsPluginEnabled@4 _FreeImage_IsTransparent@4 _FreeImage_Load@12 _FreeImage_LoadFromHandle@16 _FreeImage_LockPage@8 _FreeImage_MovePage@12 _FreeImage_OpenMultiBitmap@20 _FreeImage_OutputMessageProc _FreeImage_Paste@20 _FreeImage_RegisterExternalPlugin@20 _FreeImage_RegisterLocalPlugin@20 _FreeImage_Rescale@16 _FreeImage_RotateClassic@12 _FreeImage_RotateEx@48 _FreeImage_Save@16 _FreeImage_SaveToHandle@20 _FreeImage_SetChannel@12 _FreeImage_SetOutputMessage@4 _FreeImage_SetPluginEnabled@8 _FreeImage_SetTransparencyTable@12 _FreeImage_SetTransparent@8 _FreeImage_Threshold@8 _FreeImage_Unload@4 _FreeImage_UnlockPage@12 _FreeImage_ZLibCompress@16 _FreeImage_ZLibUncompress@16 --- NEW FILE: FileLister.f --- \ FileLister.f List Files in a Folder \ Thursday, August 19 2004 - Ezra Boyce \ Code adapted from ProjectManager.f, a.k.a shamelessly ripped off :-) \ See the FileWindow class at end of file for available methods and uses anew -FileLister.f needs linklist.f needs treeview.f needs bitmap.f needs apps\forthform\quiksort.f load-bitmap folderbmp "apps\forthform\res\folder.bmp" : rootdir? { pathstr cnt -- f } \ f = true if path is at root pathstr cnt + 2 - w@ s" :\" drop w@ = ?dup ?exit pathstr cnt + 1- c@ ':' = ; \- ?exitm macro ?exitm " if exitm then" :Object FileFinder <Super Object max-path bytes findpath 32 bytes findspecs :M FindFirstFile: ( addr cnt -- ior ) \ ior = 0 = success find-first-file nip ;M :M FindNextFile: ( -- ior ) \ ior = 0 = success find-next-file nip ;M :M FindClose: ( -- ior ) \ ior = 0 = success find-close drop ;M :M GetFileAttributes: ( -- n ) _Win32-Find-Data @ ;M :M GetFileName: ( -- adr cnt ) get-file-name zcount ;M :M GetFileSize: ( -- d ) get-file-size ;M :M ClassInit: ( -- ) ClassInit: super findpath max-path erase s" *.*" findspecs place \ default ;M : .or..? ( -- f ) \ is found file directories . or ..? GetFileName: self drop c@ '.' = ; :M IsDirectory?: ( -- f ) \ exclude . and .. GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0<> .or..? not and ;M :M IsFile?: ( -- f ) GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0= ;M :M SetUp: ( pathstr len spec$ cnt -- ) \ pathstr len = pointer to path to search \ spec$ cnt = file specs to search for dup 0= if 2drop s" *.*" then 31 min 0max findspecs place findpath place ;M :M FindFiles: ( -- f ) \ specs should be already setup new$ >r findpath count r@ place findspecs count dup if r@ ?+\ then r@ +place r> count FindFirstFile: self ;M :M FullPath: ( -- addr cnt ) \ return full path of directory found findpath count new$ dup>r place GetFileName: self dup if r@ ?+\ then r@ +place r> count ;M ;Object :Class FolderItem <super Object record: iteminfo max-path 1+ bytes itemname int parenttree \ parent treeview control int parentitem \ parent item in treeview control int hwnditem \ handle for item short itemflags 2 bits itemid \ item id, 0 for child item 14 bits reservedflags ;recordsize: sizeof(iteminfo) int iconhandle cell bytes index \ save information for each individual file Record: Win32_Find_Data int FileAttributes int FileCreationTimeLow int FileCreationTimeHigh int FileLastAccessTimeLow int FileLastAccessTimeHigh int FileLastWriteTimeLow int FileLastWriteTimeHigh int FileSizeHigh int FileSizeLow int Reserved0 int Reserved1 max-path bytes FileName 14 bytes AlternateFileName ;RecordSize: sizeof(Win32_Find_Data) :M GetFileAttributes: ( -- n ) FileAttributes ;M :M GetFileName: ( -- adr cnt ) FileName zcount ;M :M GetFileSize: ( -- d ) FileSizeLow ;M : .or..? ( -- f ) \ is found file directories . or ..? GetFileName: self drop c@ '.' = ; :M IsFile?: ( -- f ) GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0= ;M :M IsDirectory?: ( -- f ) \ exclude . and .. IsFile?: self not .or..? not and ;M :M classinit: ( -- ) classinit: super iteminfo sizeof(iteminfo) erase Win32_Find_Data sizeof(Win32_Find_Data) erase 0 to iconhandle -1 index ! ;M :m GetData: ( -- addr cnt ) \ access for any additional information needed Win32_Find_Data sizeof(Win32_Find_Data) ;m :M setname: ( addr cnt -- ) \ assumes name is set for FindFirstFile, FindNextFile etc. itemname max-path erase max-path min 0max itemname swap move \ transfer the info _Win32-Find-Data Win32_Find_Data sizeof(Win32_Find_Data) move ;M :m getname: ( -- addrz ) itemname ;m :m getname$: ( -- addr cnt ) itemname zcount ;m :m isparentitem: ( n -- ) to parentitem ;m :m parentitem: ( -- n ) parentitem ;m :m isparenttree: ( n -- ) to parenttree ;m :m parenttree: ( -- n ) parenttree ;m :m handle: ( -- hwnd ) hwnditem ;m :m ishandle: ( n -- ) to hwnditem ;m :m itemid: ( -- f ) itemid ;m :m isitemid: ( f -- ) to itemid ;m :m iconhandle: ( -- n ) iconhandle ;m :m isiconhandle: ( n -- ) to iconhandle ;m :m index: ( -- n ) index @ ;m :m isindex: ( n -- ) index ! ;m :M AddIcon: ( -- ) index itemname conhndl Call ExtractAssociatedIcon to iconhandle ;M /* Windows API say the following isn't necessary :M ~: ( -- ) iconhandle ?dup if Call DestroyIcon drop 0 to iconhandle then ;M */ ;class :Class TreeList <super linked-list int hwndlist int itemid 32 constant listmax \ maximum length of list name listmax 1+ bytes listname :m handle: ( -- n ) hwndlist ;m :m ishandle: ( hwnd -- ) to hwndlist ;m :m itemid: ( -- f ) itemid ;m :m isitemid: ( f -- ) to itemid ;m :m setname: ( addr cnt -- ) listname dup listmax erase swap listmax min 0max move ;m :m getname: ( -- namez ) listname ;m :m classinit: ( -- ) classinit: super s" .." setname: self -1 isitemid: self ;m \ identifies parent :m DeleteItem: { item \ flag -- } Data@: self 0= ?exitm false to flag #Links: self 1+ 1 ?do i >Link#: self Data@: self item = if 0 Data!: self DeleteLink: self item dispose true to flag \ mark as found leave then loop flag 0= abort" Item not found in list!" ;m :m total: ( -- n ) Data@: self if #links: self else 0 then ;m :m GetEntry: { n -- obj | 0 } 0 total: self 0= ?exitm n 1 total: self between not ?exitm drop n >Link#: self Data@: self ;m ;class :Class FolderTree <super TreeViewControl int ThisItem \ temp pointer to new item int hwndmain \ handle of root item in tree int hwndimage \ handle to imagelist int FolderList int sortorder int tree-click \ called when an item is clicked int on_update \ called when folder tree is refreshed int SelectedItem \ tree item object int show-files? \ do we want to display files as well as directories? int #dirs \ number of directories found when updating int #fls \ ditto files max-path bytes thespecs int hwndlabel \ handle to window to display path \ number of files shown is limited only by available memory \ however only first 4k will be sorted. Of course the buffer size could always be increased 16 1024 * constant recbuffer-size recbuffer-size cell / constant max-recs \ about 4000 files and directories for sorting int recbuffer \ pointer to memory used for sorting 2 cells bytes rootname max-path 1+ bytes Treepath : free-recbuffer ( -- ) recbuffer ?dup if release 0 to recbuffer then ; :M Handle: ( -- hwndmain ) hwndmain ;M :m SetRootName: ( addr cnt -- ) rootname 2 cells erase rootname swap move ;m :m Setpath: { addr cnt -- } \ check for valid path addr cnt + 2 - w@ 0x5C3A = \ are the last chars ':\' i.e root dir? if addr cnt treepath place treepath +null exitm then addr cnt find-first-file ?exitm \ does not exist so exit @ FILE_ATTRIBUTE_DIRECTORY and \ something was found if addr cnt treepath place \ it is a directory treepath +null then find-close drop ;M :m Getpath: ( -- addr cnt ) treepath count ;M :M SetSpecs: ( addr cnt -- ) thespecs place ;M :M GetSpecs: ( -- addr cnt ) thespecs count ;M :M IsLabelHandle: ( hwnd -- ) to hwndlabel ;M : CreateImageList ( -- ) \ create image list for treeview control total: folderlist 2 + \ maximum images dup 2 max \ number of images to use ILC_COLOR4 \ color depth 18 16 \ bitmap size height,width Call ImageList_Create to hwndimage ; : RegisterList ( -- ) \ register list with this treeview control hwndimage ?dup 0= ?exit TVSIL_NORMAL TVM_SETIMAGELIST hwnd send-window ; : add-icons { \ item -- } \ add icon for each file total: folderlist 1+ 1 ?do i >Link#: FolderList Data@: FolderList to item IconHandle: item hwndimage Call ImageList_AddIcon dup -1 <> if isindex: item else drop then loop ; \ A folder has a default icon to represent it but I find it displays kinda dark in the \ treeview imagelist. I am sure it is simply something I am missing about image lists \ but for now I will use my own folder bitmap to represent folders in the treeview : Add-folderbmp { \ hbitmap -- } hwndimage 0= ?exit \ we don't have any folderbmp usebitmap map-3dcolors \ create bitmap handle GetDc: self dup>r CreateDIBitmap to hbitmap r> ReleaseDc: self hbitmap \ was it successful? if NULL \ no overlay image list hbitmap hwndimage Call ImageList_Add drop hbitmap Call DeleteObject drop \ discard, windows has a copy then ; : AddImages ( -- ) CreateImageList RegisterList Color: WHITE hwndimage Call ImageList_SetBkColor drop add-folderbmp add-icons ; : ?Hasfiles ( -- f ) \ does a directory have any files? IsDirectory?: ThisItem if treepath count pad place pad ?+\ s" *.*" pad +place \ not necessarily the "thespecs" value pad count find-first-file nip 0= if find-close drop 1 else 0 then else 0 then ; : ?itemimage ( -- n ) IsDirectory?: ThisItem if 1 \ use my folder bitmap for directory entries else index: ThisItem \ use associated file icon then ; : AddTreeItem ( -- ) \ add file or directory to tree tvins /tvins erase tvitem /tvitem erase ?HasFiles to cChildren Handle: FolderList to hParent TVI_LAST to hInsertAfter GetName$: ThisItem "to-pathend" asciiz to pszText ThisItem to lparam ?itemimage dup to iImage to iSelectedImage [ TVIF_TEXT TVIF_CHILDREN or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE or ] LITERAL to mask tvitem->tvins tvins 0 TVM_INSERTITEMA hWnd Call SendMessage IsHandle: ThisItem ; : UpdateList ( addr cnt -- ) \ save file info SetName: ThisItem FolderList IsParentItem: ThisItem self IsParentTree: ThisItem IsDirectory?: Thisitem isitemid: ThisItem AddIcon: ThisItem ; : add-items ( -- ) \ actually add found files to tree AddImages >FirstLink: FolderList #dirs 0 \ directories first ?do Data@: FolderList to ThisItem AddTreeItem >NextLink: FolderList loop show-files? #fls 0<> and \ and then files if #dirs 1+ dup >Link#: FolderList total: FolderList 1+ swap ?do Data@: FolderList to ThisItem AddTreeItem >NextLink: FolderList loop then ; : AddFile ( str cnt -- ) Data@: FolderList if AddLink: FolderList then New> FolderItem dup Data!: FolderList to ThisItem ( str cnt ) UpdateList ; : ?rootimage ( -- n ) rootname zcount rootdir? 1 and ; : AddRoot ( -- ) tvins /tvins erase tvitem /tvitem erase 1 to cChildren \ assuming we have TVI_ROOT to hParent TVI_LAST to hInsertAfter Folderlist to lparam getname: lparam to pszText ?rootimage dup to iImage to iSelectedImage [ TVIF_TEXT TVIF_CHILDREN or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE or ] LITERAL to mask tvitem->tvins tvins 0 TVM_INSERTITEMA hWnd Call SendMessage dup ishandle: FolderList to hwndmain ; : CreateTree ( -- ) new> treelist to FolderList rootname zcount SetName: FolderList ; :M start: ( parent -- ) start: super CreateTree AddRoot recbuffer-size malloc to recbuffer ;M :m Classinit: ( -- ) Classinit: super 0 to SelectedItem s" .." setrootname: self treepath off s" *.*" thespecs place ['] drop to tree-click ['] drop to on_update 0 to SelectedItem true to show-files? 0 to #dirs 0 to #fls 0 to hwndlabel 0 to recbuffer SortAscending: [ self ] ;m : DisposeTheList ( -- ) FolderList if Folderlist DisposeList FolderList Dispose 0 to FolderList then ; :M WindowStyle: ( -- style ) WindowStyle: super TVS_HASLINES or TVS_HASBUTTONS or TVS_DISABLEDRAGDROP or TVS_SHOWSELALWAYS or TVS_LINESATROOT or ;M :m ~: ( -- ) DisposeTheList free-recbuffer ;m :m Close: ( -- ) DisposeTheList free-recbuffer hwndimage ?dup if Call ImageList_Destroy drop then Close: super ;m : FindAllFiles ( -- ) path-ptr >r thespecs to path-ptr 0 to #dirs 0 to #fls \ we get all directories first TreePath count s" *.*" Setup: FileFinder FindFiles: FileFinder begin 0= while IsDirectory?: FileFinder if FullPath: FileFinder AddFile 1 +to #dirs then FindNextFile: FileFinder repeat FindClose: FileFinder \ now we get the rest of the files first-path" begin dup 0> while TreePath count 2swap SetUp: FileFinder FindFiles: FileFinder begin 0= while IsFile?: FileFinder if FullPath: FileFinder AddFile 1 +to #fls then FindNextFile: FileFinder repeat FindClose: FileFinder next-path" repeat 2drop r> to path-ptr ; : recbuffer() ( n -- addr ) recbuffer +cells ; :M SortAscending: ( -- ) ['] 0< to sortorder ;M :M SortDescending: ( -- ) ['] 0> to sortorder ;M \ : null-check ( a1 -- a1 ) \ ?win-error-enabled 0= \ if dup 0= \ if drop ['] noop \ convert null to NOOP \ exit \ and exit \ then \ then \ dup 0= s" Attempt to execute a NULL function" ?TerminateBox \ ; : dosortorder ( n -- f ) sortorder null-check execute ; : compare-recs ( n1 n2 -- f ) GetName$: [ swap ] "to-pathend" GetName$: [ rot ] "to-pathend" caps-compare dosortorder ; : readrecbuffer ( -- ) \ load temporary buffer with record pointers >FirstLink: FolderList total: FolderList max-recs min 0max 0 ?do Data@: FolderList i recbuffer() ! >NextLink: FolderList loop ; : writerecbuffer ( -- ) \ rewrite sorted records to database >FirstLink: FolderList total: FolderList max-recs min 0max 0 ?do i recbuffer() @ Data!: FolderList >NextLink: FolderList loop ; : sortfiles ( -- ) recbuffer 0= ?exit \ if not allocated abort sorting ['] compare-recs is precedes \ set sort comparator total: folderlist 2 < ?exit readrecbuffer \ load buffer #dirs 1 > if 0 recbuffer() #dirs sort \ sort the directories then #fls 1 > if #dirs recbuffer() #fls sort \ and the files then writerecbuffer ; : show-path ( -- ) hwndlabel 0= ?exit hwndlabel Call IsWindow 0= ?exit treepath count asciiz 0 WM_SETTEXT hwndlabel send-window ; :M UpdateFiles: ( -- ) treepath c@ 0= if current-dir$ count setpath: self then TreePath count rootdir? \ if at root can't go up a level if Treepath dup ?+\ +NULL TreePath count else s" .." \ indicates ability to ascend then SetRootName: self Close: self \ clear tree parent Start: self \ and restart _Win32-Find-Data [ 11 cells max-path + 14 + ] LITERAL erase FindAllFiles SortFiles add-items show-path hwndmain ToggleExpandItem: self self On_Update null-check execute \ user function ;M :M ascend: ( -- ) GetPath: self 2dup rootdir? if 2drop exitm then 2dup + swap '\' -scan drop over - SetPath: self Updatefiles: self ;m :m descend: ( --) SelectedItem 0= ?exitm IsDirectory?: SelectedItem not ?exitm GetName$: SelectedItem SetPath: self Updatefiles: self ;m :M On_SelChanged: ( -- f ) \ lparamNew to SelectedItem SelectedItem tree-click null-check execute false ;M :m DeleteFile: ( -- ) Selecteditem 0= ?exitm itemid: SelectedItem 0<> ?exitm \ can't delete folder or root s" Delete " new$ dup>r place getname$: SelectedItem r@ +place s" ?" r@ +place r@ +NULL r> 1+ ( sztext ) z" Are you sure?" ( ztitle ) MB_YESNO ( style ) MessageBox: parent IDNO = ?exitm Getname$: SelectedItem delete-file dup s" Delete file failed" ?MessageBox ?exitm handle: SelectedItem \ save it SelectedItem dup parentitem: [ ] DeleteItem: [ ] ( handle ) \ lparam 0 \ wparam TVM_DELETEITEM \ msg hwnd send-window 0 to SelectedItem UpdateFiles: self ;m :M SelectedItem: ( -- n ) SelectedItem ;M :M #Dirs: ( -- n ) #dirs ;M :M #Files: ( -- n ) #fls ;m :M Showfiles: ( f -- ) to show-files? ;m :M IsOn_Update: ( cfa -- ) to on_update ;m :M IsTree-Click: ( cfa -- ) to tree-click ;m :M FileList: ( -- list ) FolderList ;M ;Class :Class FileWindow <Super Child-Window FolderTree ThisFolder int tree-dblclick int wstyle \ additional window style e.g WS_BORDER :M ClassInit: ( -- ) ClassInit: Super ['] drop to tree-dblclick NextId to ID 0 to wstyle ;M :M On_Init: ( -- ) self Start: ThisFolder Updatefiles: ThisFolder ;m :M WindowStyle: ( -- style ) WindowStyle: super wstyle or ;M \ add in user style :M AddStyle: ( n -- ) to wstyle ;M :M On_Size: ( -- ) autosize: thisfolder ;M :M #Dirs: ( -- n ) #dirs: thisfolder ;M :M #Files: ( -- n ) #files: thisfolder ;m :M Showfiles: ( f -- ) \ allow or disallow display of files in tree showfiles: thisfolder ;m :M IsOn_Update: ( cfa -- ) \ cfa to execute whenever the display is updated ison_update: thisfolder ;m :M IsTree-Click: ( cfa -- ) \ set cfa to be executed when item in tree is clicked istree-click: thisfolder ;m :M IsTree-Dblclick: ( cfa -- ) \ set cfa to be executed when item in tree is double-clicked to tree-dblclick ;M :M TheFolderTree: ( -- obj ) \ direct access to the tree Addr: ThisFolder ;M :M UpdateFiles: ( -- ) \ update the display UpdateFiles: ThisFolder ;M :M SetPath: ( addr cnt -- ) \ set for valid path SetPath: ThisFolder ;M :M GetPath: ( -- addr cnt ) GetPath: ThisFolder ;M :M SetSpecs: ( addr cnt -- ) \ e.g s" *.f;*.seq;*.frm;*.txt" SetSpecs: Thisfolder ;M :M GetSpecs: ( -- addr cnt ) GetSpecs: ThisFolder ;M :M IsLabelhandle: ( hwnd -- ) \ handle of window that will display path name IsLabelHandle: ThisFolder ;M :M SortAscending: ( -- ) SortAscending: ThisFolder ;M :M SortDescending: ( -- ) SortDescending: ThisFolder ;M :M DeleteFile: ( -- ) \ delete selected file after confirmation DeleteFile: ThisFolder ;M :M SelectedItem: ( -- ) \ selected file or directory, itemid = 0 means it is a file SelectedItem: ThisFolder ;M :M Total: ( -- n ) \ sum of files and directories #dirs: self #files: self + ;M :M FileList: ( -- list ) FileList: ThisFolder ;M :M ChooseFolder: ( -- ) \ change folder programatically, also available by right clicking hwnd 0= ?exitm z" Select a drive or folder" \ use a copy of path because if cancelled path info is changed to null GetPath: self pad place pad hwnd BrowseForFolder if pad count SetPath: self UpdateFiles: self then ;M :M Close: ( -- ) Close: ThisFolder Close: Super ;M :M WM_NOTIFY ( h m w l -- f ) dup @ GetHandle: ThisFolder = if dup 2 cells+ @ case \ check for double click NM_DBLCLK of ItemId: [ SelectedItem: ThisFolder ] dup 0= \ is a file? if drop SelectedItem: ThisFolder tree-dblclick null-check execute else -1 = \ .. selection? if ascend: ThisFolder else descend: ThisFolder then then endof \ right click in treeview opens browseforfolder dialog NM_RCLICK of ChooseFolder: self endof endcase Handle_Notify: ThisFo... [truncated message content] |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-13 20:48:45
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10517/src/lib Modified Files: Joystick.f Log Message: Jos: Removed a number of ";" Index: Joystick.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/Joystick.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Joystick.f 10 Jun 2006 11:41:09 -0000 1.3 --- Joystick.f 13 Jun 2006 20:48:39 -0000 1.4 *************** *** 6,31 **** :struct joycapsa ! WORD wMid; /* manufacturer ID */ ! WORD wPid; /* product ID */ MAXPNAMELEN Field: szPname /* product name (NULL terminated string) */ ! UINT wXmin; /* minimum x position value */ ! UINT wXmax; /* maximum x position value */ ! UINT wYmin; /* minimum y position value */ ! UINT wYmax; /* maximum y position value */ ! UINT wZmin; /* minimum z position value */ ! UINT wZmax; /* maximum z position value */ ! UINT wNumButtons; /* number of buttons */ ! UINT wPeriodMin; /* minimum message period when captured */ ! UINT wPeriodMax; /* maximum message period when captured */ ! UINT wRmin; /* minimum r position value */ ! UINT wRmax; /* maximum r position value */ ! UINT wUmin; /* minimum u (5th axis) position value */ ! UINT wUmax; /* maximum u (5th axis) position value */ ! UINT wVmin; /* minimum v (6th axis) position value */ ! UINT wVmax; /* maximum v (6th axis) position value */ ! UINT wCaps; /* joystick capabilites */ ! UINT wMaxAxes; /* maximum number of axes supported */ ! UINT wNumAxes; /* number of axes in use */ ! UINT wMaxButtons; /* maximum number of buttons supported */ maxpnamelen Field: szRegKey /* registry key */ max_joystickoemvxdname Field: szOEMVxD /* OEM VxD in use */ --- 6,31 ---- :struct joycapsa ! WORD wMid /* manufacturer ID */ ! WORD wPid /* product ID */ MAXPNAMELEN Field: szPname /* product name (NULL terminated string) */ ! UINT wXmin /* minimum x position value */ ! UINT wXmax /* maximum x position value */ ! UINT wYmin /* minimum y position value */ ! UINT wYmax /* maximum y position value */ ! UINT wZmin /* minimum z position value */ ! UINT wZmax /* maximum z position value */ ! UINT wNumButtons /* number of buttons */ ! UINT wPeriodMin /* minimum message period when captured */ ! UINT wPeriodMax /* maximum message period when captured */ ! UINT wRmin /* minimum r position value */ ! UINT wRmax /* maximum r position value */ ! UINT wUmin /* minimum u (5th axis) position value */ ! UINT wUmax /* maximum u (5th axis) position value */ ! UINT wVmin /* minimum v (6th axis) position value */ ! UINT wVmax /* maximum v (6th axis) position value */ ! UINT wCaps /* joystick capabilites */ ! UINT wMaxAxes /* maximum number of axes supported */ ! UINT wNumAxes /* number of axes in use */ ! UINT wMaxButtons /* maximum number of buttons supported */ maxpnamelen Field: szRegKey /* registry key */ max_joystickoemvxdname Field: szOEMVxD /* OEM VxD in use */ |
|
From: Rod O. <rod...@us...> - 2006-06-13 19:34:57
|
Update of /cvsroot/win32forth/win32forth/apps/ProMgr In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12076/apps/ProMgr Modified Files: ProjectManager.f Log Message: Rod: Updated to work with TreeView class derived from Control class by adding StartSize: method to TheProject. Used WndClassStyle: method instead of SetClassLong. Index: ProjectManager.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ProMgr/ProjectManager.f,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** ProjectManager.f 13 Jun 2006 19:20:25 -0000 1.14 --- ProjectManager.f 13 Jun 2006 19:34:42 -0000 1.15 *************** *** 1,2 **** --- 1,4 ---- + \ $Id$ + \ ProjectManager.f version 2 *************** *** 5,8 **** --- 7,17 ---- comment: + Tuesday, June 13 2006 - Rod + + Updated to work with TreeView class derived from Control class by adding + StartSize: method to TheProject. Used WndClassStyle: method instead of SetClassLong + wherever possible. Splitter bar object NOT needed when background of main window + is set to COLOR_BTNFACE. + October 07, 2005 - EAB - added class for viewing binary files of any size. *************** *** 428,431 **** --- 437,442 ---- :Object TheProject <super TreeViewControl + :M StartSize: ( w h -- ) width: parent height: parent ;M + File ProjectFile load-bitmap imagelist "treeimages.bmp" *************** *** 867,873 **** :Object LeftPane <Super Child-Window :M On_Init: ( -- ) On_Init: super - CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop WS_CLIPCHILDREN +Style: self ;M --- 878,887 ---- :Object LeftPane <Super Child-Window + :M WndClassStyle: ( -- style ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS ;M + :M On_Init: ( -- ) On_Init: super WS_CLIPCHILDREN +Style: self ;M *************** *** 899,902 **** --- 913,920 ---- HexViewer BinaryBox + :M WndClassStyle: ( -- style ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS ;M + :M ExWindowStyle: ( -- ) WS_EX_CLIENTEDGE ;M *************** *** 1043,1047 **** ;Object ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 1061,1065 ---- ;Object ! (( ****not needed as long as HBRBACKGROUND set to COLOR_BTNFACE in main window**** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 1061,1065 **** ;Object ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 1079,1083 ---- ;Object ! )) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 1101,1105 **** 0 ToolBarHeight LeftWidth LeftHeight Move: LeftPane LeftWidth thickness + ToolBarHeight Width LeftWidth thickness + - LeftHeight Move: RightPane ! LeftWidth ToolBarHeight thickness LeftHeight Move: Splitter AutoSize: TheProject ; --- 1119,1123 ---- 0 ToolBarHeight LeftWidth LeftHeight Move: LeftPane LeftWidth thickness + ToolBarHeight Width LeftWidth thickness + - LeftHeight Move: RightPane ! \ LeftWidth ToolBarHeight thickness LeftHeight Move: Splitter AutoSize: TheProject ; *************** *** 1158,1161 **** --- 1176,1183 ---- ;M + :M WndClassStyle: ( -- style ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS ;M + :M WindowHasMenu: ( -- f ) true ;M *************** *** 1174,1178 **** :M On_Init: ( -- ) - CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop WS_CLIPCHILDREN +Style: self self to TheProjectWindow --- 1196,1199 ---- |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-13 19:20:37
|
Update of /cvsroot/win32forth/win32forth/apps/ProMgr In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5965/apps/ProMgr Modified Files: ProjectManager.f Log Message: Jos: Restored SelectItem: to his orginal version Index: ProjectManager.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ProMgr/ProjectManager.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** ProjectManager.f 11 Jun 2006 07:37:26 -0000 1.13 --- ProjectManager.f 13 Jun 2006 19:20:25 -0000 1.14 *************** *** 731,734 **** --- 731,736 ---- ;M + :M SelectItem: ( hItem -- ) TVGN_CARET TVM_SELECTITEM SendMessage:SelfDrop ;M + :M Delete: ( -- ) SelectedItem 0= if exitm then |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-13 19:15:09
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3424/apps/Win32ForthIDE Modified Files: ProjectTree.f Log Message: Jos: Restored SelectItem: to his orginal version Index: ProjectTree.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ProjectTree.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** ProjectTree.f 11 Jun 2006 18:04:10 -0000 1.8 --- ProjectTree.f 13 Jun 2006 19:14:50 -0000 1.9 *************** *** 489,492 **** --- 489,494 ---- then false ;M + :M SelectItem: ( hItem -- ) TVGN_CARET TVM_SELECTITEM SendMessage:SelfDrop ;M + :M Delete: ( -- ) SelectedItem 0= if exitm then |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-13 18:46:59
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24256/src/lib Modified Files: treeview.f Log Message: Jos: Changed the stack of SelectItem: and GetNextItem: Index: treeview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/treeview.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** treeview.f 12 Jun 2006 16:22:57 -0000 1.7 --- treeview.f 13 Jun 2006 18:46:49 -0000 1.8 *************** *** 268,286 **** 0 TVM_DELETEITEM hWnd SendMessage:SelfDrop ;M ! :M InsertItem: ( -- hItem ) tvins 0 TVM_INSERTITEM SendMessage:Self ;M :M SetImageList: ( himl iImage -- ) TVM_SETIMAGELIST SendMessage:SelfDrop ;M ! :M DeleteItem: ( hItem -- f ) 0 TVM_DELETEITEM SendMessage:Self ;M ! :M SetItem: ( -- ) tvitem 0 TVM_SETITEM SendMessage:SelfDrop ;M ! :M Expand: ( hItem f -- ) TVM_EXPAND SendMessage:SelfDrop ;M \ :M ToggleExpandItem: ( hItem -- ) TVE_TOGGLE Expand: self ;M ! :M CollapseReset: ( hItem -- ) TVE_COLLAPSERESET TVE_COLLAPSE or Expand: self ;M ! :M GetItemRect: ( hItem -- f ) ItemRect ! ItemRect true TVM_GETITEMRECT SendMessage:Self ;M ! :M SelectItem: ( hItem -- ) TVGN_CARET TVM_SELECTITEM SendMessage:SelfDrop ;M ! :M GetNextItem: ( hItem -- h ) TVM_GETNEXTITEM SendMessage:Self ;M ! :M GetRoot: ( -- hItem ) 0 TVGN_ROOT GetNextItem: self ;M ! :M GetChild: ( hItem -- hItem ) TVGN_CHILD GetNextItem: self ;M ! :M GetParentItem: ( hItem -- hItem ) TVGN_PARENT GetNextItem: self ;M ! :M GetNext: ( hItem -- hItem ) TVGN_NEXT GetNextItem: self ;M ! :M GetPrevious: ( hItem -- hItem ) TVGN_PREVIOUS GetNextItem: self ;M int maxwidth --- 268,286 ---- 0 TVM_DELETEITEM hWnd SendMessage:SelfDrop ;M ! :M InsertItem: ( -- hItem ) tvins 0 TVM_INSERTITEM SendMessage:Self ;M :M SetImageList: ( himl iImage -- ) TVM_SETIMAGELIST SendMessage:SelfDrop ;M ! :M DeleteItem: ( hItem -- f ) 0 TVM_DELETEITEM SendMessage:Self ;M ! :M SetItem: ( -- ) tvitem 0 TVM_SETITEM SendMessage:SelfDrop ;M ! :M Expand: ( hItem f -- ) TVM_EXPAND SendMessage:SelfDrop ;M \ :M ToggleExpandItem: ( hItem -- ) TVE_TOGGLE Expand: self ;M ! :M CollapseReset: ( hItem -- ) TVE_COLLAPSERESET TVE_COLLAPSE or Expand: self ;M ! :M GetItemRect: ( hItem -- f ) ItemRect ! ItemRect true TVM_GETITEMRECT SendMessage:Self ;M ! :M SelectItem: ( flag hItem -- ) TVM_SELECTITEM SendMessage:SelfDrop ;M ! :M GetNextItem: ( flag hItem -- h ) TVM_GETNEXTITEM SendMessage:Self ;M ! :M GetRoot: ( -- hItem ) 0 TVGN_ROOT GetNextItem: self ;M ! :M GetChild: ( hItem -- hItem ) TVGN_CHILD GetNextItem: self ;M ! :M GetParentItem: ( hItem -- hItem ) TVGN_PARENT GetNextItem: self ;M ! :M GetNext: ( hItem -- hItem ) TVGN_NEXT GetNextItem: self ;M ! :M GetPrevious: ( hItem -- hItem ) TVGN_PREVIOUS GetNextItem: self ;M int maxwidth |
|
From: Dirk B. <db...@us...> - 2006-06-12 16:23:04
|
Update of /cvsroot/win32forth/win32forth/apps/ForthForm In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32232/apps/ForthForm Modified Files: FileLister.f Log Message: - Changed the TreeViewControl back into a child-window. As a quick bugfix for problems with the FileLister class. Index: FileLister.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FileLister.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** FileLister.f 11 Jun 2006 07:37:26 -0000 1.4 --- FileLister.f 12 Jun 2006 16:22:56 -0000 1.5 *************** *** 554,566 **** ['] 0> to sortorder ;M ! : null-check ( a1 -- a1 ) ! ?win-error-enabled 0= ! if dup 0= ! if drop ['] noop \ convert null to NOOP ! exit \ and exit ! then ! then ! dup 0= s" Attempt to execute a NULL function" ?TerminateBox ! ; : dosortorder ( n -- f ) --- 554,566 ---- ['] 0> to sortorder ;M ! \ : null-check ( a1 -- a1 ) ! \ ?win-error-enabled 0= ! \ if dup 0= ! \ if drop ['] noop \ convert null to NOOP ! \ exit \ and exit ! \ then ! \ then ! \ dup 0= s" Attempt to execute a NULL function" ?TerminateBox ! \ ; : dosortorder ( n -- f ) |
|
From: Dirk B. <db...@us...> - 2006-06-12 16:23:01
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32232/src/lib Modified Files: treeview.f Log Message: - Changed the TreeViewControl back into a child-window. As a quick bugfix for problems with the FileLister class. Index: treeview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/treeview.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** treeview.f 11 Jun 2006 07:37:27 -0000 1.6 --- treeview.f 12 Jun 2006 16:22:57 -0000 1.7 *************** *** 86,90 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! :Class TreeViewControl <super control Record: nmhdr --- 86,93 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ :Class TreeViewControl <super control ! \ converted back into a child window as a quick an dirty fix for the ! \ FileLister class (Montag, Juni 12 2006 - dbu) ! :Class TreeViewControl <super child-window Record: nmhdr *************** *** 180,184 **** \ -------------------- Create Tree-View Control -------------------- - create treeview-class z," SysTreeView32" \ Pre-registered class --- 183,186 ---- *************** *** 187,198 **** ;M :M Start: ( Parent -- ) hWnd ! if drop ! SW_SHOWNOACTIVATE Show: self ! else to Parent ! Call InitCommonControls drop ! treeview-class Create-Control ! then ;M :M Handle_Notify: ( h m w l -- f ) --- 189,231 ---- ;M + \ :M Start: ( Parent -- ) + \ hWnd + \ if drop + \ SW_SHOWNOACTIVATE Show: self + \ else to Parent + \ Call InitCommonControls drop + \ treeview-class Create-Control + \ then ;M + + : create-treeview ( -- hWnd ) + \ Make sure Common Controls are loaded + Call InitCommonControls drop + + NULL \ Creation parameter + appInst \ Instance handle + id \ Child id + Parent conhndl = + if conhndl + else GetHandle: Parent \ parent window handle + then + tempRect.AddrOf GetClientRect: Parent + Bottom: tempRect Right: tempRect \ Size h,w + 0 0 \ Position y,x + WindowStyle: [ self ] \ Style + NULL \ Window name + treeview-class \ Pre-registered class + 0 \ Extended style + Call CreateWindowEx + ; + :M Start: ( Parent -- ) hWnd ! if drop ! SW_SHOWNOACTIVATE Show: self ! else ! to Parent ! create-treeview to hWnd ! then ! ;M :M Handle_Notify: ( h m w l -- f ) *************** *** 274,278 **** ;M - \ --------------------- Overridable methods ---------------------- --- 307,310 ---- |
|
From: George H. <geo...@us...> - 2006-06-12 12:25:18
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15839/win32forth/src Modified Files: DBGSRC2.F Log Message: gah: Tidied up search order so added vocabularies are removed. Index: DBGSRC2.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/DBGSRC2.F,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** DBGSRC2.F 17 May 2005 22:25:25 -0000 1.3 --- DBGSRC2.F 12 Jun 2006 12:25:11 -0000 1.4 *************** *** 3,8 **** \ DBGSRC2.F Add Source Level Debugging to Win32Forth by Tom Zimmer - only forth also definitions - INTERNAL --- 3,6 ---- *************** *** 16,21 **** app-size SizeOf!> SrcInfoPtr \ set the new size 1 SrcInfoPtr ! \ mark as not loadable initiallly - \ cr ." Loading Source Information File: " - \ SrcInfoName count type SrcInfoName count r/w open-file dup if 2drop --- 14,17 ---- *************** *** 44,52 **** : SaveInfo ( -<name>- ) \ save the debugger information to disk - \ cr ." Saving Source Pointer Information for: " SrcInfoCnt . - \ ." locations." - \ cr ." To: " /parse-word count SrcInfoName place - \ SrcInfoName count type SrcInfoName count r/w create-file abort" Failed to create Info File" >r --- 40,44 ---- *************** *** 59,62 **** --- 51,56 ---- : buf-emit ( c1 -- ) ed-dbgline c+place ; + also bug + : _word-watch { ip@ -- } \ ip@ is address we want shown in source with-source? \ if we want to show source *************** *** 80,84 **** defer@ emit >r ['] buf-emit is emit ed-dbgline off - [ also bug also hidden ] .smax @ >r 3 .smax ! \ limit stack display to 3 items debug-.s \ display stack --- 74,77 ---- *************** *** 97,101 **** ip@ @ execute? if ." [ " stack-top .name ." ]" ! [ previous ] then r> is emit r> is type --- 90,94 ---- ip@ @ execute? if ." [ " stack-top .name ." ]" ! then r> is emit r> is type *************** *** 124,128 **** defer@ emit >r ['] rst-emit is emit ed-return off - [ also bug also hidden ] return-top \ if returnstack is set if return-top 1 cells + --- 117,120 ---- *************** *** 130,134 **** #dbg-rstack return-top to prev-return ! [ previous ] then r> is emit r> is type --- 122,126 ---- #dbg-rstack return-top to prev-return ! then r> is emit r> is type *************** *** 136,141 **** 0 ED_STACK editor-message ; ' _stack-watch is stack-watch MODULE - --- 128,134 ---- 0 ED_STACK editor-message ; + previous + ' _stack-watch is stack-watch MODULE |
|
From: Rod O. <rod...@us...> - 2006-06-11 20:51:31
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv11794/apps/Win32ForthIDE Modified Files: Main.f Log Message: Rod: updated Activate: method to stop scroll bar flicker Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** Main.f 11 Jun 2006 18:04:10 -0000 1.11 --- Main.f 11 Jun 2006 20:51:26 -0000 1.12 *************** *** 482,485 **** --- 482,495 ---- HandleW32FMsg ;M + :M Activate: + GetActive: self drop \ maximised flag + IF false SetRedraw: self THEN + Activate: super + true SetRedraw: self + WS_CLIPCHILDREN -Style: ActiveChild + Paint: ActiveChild + WS_CLIPCHILDREN +Style: ActiveChild + ;M + int FileNotFound 2 CallBack: FindFile { hChild lparam -- f } |
|
From: Jos v.d.V. <jo...@us...> - 2006-06-11 20:11:43
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24740/src Modified Files: Class.f Log Message: Jos: Jacques Bertrand fixed a bug in (FINDM) As far I could test it is OK. His test code: :Class Display <super object :M Line: ( x1 y1 x2 y2 -- ) Cr ." display draws line from: " 2swap swap . . ." to: " swap . . ;M ;Class Display TheDirectDisplay :Class Classx <super Object int val :M Show1: ( -- ) 10 20 30 40 Line: TheDirectDisplay ;M :M Show2: { aDisplay -- } 10 20 30 40 Lone: aDisplay ;M :M Show3: ( aDisplay -- ) >r 10 20 30 40 r> Lone: [ ] ;M ;Class Display TheIndirectDisplay Classx TheObj1 : xx1 show1: TheObj1 ; : xx2 TheIndirectDisplay show2: TheObj1 ; : xx3 TheIndirectDisplay show3: TheObj1 ; \s His explanation: I found a little bug in Win32Forth late bound method error messages. It annoyed me for a long time until i find the courage to try to solve it ! It's very annoying since you cannot know which method is faulty when reading the error message see a code example below there is a typing error : Lone: instead of Line: in the method when I run xx2 or xx3, the error code should be : Lone: is not understood by class Display I get instead : Show3: is not understood by class Display I have made a patch to correct it, but not yet thoroughfully tested. yes I know that the trick used to patch (FINDM) is horrible and not ANS compliant but it works fine. Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** Class.f 1 Jun 2006 08:08:18 -0000 1.17 --- Class.f 11 Jun 2006 20:11:38 -0000 1.18 *************** *** 111,121 **** 2dup MFA ((findm)) if nip nip EXIT then ! nip ! S" not understood by class " tempmsg$ +place ! turnkeyed? \ Sonntag, März 13 2005 dbu ! if drop s" [UNKNOWN]" tempmsg$ +place ! else body> >name nfa-count tempmsg$ +place ! then tempmsg$ msg ! -2 throw ; : FIND-METHOD ( SelID ^obj -- ^obj m0cfa ) \ find method in object --- 111,120 ---- 2dup MFA ((findm)) if nip nip EXIT then ! s" --> " tempmsg$ +place swap unhash tempmsg$ +place \ replaces nip S" not understood by class " tempmsg$ +place ! turnkeyed? \ Sonntag, März 13 2005 dbu ! if drop s" [UNKNOWN]" tempmsg$ +place ! else body> >name nfa-count tempmsg$ +place ! then tempmsg$ msg ! -2 throw ; : FIND-METHOD ( SelID ^obj -- ^obj m0cfa ) \ find method in object *************** *** 929,935 **** : msgFind ( addr -- addr false | cfa true ) PARMFIND ?DUP 0= ! IF _MSGFIND ! (dprwarn) \ warn if deprecated selector is found (Sonntag, März 13 2005 dbu) ! THEN ; \ If FIND is used in a TURNKEYed application it must be reset to PARMFIND --- 928,934 ---- : msgFind ( addr -- addr false | cfa true ) PARMFIND ?DUP 0= ! IF _MSGFIND ! (dprwarn) \ warn if deprecated selector is found (Sonntag, März 13 2005 dbu) ! THEN ; \ If FIND is used in a TURNKEYed application it must be reset to PARMFIND |
|
From: Dirk B. <db...@us...> - 2006-06-11 18:04:17
|
Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv31890/apps/Win32ForthIDE Modified Files: CommandID.f EdCommand.f EdMenu.f EdTabControl.f Main.f ProjectTree.f Log Message: Some more work on the IDE. Index: EdTabControl.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdTabControl.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** EdTabControl.f 11 Jun 2006 09:03:45 -0000 1.8 --- EdTabControl.f 11 Jun 2006 18:04:10 -0000 1.9 *************** *** 61,67 **** --- 61,69 ---- \ Find a file in the list view. \ addr is the object address of the mdi child window + cr ." FindFile: " dup h. LVFI_PARAM SetFlags: LvFindInfo SetlParam: LvFindInfo Addr: LvFindInfo -1 FindItem: self + ." returns " dup . ;M *************** *** 88,92 **** \ addr is the object address of the mdi child window addr FindFile: self -1 = ! if LVIF_TEXT LVIF_PARAM or SetMask: LvItem addr SetlParam: LvItem addr FileNameToBuffer SetpszText: LvItem --- 90,96 ---- \ addr is the object address of the mdi child window addr FindFile: self -1 = ! if LVIF_TEXT LVIF_PARAM or ! LVIF_STATE or SetMask: LvItem ! LVIS_SELECTED Setstate: LvItem addr SetlParam: LvItem addr FileNameToBuffer SetpszText: LvItem *************** *** 102,105 **** --- 106,110 ---- Setstate: LvItem -1 SetstateMask: LvItem + false to Enable_Notify? Addr: LvItem swap SetItemState: self drop *************** *** 127,133 **** Enable_Notify? if dup GetNotifyCode LVN_ITEMCHANGED = ! \ if dup GetNotifyCode LVN_ITEMACTIVATE = ! \ if dup GetNotifyCode NM_CLICK = ! if LVN_GetNotifyParam OnSelect else drop then --- 132,141 ---- Enable_Notify? if dup GetNotifyCode LVN_ITEMCHANGED = ! if ! cr ." Handle_Notify: enter" ! false to Enable_Notify? ! LVN_GetNotifyParam OnSelect ! true to Enable_Notify? ! cr ." Handle_Notify: exit" else drop then *************** *** 149,156 **** :M Handle_Notify: ( h m w l -- f ) \ Handle the notification messages of the treeview control. ! dup GetNotifyCode NM_DBLCLK = ! if IDM_EXECUTEFILE_PRJ DoCommand false ! else Handle_Notify: super ! then ;M ;class --- 157,166 ---- :M Handle_Notify: ( h m w l -- f ) \ Handle the notification messages of the treeview control. ! \ dup GetNotifyCode NM_DBLCLK = ! \ if IDM_EXECUTEFILE_PRJ DoCommand false ! \ else Handle_Notify: super ! \ then ;M ! Handle_Notify: super ! ;M ;class *************** *** 321,326 **** UpdateFileName: cFileList ;M - :M ResetProject: ( -- ) - Close: cProjectTree self Start: cProjectTree ;M - ;class --- 331,333 ---- Index: EdMenu.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdMenu.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** EdMenu.f 11 Jun 2006 09:03:45 -0000 1.8 --- EdMenu.f 11 Jun 2006 18:04:10 -0000 1.9 *************** *** 104,107 **** --- 104,109 ---- \ MenuItem "Copy all files..." IDM_COPY_ALL_PRJ DoCommand ; \ EndSubMenu + \ MenuSeparator + 8 RECENTFILES RecentProjectFiles IDM_OPEN_RECENT_FILE_PRJ DoCommand ; Popup "&DexH" Index: ProjectTree.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ProjectTree.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** ProjectTree.f 11 Jun 2006 09:03:45 -0000 1.7 --- ProjectTree.f 11 Jun 2006 18:04:10 -0000 1.8 *************** *** 454,458 **** then ; ! : RegisterList ( -- ) \ register list with this treeview control hwndimage ?dup 0= ?exit TVSIL_NORMAL SetImageList: self ; --- 454,458 ---- then ; ! : RegisterList ( -- ) \ register imagelist with this treeview control hwndimage ?dup 0= ?exit TVSIL_NORMAL SetImageList: self ; *************** *** 481,502 **** :M On_SelChanged: ( -- f ) lparamNew to SelectedItem - itemid: SelectedItem - if - s" Number of files = " pad place - #items: SelectedItem (.) pad +place - pad dup +NULL 1+ - FileExt off - else - GetName: SelectedItem dup zcount - 2dup ".ext-only" 2dup lower FileExt place \ set FileExt ! GetName: SelectedItem zcount pad place ! pad dup IDM_OPEN_RECENT_FILE DoCommand ! ! then ! drop ( for now ) \ 0 Settext: TheStatusBar .buildfile ! SetFocus: self \ ProjectManager.htm item lost focus before ! false ! ;M :M Delete: ( -- ) --- 481,491 ---- :M On_SelChanged: ( -- f ) lparamNew to SelectedItem ! itemid: SelectedItem ! if ReleaseBuffer: viewerfile ! FileExt off ! else GetName: SelectedItem zcount pad place ! pad IDM_OPEN_RECENT_FILE DoCommand ! then false ;M :M Delete: ( -- ) *************** *** 531,535 **** :M SetProjectFileName: ( addr cnt -- ) ! SetName: ProjectFile ;M :M GetProjectFileName: ( -- addr cnt ) --- 520,526 ---- :M SetProjectFileName: ( addr cnt -- ) ! 2dup SetName: ProjectFile ! pad place pad Insert: RecentProjectFiles ! ;M :M GetProjectFileName: ( -- addr cnt ) *************** *** 601,605 **** else true abort" Build file name not found!" then bl get-word s" SearchPath=" caps-compare 0= ! if bl word count path-ptr place else true abort" Search path not found!" then \ now we read in files --- 592,596 ---- else true abort" Build file name not found!" then bl get-word s" SearchPath=" caps-compare 0= ! if bl word drop \ count path-ptr place TODO TODO TODO else true abort" Search path not found!" then \ now we read in files *************** *** 684,689 **** : (open-project) ( a1 n1 -- ) \ clear-status-bar ! \ GetProjectFileName: TheProject ?dup ! \ IF pad place pad Insert: RecentFiles ELSE drop THEN 2dup SetProjectFileName: TheProject "path-only" 2dup SetDir: OpenProjectDialog --- 675,679 ---- : (open-project) ( a1 n1 -- ) \ clear-status-bar ! wait-cursor 2dup SetProjectFileName: TheProject "path-only" 2dup SetDir: OpenProjectDialog *************** *** 698,701 **** --- 688,692 ---- reset-results ReleaseBuffer: viewerfile + arrow-cursor \ IDM_SHOW_FILE_PRJ DoCommand ; *************** *** 748,755 **** SaveIfModified 0= ?exit OpenProjectFile count ?dup ! if (open-project) else drop then ; IDM_OPEN_PRJ SetCommand : save-project ( -- ) \ Save the project --- 739,752 ---- SaveIfModified 0= ?exit OpenProjectFile count ?dup ! if WINPAUSE (open-project) else drop then ; IDM_OPEN_PRJ SetCommand + : OpenRecentProjectFile ( File$ -- ) + SaveIfModified + IF count (open-project) + ELSE drop + THEN ; IDM_OPEN_RECENT_FILE_PRJ SetCommand + : save-project ( -- ) \ Save the project Index: EdCommand.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdCommand.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** EdCommand.f 11 Jun 2006 09:03:45 -0000 1.4 --- EdCommand.f 11 Jun 2006 18:04:10 -0000 1.5 *************** *** 98,106 **** else (OpenBinaryFile) then ! else 2dup IsHtmlFile? ! if (OpenHtmlFile) ! else (OpenSourceFile) ! then ! then ; IDM_OPEN_RECENT_FILE SetCommand : OpenHighlightedFile ( -- ) --- 98,108 ---- else (OpenBinaryFile) then ! else 2dup IsHtmlFile? ! if (OpenHtmlFile) ! else (OpenSourceFile) ! then ! then ! ActiveChild if SetFocus: ActiveChild then ! ; IDM_OPEN_RECENT_FILE SetCommand : OpenHighlightedFile ( -- ) Index: Main.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** Main.f 11 Jun 2006 09:03:45 -0000 1.10 --- Main.f 11 Jun 2006 18:04:10 -0000 1.11 *************** *** 304,325 **** then ; ! : 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 --- 304,337 ---- then ; ! : (SaveRecentFiles) { addr len menu -- } ! addr len s" File1" 9 1 DO 2dup + 1- i 48 + swap c! ! 4dup i GetRecentFile: menu count 2rot 2rot 2swap RegSetString LOOP 4drop ; ! : (RestoreRecentFiles) { addr len menu -- } ! 8 SetNumber: menu ! addr len 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: menu ELSE 2drop THEN LOOP 4drop ; + : SaveRecentFiles ( -- ) + s" Recent Files" RecentFiles (SaveRecentFiles) ; + + : RestoreRecentFiles ( -- ) + s" Recent Files" RecentFiles (RestoreRecentFiles) ; + + : SaveRecentProjectFiles ( -- ) + s" Recent Project Files" RecentProjectFiles (SaveRecentFiles) ; + + : RestoreRecentProjectFiles ( -- ) + s" Recent Project Files" RecentProjectFiles (RestoreRecentFiles) ; + : save-defaults ( -- ) base @ >r decimal \ MUST be in decimal when saving defaults *************** *** 358,361 **** --- 370,374 ---- SaveRecentFiles + SaveRecentProjectFiles SetRegistryKey: ControlToolBar *************** *** 396,399 **** --- 409,413 ---- RestoreRecentFiles + RestoreRecentProjectFiles SetRegistryKey: ControlToolBar *************** *** 512,521 **** ;M :M Start: ( parent -- ) Start: super self start: ChildWindow 0 0 Width Height Move: ChildWindow self AddFile: cTabWindow \ add the file to the file list ! SetFocus: ChildWindow ;M --- 526,539 ---- ;M + 0 value Starting? :M Start: ( parent -- ) + true to Starting? Start: super self start: ChildWindow 0 0 Width Height Move: ChildWindow self AddFile: cTabWindow \ add the file to the file list ! \ SetFocus: ChildWindow ! SetFocus: self ! false to Starting? ;M *************** *** 539,542 **** --- 557,561 ---- UpdateStatusBar: self EnableToolbar + \ self SelectFile: cTabWindow \ select the in the file list ;M *************** *** 554,557 **** --- 573,585 ---- \ ;M + \ :M On_ChildActivate: ( -- ) + \ cr ." On_ChildActivate: entry " self h. + \ Starting? 0= + \ if + \ self SelectFile: cTabWindow \ select the in the file list + \ then + \ cr ." On_ChildActivate: exit " self h. + \ ;M + : ?SaveMessage ( -- n ) \ IDYES, IDNO or IDCANCEL s" Do you want to save " pad place *************** *** 617,621 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Define EDITOR Child Window class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 645,649 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ Define Editor, HexDump and ImageDisplay Child Window classes \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 624,627 **** --- 652,656 ---- fload EdHexViewer.f fload EdImageWindow.f + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Define HTML Child Window class *************** *** 700,704 **** \ used by 'the class and vocabulary browser' and the \ 'Find text in Files' dialog ! ActiveBrowser 0= if NewEditWnd ActiveChild to ActiveBrowser then GetHandle: ActiveBrowser Activate: Frame ; is NewBrowseChild --- 729,733 ---- \ used by 'the class and vocabulary browser' and the \ 'Find text in Files' dialog ! ActiveBrowser 0= if NewEditWnd ActiveChild to ActiveBrowser then GetHandle: ActiveBrowser Activate: Frame ; is NewBrowseChild Index: CommandID.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/CommandID.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** CommandID.f 11 Jun 2006 09:03:45 -0000 1.3 --- CommandID.f 11 Jun 2006 18:04:10 -0000 1.4 *************** *** 130,133 **** --- 130,134 ---- NewID IDM_DELETE_PRJ NewID IDM_ADD_FORMS_PRJ + NewID IDM_OPEN_RECENT_FILE_PRJ IdCounter constant IDM_LAST |
|
From: Rod O. <rod...@us...> - 2006-06-11 09:53:54
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14433/demos Modified Files: ListViewDemo.f Log Message: Rod: tidied up Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** ListViewDemo.f 23 May 2006 19:49:26 -0000 1.13 --- ListViewDemo.f 11 Jun 2006 09:53:44 -0000 1.14 *************** *** 1,2 **** --- 1,4 ---- + \ $Id$ + \ Splitter window modified to prevent flicker - May 4th, 2006 Rod \ ForthForm generated splitter-window template *************** *** 13,19 **** 20 constant FontHeight - defer OnPosition ( window -- ) ' drop is OnPosition \ called when window panes are repositioned - defer OnInit ( window -- ) ' drop is OnInit \ called during window On_init method - \ ------------------------------------------------------------------------ \ Define the Listview for the left part of the window. --- 15,18 ---- *************** *** 26,33 **** ;M - :M WndClassStyle: ( -- style ) - \ CS_DBLCLKS only to prevent flicker in window on sizing. - CS_DBLCLKS ;M - ;object --- 25,28 ---- *************** *** 42,49 **** ;M - :M WndClassStyle: ( -- style ) - \ CS_DBLCLKS only to prevent flicker in window on sizing. - CS_DBLCLKS ;M - ;object --- 37,40 ---- *************** *** 118,127 **** :M On_Size: ( -- ) ! gethandle: ListViewLeft ! if 1 ( repaint flag ) ! tempRect.AddrOf GetClientRect: Self ! Bottom: tempRect Right: tempRect 0 0 ! gethandle: ListViewLeft Call MoveWindow drop ! then ;M : 0GetParmsItem ( nItem - Z$text Lparm flNew ) --- 109,114 ---- :M On_Size: ( -- ) ! 0 0 width height Move: ListViewLeft ! ;M : 0GetParmsItem ( nItem - Z$text Lparm flNew ) *************** *** 159,164 **** ;M ! :M Start: ( parent -- ) ! start: super -1 to SelectedItemLeft Self start: ListViewLeft --- 146,150 ---- ;M ! :M On_Init: ( -- ) -1 to SelectedItemLeft Self start: ListViewLeft *************** *** 180,192 **** :M On_Size: ( -- ) ! gethandle: ListViewRightBottom ! if 1 ( repaint flag ) ! tempRect.AddrOf GetClientRect: Self ! Bottom: tempRect Right: tempRect 0 0 ! gethandle: ListViewRightBottom Call MoveWindow drop ! then ;M ! :M Start: ( Parent -- ) ! start: super Self start: ListViewRightBottom ;M --- 166,173 ---- :M On_Size: ( -- ) ! 0 0 width height Move: ListViewRightBottom ! ;M ! :M On_Init: ( -- ) Self start: ListViewRightBottom ;M *************** *** 194,205 **** ;Object - \ ------------------------------------------------------------------------ - \ Define the menubar for the main window. - \ ------------------------------------------------------------------------ - MENUBAR TestBar - POPUP "&File" - MENUITEM "Bye" bye ; - ENDBAR - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 175,178 ---- *************** *** 249,254 **** LeftWidth thickness + ToolBarHeight Width LeftWidth thickness + - RightTopHeight Move: RightTopPane LeftWidth thickness + ToolBarHeight RightTopHeight + Width LeftWidth thickness + - RightBottomHeight Move: RightBottomPane ! LeftWidth ToolBarHeight thickness LeftHeight Move: Splitter ! self OnPosition ; : InSplitter? ( -- f1 ) \ is cursor on splitter window --- 222,226 ---- LeftWidth thickness + ToolBarHeight Width LeftWidth thickness + - RightTopHeight Move: RightTopPane LeftWidth thickness + ToolBarHeight RightTopHeight + Width LeftWidth thickness + - RightBottomHeight Move: RightBottomPane ! LeftWidth ToolBarHeight thickness LeftHeight Move: Splitter ; : InSplitter? ( -- f1 ) \ is cursor on splitter window *************** *** 297,301 **** :M Classinit: ( -- ) ClassInit: super \ init super class - TestBar to CurrentMenu ['] On_clicked SetClickFunc: self ['] On_unclicked SetUnClickFunc: self --- 269,272 ---- *************** *** 327,331 **** self Start: RightBottomPane self Start: Splitter - self OnInit \ perform user function ;M --- 298,301 ---- |
|
From: Rod O. <rod...@us...> - 2006-06-11 09:26:40
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3624/src/lib Modified Files: Listview.f Log Message: Rod: updated to use SendMessage:Self, removed incorrect window message processing Index: Listview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/Listview.f,v retrieving revision 1.10 retrieving revision 1.11 diff -C2 -d -r1.10 -r1.11 *** Listview.f 5 Jun 2006 12:08:07 -0000 1.10 --- Listview.f 11 Jun 2006 09:26:31 -0000 1.11 *************** *** 1,7 **** \ ListView.f ListView control by Prad anew -ListView.f ! cr .( Loading ListView control...) internal --- 1,9 ---- + \ $Id$ + \ ListView.f ListView control by Prad anew -ListView.f ! cr .( Loading ListView Class...) internal *************** *** 290,297 **** --- 292,301 ---- :Class ListView <Super Control + Comment: int nmhdr // NMHDR nmhdr int nmlv // NM_LISTVIEW nmlv int lvdi // LV_DISPINFO lvdi int lvkd // LV_KEYDOWN lvkd + Comment; :M Start: ( Parent -- ) *************** *** 300,442 **** ;M - :M WindowStyle: ( -- style ) \ return the window style - WindowStyle: super - WS_BORDER or - ;M - ( -------------------------------------------------------------------) ( Items and SubItems ) ! :M DeleteAllItems: ( -- f ) 0 0 LVM_DELETEALLITEMS hWnd Call SendMessage ;M ! :M DeleteItem: ( iitem -- f ) 0 swap LVM_DELETEITEM hWnd Call SendMessage ;M ! :M GetItem: ( ptem -- f ) 0 LVM_GETITEM hWnd Call SendMessage ;M ! :M GetItemCount: ( -- n ) 0 0 LVM_GETITEMCOUNT hWnd Call SendMessage ;M ! :M GetItemSpacing: ( fsmall -- f ) 0 swap LVM_GETITEMSPACING hWnd Call SendMessage ;M ! :M GetItemState: ( mask i -- f ) LVM_GETITEMSTATE hWnd Call SendMessage ;M :M GetItemText: ( pitem iItem -- adr count ) >r dup r> ! LVM_GETITEMTEXT hWnd Call SendMessage swap 5 cells+ @ swap ;M ! :M GetSelectedCount: ( -- n ) 0 0 LVM_GETSELECTEDCOUNT hWnd Call SendMessage ;M ! :M InsertItem: ( pitem -- index | -1 ) 0 LVM_INSERTITEM hWnd Call SendMessage ;M ! :M SetItem: ( pitem -- index | -1 ) 0 LVM_SETITEM hWnd Call SendMessage ;M ! :M SetItemCount: ( cItems -- ) 0 swap LVM_SETITEMCOUNT hWnd Call SendMessage ;M ! :M SetItemState: ( pitem i -- f ) LVM_SETITEMSTATE hWnd Call SendMessage ;M ! :M SetItemText: ( pitem i -- f ) LVM_SETITEMTEXT hWnd Call SendMessage ;M :M SetExtendedStyle: ( fl lvs_ex_style - ) LVM_SETEXTENDEDLISTVIEWSTYLE ! hWnd Call SendMessage drop ;M ( -------------------------------------------------------------------) ( Callback Items ) ! :M GetCallBackMask: ( -- mask ) 0 0 LVM_GETCALLBACKMASK hWnd Call SendMessage ;M ! :M ReDrawItems: ( iLast iFirst -- f ) LVM_REDRAWITEMS hWnd Call SendMessage ;M ! :M SetCallBackMask: ( mask -- f ) 0 swap LVM_SETCALLBACKMASK hWnd Call SendMessage ;M ! :M Update: ( iItem -- f ) 0 swap LVM_UPDATE hWnd Call SendMessage ;M ( -------------------------------------------------------------------) ( Columns ) ! :M DeleteColumn: ( icol -- f ) 0 swap LVM_DELETECOLUMN hWnd Call SendMessage ;M ! :M GetColumn: ( pcol icol -- f ) LVM_GETCOLUMN hWnd Call SendMessage ;M ! :M GetColumnWidth: ( icol -- width|0 ) 0 swap LVM_GETCOLUMNWIDTH hWnd Call SendMessage ;M ! :M GetStringWidth: ( psz -- width|0 ) 0 LVM_GETSTRINGWIDTH hWnd Call SendMessage ;M ! :M InsertColumn: ( pcol icol -- index|-1 ) LVM_INSERTCOLUMN hWnd Call SendMessage ;M ! :M SetColumn: ( pcol icol -- f ) LVM_SETCOLUMN hWnd Call SendMessage ;M ! :M SetColumnWidth: ( cx icol -- ) LVM_SETCOLUMNWIDTH hWnd Call SendMessage drop ;M ( -------------------------------------------------------------------) ( Arranging, Sorting and Finding ) ! :M Arrange: ( code -- f ) 0 swap LVM_ARRANGE hWnd Call SendMessage ;M ! :M FindItem: ( plvfi iStart -- index|-1 ) LVM_FINDITEM hWnd Call SendMessage ;M ! :M GetNextItem: ( flags iStart -- index|-1 ) LVM_GETNEXTITEM hWnd Call SendMessage ;M ! :M SortItems: ( pfnCompare lParamsort -- f ) LVM_SORTITEMS hWnd Call SendMessage ;M ( -------------------------------------------------------------------) ( Items Positions and Scrolling ) ! :M EnsureVisible: ( fPartialOK i -- f ) LVM_ENSUREVISIBLE hWnd Call SendMessage ;M ! :M GetCountPerPage: ( -- n ) 0 0 LVM_GETCOUNTPERPAGE hWnd Call SendMessage ;M ! :M GetItemPosition: ( ppt i -- f ) LVM_GETITEMPOSITION hWnd Call SendMessage ;M ! :M GetItemRect: ( prc i -- f ) LVM_GETITEMRECT hWnd Call SendMessage ;M ! :M GetOrigin: ( lpptOrg -- f ) 0 LVM_GETORIGIN hWnd Call SendMessage ;M ! :M GetTopIndex: ( -- index|0 ) 0 0 LVM_GETTOPINDEX hWnd Call SendMessage ;M ! :M GetViewRect: ( prc -- f ) 0 LVM_GETVIEWRECT hWnd Call SendMessage ;M ! :M HitTest: ( pinfo -- index|-1 ) 0 LVM_HITTEST hWnd Call SendMessage ;M ! :M Scroll: ( dy dx -- f ) LVM_SCROLL hWnd Call SendMessage ;M ! :M SetItemPosition: ( x y i -- f ) >r word-join r> LVM_SETITEMPOSITION hWnd Call SendMessage ;M ! :M SetItemPosition32: ( lpptNewPos iItem -- f ) LVM_SETITEMPOSITION32 hWnd Call SendMessage ;M ( -------------------------------------------------------------------) ( Colours ) ! :M GetBkColor: ( -- col ) 0 0 LVM_GETBKCOLOR hWnd Call SendMessage ;M ! :M GetTextBkColor: ( -- col ) 0 0 LVM_GETTEXTBKCOLOR hWnd Call SendMessage ;M ! :M GetTextColor: ( -- col ) 0 0 LVM_GETTEXTCOLOR hWnd Call SendMessage ;M ! :M SetBkColor: ( clrBk -- f ) 0 LVM_SETBKCOLOR hWnd Call SendMessage ;M ! :M SetTextBkColor: ( clrText -- f ) 0 LVM_SETTEXTBKCOLOR hWnd Call SendMessage ;M ! :M SetTextColor: ( clrText -- f ) 0 LVM_SETTEXTCOLOR hWnd Call SendMessage ;M ( -------------------------------------------------------------------) ( Miscellaneous ) ! :M CreateDragImage: ( lpptUpLeft iItem -- hndl|NULL ) LVM_CREATEDRAGIMAGE hWnd Call SendMessage ;M ! :M EditLabel: ( iItem -- hndl|NULL ) 0 swap LVM_EDITLABEL hWnd Call SendMessage ;M ! :M GetEditControl: ( -- ) 0 0 LVM_GETEDITCONTROL hWnd Call SendMessage ;M ! :M GetImageList: ( iImageList -- hndl|NULL ) 0 swap LVM_GETIMAGELIST hWnd Call SendMessage ;M ! :M SetImageList: ( himl iImageList -- hndl|NULL ) LVM_SETIMAGELIST hWnd Call SendMessage ;M ( -------------------------------------------------------------------) ( -Window Message Processing performed by a list contol- ) ! :M WM_CHAR: ( -- ) ;M ! :M WM_COMMAND: ( -- ) ;M ! :M WM_CREATE: ( -- ) ;M ! :M WM_DESTROY: ( -- ) ;M ! :M WM_ERASEBKGND: ( -- ) ;M ! :M WM_GETDLGCODE: ( -- ) ;M ! :M WM_GETFONT: ( -- ) ;M ! :M WM_HSCROLL: ( -- ) ;M ! :M WM_KEYDOWN: ( -- ) ;M ! :M WM_KILLFOCUS: ( -- ) ;M ! :M WM_LBUTTONDBLCLK: ( -- ) ;M ! :M WM_LBUTTONDOWN: ( -- ) ;M ! :M WM_NCCREATE: ( -- ) ;M ! ! :M WM_NOTIFY: ( h m w l -- ) ! dup @ to nmhdr ! Getcode: nmhdr ! ! ( A list view control sends notification ! ( messages to its owner window when events occur in the control. ) ! ! case ! LVN_BEGINDRAG OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_BEGINLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO ! LVN_BEGINRDRAG OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_COLUMNCLICK OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_DELETEALLITEMS OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_DELETEITEM OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_ENDLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO ! LVN_GETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO ! LVN_INSERTITEM OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_ITEMCHANGED OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_ITEMCHANGING OF @ to nmlv ENDOF // NM_LISTVIEW ! LVN_KEYDOWN OF @ to lvkd ENDOF // LV_KEYDOWN ! LVN_SETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO ! endcase ! ;M ! :M WM_NCCREATE: ( -- ) ;M ! :M WM_NCDESTROY: ( -- ) ;M ! :M WM_PAINT: ( -- ) ;M ! :M WM_RBUTTONDOWN: ( -- ) ;M ! :M WM_SETFOCUS: ( -- ) ;M ! :M WM_SETFONT: ( -- ) ;M ! :M WM_SETREDRAW: ( -- ) ;M ! :M WM_TIMER: ( -- ) ;M ! :M WM_VSCROLL: ( -- ) ;M ! :M WM_WINDOWPOSCHANGED: ( -- ) ;M ! :M WM_WININICHANGE: ( -- ) ;M ;Class --- 304,428 ---- ;M ( -------------------------------------------------------------------) ( Items and SubItems ) ! :M DeleteAllItems: ( -- f ) 0 0 LVM_DELETEALLITEMS SendMessage:Self ;M ! :M DeleteItem: ( iitem -- f ) 0 swap LVM_DELETEITEM SendMessage:Self ;M ! :M GetItem: ( ptem -- f ) 0 LVM_GETITEM SendMessage:Self ;M ! :M GetItemCount: ( -- n ) 0 0 LVM_GETITEMCOUNT SendMessage:Self ;M ! :M GetItemSpacing: ( fsmall -- f ) 0 swap LVM_GETITEMSPACING SendMessage:Self ;M ! :M GetItemState: ( mask i -- f ) LVM_GETITEMSTATE SendMessage:Self ;M :M GetItemText: ( pitem iItem -- adr count ) >r dup r> ! LVM_GETITEMTEXT SendMessage:Self swap 5 cells+ @ swap ;M ! :M GetSelectedCount: ( -- n ) 0 0 LVM_GETSELECTEDCOUNT SendMessage:Self ;M ! :M InsertItem: ( pitem -- index | -1 ) 0 LVM_INSERTITEM SendMessage:Self ;M ! :M SetItem: ( pitem -- index | -1 ) 0 LVM_SETITEM SendMessage:Self ;M ! :M SetItemCount: ( cItems -- ) 0 swap LVM_SETITEMCOUNT SendMessage:Self ;M ! :M SetItemState: ( pitem i -- f ) LVM_SETITEMSTATE SendMessage:Self ;M ! :M SetItemText: ( pitem i -- f ) LVM_SETITEMTEXT SendMessage:Self ;M :M SetExtendedStyle: ( fl lvs_ex_style - ) LVM_SETEXTENDEDLISTVIEWSTYLE ! SendMessage:SelfDrop ;M ( -------------------------------------------------------------------) ( Callback Items ) ! :M GetCallBackMask: ( -- mask ) 0 0 LVM_GETCALLBACKMASK SendMessage:Self ;M ! :M ReDrawItems: ( iLast iFirst -- f ) LVM_REDRAWITEMS SendMessage:Self ;M ! :M SetCallBackMask: ( mask -- f ) 0 swap LVM_SETCALLBACKMASK SendMessage:Self ;M ! :M Update: ( iItem -- f ) 0 swap LVM_UPDATE SendMessage:Self ;M ( -------------------------------------------------------------------) ( Columns ) ! :M DeleteColumn: ( icol -- f ) 0 swap LVM_DELETECOLUMN SendMessage:Self ;M ! :M GetColumn: ( pcol icol -- f ) LVM_GETCOLUMN SendMessage:Self ;M ! :M GetColumnWidth: ( icol -- width|0 ) 0 swap LVM_GETCOLUMNWIDTH SendMessage:Self ;M ! :M GetStringWidth: ( psz -- width|0 ) 0 LVM_GETSTRINGWIDTH SendMessage:Self ;M ! :M InsertColumn: ( pcol icol -- index|-1 ) LVM_INSERTCOLUMN SendMessage:Self ;M ! :M SetColumn: ( pcol icol -- f ) LVM_SETCOLUMN SendMessage:Self ;M ! :M SetColumnWidth: ( cx icol -- ) LVM_SETCOLUMNWIDTH SendMessage:SelfDrop ;M ( -------------------------------------------------------------------) ( Arranging, Sorting and Finding ) ! :M Arrange: ( code -- f ) 0 swap LVM_ARRANGE SendMessage:Self ;M ! :M FindItem: ( plvfi iStart -- index|-1 ) LVM_FINDITEM SendMessage:Self ;M ! :M GetNextItem: ( flags iStart -- index|-1 ) LVM_GETNEXTITEM SendMessage:Self ;M ! :M SortItems: ( pfnCompare lParamsort -- f ) LVM_SORTITEMS SendMessage:Self ;M ( -------------------------------------------------------------------) ( Items Positions and Scrolling ) ! :M EnsureVisible: ( fPartialOK i -- f ) LVM_ENSUREVISIBLE SendMessage:Self ;M ! :M GetCountPerPage: ( -- n ) 0 0 LVM_GETCOUNTPERPAGE SendMessage:Self ;M ! :M GetItemPosition: ( ppt i -- f ) LVM_GETITEMPOSITION SendMessage:Self ;M ! :M GetItemRect: ( prc i -- f ) LVM_GETITEMRECT SendMessage:Self ;M ! :M GetOrigin: ( lpptOrg -- f ) 0 LVM_GETORIGIN SendMessage:Self ;M ! :M GetTopIndex: ( -- index|0 ) 0 0 LVM_GETTOPINDEX SendMessage:Self ;M ! :M GetViewRect: ( prc -- f ) 0 LVM_GETVIEWRECT SendMessage:Self ;M ! :M HitTest: ( pinfo -- index|-1 ) 0 LVM_HITTEST SendMessage:Self ;M ! :M Scroll: ( dy dx -- f ) LVM_SCROLL SendMessage:Self ;M ! :M SetItemPosition: ( x y i -- f ) >r word-join r> LVM_SETITEMPOSITION SendMessage:Self ;M ! :M SetItemPosition32: ( lpptNewPos iItem -- f ) LVM_SETITEMPOSITION32 SendMessage:Self ;M ( -------------------------------------------------------------------) ( Colours ) ! :M GetBkColor: ( -- col ) 0 0 LVM_GETBKCOLOR SendMessage:Self ;M ! :M GetTextBkColor: ( -- col ) 0 0 LVM_GETTEXTBKCOLOR SendMessage:Self ;M ! :M GetTextColor: ( -- col ) 0 0 LVM_GETTEXTCOLOR SendMessage:Self ;M ! :M SetBkColor: ( clrBk -- f ) 0 LVM_SETBKCOLOR SendMessage:Self ;M ! :M SetTextBkColor: ( clrText -- f ) 0 LVM_SETTEXTBKCOLOR SendMessage:Self ;M ! :M SetTextColor: ( clrText -- f ) 0 LVM_SETTEXTCOLOR SendMessage:Self ;M ( -------------------------------------------------------------------) ( Miscellaneous ) ! :M CreateDragImage: ( lpptUpLeft iItem -- hndl|NULL ) LVM_CREATEDRAGIMAGE SendMessage:Self ;M ! :M EditLabel: ( iItem -- hndl|NULL ) 0 swap LVM_EDITLABEL SendMessage:Self ;M ! :M GetEditControl: ( -- ) 0 0 LVM_GETEDITCONTROL SendMessage:Self ;M ! :M GetImageList: ( iImageList -- hndl|NULL ) 0 swap LVM_GETIMAGELIST SendMessage:Self ;M ! :M SetImageList: ( himl iImageList -- hndl|NULL ) LVM_SETIMAGELIST SendMessage:Self ;M ( -------------------------------------------------------------------) ( -Window Message Processing performed by a list contol- ) ! Comment: ! The following messages are processed by the window procedure of a ListView control. ! To intercept a message eg WM_CHAR :- ! :M WM_CHAR ( h m w l -- f ) ! ( ****Add your code here**** ) ! old-WndProc CallWindowProc ;M ! Failure to send this message to the old window procedure will stop the control working properly. + WM_CHAR + WM_COMMAND + WM_CREATE + WM_DESTROY + WM_ERASEBKGND + WM_GETDLGCODE + WM_GETFONT + WM_HSCROLL + WM_KEYDOWN + WM_KILLFOCUS + WM_LBUTTONDBLCLK + WM_LBUTTONDOWN + WM_NCCREATE + WM_NOTIFY - processes notification messages from the header control. + A list view control also sends WM_NOTIFY to its + owner window when events occur in the control. + WM_NCCREATE + WM_NCDESTROY + WM_PAINT + WM_RBUTTONDOWN + WM_SETFOCUS + WM_SETFONT + WM_SETREDRAW + WM_TIMER + WM_VSCROLL + WM_WINDOWPOSCHANGED + WM_WININICHANGE ! Comment; ;Class |
1040 messages has been excluded from this view by a project administrator.
