Menu
▾
▴
[Win32forth-cvs] win32forth-stc/demos FILEDUMP.F, NONE, 1.1 ListViewDemo.f, NONE, 1.1 WINDILOG.F, NONE, 1.1
|
From: George H. <geo...@us...> - 2007-05-04 08:09:52
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9931/win32forth-stc/demos Added Files: FILEDUMP.F ListViewDemo.f WINDILOG.F Log Message: gah:Added more demos --- NEW FILE: WINDILOG.F --- \ $Id: WINDILOG.F,v 1.1 2007/05/04 08:09:36 georgeahubert Exp $ \ WINDILOG.F Example of a user created Dialog by Freidrich Prinz \ Modified for Win32Forth by Tom Zimmer Require Controls.f :OBJECT EditSample <SUPER WINDOW ListControl List_1 \ a list box ComboListControl CbList_1 \ a combo list box GroupControl Group_1 \ a frame around a group EditControl Edit_1 \ an edit window StaticControl Text_1 \ a static text window ButtonControl Button_1 \ a button CheckControl Check_1 \ a check box RadioControl Radio_1 \ a radio button RadioControl Radio_2 \ another radio button :M ClassInit: ( -- ) ClassInit: super ;M :M ExWindowStyle: ( -- style ) ExWindowStyle: SUPER ;M :M WindowStyle: ( -- style ) WindowStyle: SUPER WS_BORDER OR WS_OVERLAPPED OR ;M :M WindowTitle: ( -- title ) z" " ;M :M StartSize: ( -- width height ) 300 350 ;M :M StartPos: ( -- x y ) 30 30 ;M :M Close: ( -- ) \ GetText: Edit_1 cr type cr Close: SUPER ;M :M On_Init: ( -- ) self Start: Check_1 4 25 60 20 Move: Check_1 s" Hello" SetText: Check_1 self Start: Radio_1 100 75 130 20 Move: Radio_1 s" Hello Again 1" SetText: Radio_1 WS_GROUP +Style: Radio_1 \ Start a group self Start: Radio_2 100 95 130 20 Move: Radio_2 BS_CENTER +Style: Radio_2 \ and centering s" Hello Again 2" SetText: Radio_2 self Start: Group_1 90 55 140 70 Move: Group_1 s" Radios" SetText: Group_1 self Start: List_1 4 140 100 60 Move: List_1 0 0 LB_RESETCONTENT GetID: List_1 SendDlgItemMessage: self drop z" Ola1 " 0 LB_ADDSTRING GetID: List_1 SendDlgItemMessage: self drop z" Ola2 " 0 LB_ADDSTRING GetID: List_1 SendDlgItemMessage: self drop z" Ola3 " 0 LB_ADDSTRING GetID: List_1 SendDlgItemMessage: self drop self Start: CbList_1 4 220 100 90 Move: CbList_1 0 0 CB_RESETCONTENT GetID: CbList_1 SendDlgItemMessage: self drop z" Ola4 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop z" Ola5 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop z" Ola6 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop z" Ola7 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop z" Ola8 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop z" Ola9 " 0 CB_ADDSTRING GetID: CbList_1 SendDlgItemMessage: self drop 0 0 CB_SETCURSEL GetID: CbList_1 SendDlgItemMessage: self drop self Start: Text_1 \ start up static text WS_GROUP +Style: Text_1 \ End a group SS_CENTER +Style: Text_1 \ and centering WS_BORDER +Style: Text_1 \ and border to style 4 4 192 20 Move: Text_1 \ position the window s" Sample Text" SetText: Text_1 \ set the window message self Start: Edit_1 3 72 60 25 Move: Edit_1 s" 000,00" SetText: Edit_1 IDOK SetID: Button_1 self Start: Button_1 126 172 70 25 Move: Button_1 s" OK" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON +Style: Button_1 ;M :M On_Paint: ( -- ) \ screen redraw procedure 0 0 StartSize: self LTGRAY FillArea: dc ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD ( ID ) case IDOK of Close: self endof GetID: Check_1 of GetID: Check_1 IsDlgButtonChecked: self if beep then endof endcase 0 ;M ;OBJECT : DEMO ( -- ) Start: EditSample ; cr .( Type DEMO to run the dialog demo. ) --- NEW FILE: FILEDUMP.F --- \ FILEDUMP.F An example to use the scroll bar by Jih-tung Pai, 6/23/96 comment: It's a simple example to use the vertical scroll bar. The program is based on WINBROWS.F. It can dump the file in HEX format just like DUMP does to memory. To use it-- 1. type "fload filedump" to load the file 2. type "dump-file" comment; Require WinMsg.f Require xfiledlg.f only forth also definitions hidden also forth FileOpenDialog filedump "Dump File" "All Files|*.*|" :object dump-window <super window int screen-cols int screen-rows Font fdFont int cur-first-line \ current first line position 0 value first-line# \ first line number 200 value last-line# \ last line number last-line# 20 - value last-top-line# create cur-filename max-path allot 16 value bytes/line 0 value file-len \ length of the whole file 0 value file-ptr \ address of the memory for file :m home: ( -- ) first-line# to cur-first-line paint: self ;m : "open-file ( a1 n1 -- ) 2dup r/o open-file 0= if Home: self StartPos: self 200 + swap 200 + swap message-origin s" Reading Text File..." _"message >r 127 min cur-filename place \ release/allocate the text buffer file-ptr ?dup if free drop then r@ file-size 2drop to file-len file-len bytes/line / 1+ bytes/line * dup malloc to file-ptr bytes/line - file-ptr + bytes/line erase \ erase the etra memory \ read the file into memory file-ptr file-len r@ read-file drop to file-len r> close-file drop message-off 0 to cur-first-line file-len bytes/line / 1+ to last-line# cur-filename count settitle: self else drop 2drop then ; : load-file ( -- ) gethandle: self Start: filedump dup c@ if count "open-file else drop abort" No file selected" then ; \ ' load-file is load-file-defer :M On_Init: ( -- ) On_Init: super 8 Width: fdFont 14 Height: fdFont s" Courier" SetFaceName: fdFont Create: fdFont load-file ;M :m on_size: ( w -- ) width char-width / to screen-cols height char-height / to screen-rows last-line# screen-rows - 0max to last-top-line# \ set the vertical scroll limits false last-top-line# first-line# SB_VERT GetHandle: self Call SetScrollRange drop ;m :m startpos: 0 0 ;m :m startsize: 75 char-width * 20 char-height * ;m create line-buf 80 allot : H.N.str ( n1 n2 -- adr len ) \ display n1 a s a hex number of n2 digits BASE @ >R HEX >R 0 <# R> 0 ?DO # LOOP #> R> BASE ! ; : dump-line ( i -- adr len ) bytes/line * dup 6 h.n.str line-buf place spcs 2 line-buf +place file-ptr + dup dup bytes/line + swap ?do i c@ 2 h.n.str line-buf +place spcs 1 line-buf +place loop bytes/line line-buf +place line-buf count ; :m on_paint: ( -- ) SaveDC: dc \ save device context Handle: fdFont SetFont: dc \ set the font to be used screen-rows 0 do 0 char-height i * i cur-first-line + dup last-line# > if drop spcs 80 else dump-line then textout: dc loop RestoreDC: dc ;m :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super WS_VSCROLL or \ add vertical scroll bar ;M :m vposition: ( n -- ) \ move to position n 0max last-top-line# min to cur-first-line paint: self ;m :m vscroll: ( n -- ) \ move n lines up or down cur-first-line + vposition: self ;m :m end: ( -- ) \ move to end, in this case it's 100 bytes down to pad last-top-line# to cur-first-line paint: self ;m :m vpage: ( n -- ) \ down or up n pages screen-rows 1- * vscroll: self ;m :M WM_VSCROLL ( h m w l -- res ) swap word-split >r CASE SB_BOTTOM of End: self endof SB_TOP of Home: self endof SB_LINEDOWN of 1 VScroll: self endof SB_LINEUP of -1 VScroll: self endof SB_PAGEDOWN of 1 VPage: self endof SB_PAGEUP of -1 VPage: self endof SB_THUMBPOSITION of r@ VPosition: self endof SB_THUMBTRACK of r@ VPosition: self endof ENDCASE r>drop \ position the vertical button in the scroll bar TRUE cur-first-line SB_VERT GetHandle: self Call SetScrollPos drop 0 ;M :m on_done: ( -- ) file-ptr ?dup if free drop then Delete: fdFont on_done: super ;m ;object : dump-file ( -- ) start: dump-window ; \ ***** program end ***** --- NEW FILE: ListViewDemo.f --- \ Splitter window modified to prevent flicker - May 4th, 2006 Rod \ ForthForm generated splitter-window template \ Modify according to your needs \ A primarly demo to show some interactions with a ListView Anew -ListViewDemo.f Needs ListView.f Needs ChildWnd.f Needs Menu.f \ Needs NoConsole.f \ Needs Resources.f 0 value turnkey? 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. \ ------------------------------------------------------------------------ :object ListViewLeft <super ListView :M WindowStyle: ( -- style ) WindowStyle: super [ LVS_REPORT LVS_SHOWSELALWAYS OR LVS_SORTASCENDING or LVS_EDITLABELS or ] literal or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M ;object \ ------------------------------------------------------------------------ \ Define the Listview for the lower right part of the window. \ ------------------------------------------------------------------------ :object ListViewRightBottom <super ListView :M WindowStyle: ( -- style ) WindowStyle: super [ LVS_REPORT LVS_SHOWSELALWAYS OR LVS_EDITLABELS or ] literal or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M ;object \ ------------------------------------------------------------------------ \ Define the Window for the upper right part of the window. \ ------------------------------------------------------------------------ :Object RightTopPane <Super Child-Window int lparmLeft String: Out$ Font vFont :M out$: ( - adrOt$ ) out$ ;M :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M :M On_Init: ( -- ) 14 Width: vFont FontHeight Height: vFont s" Courier" SetFaceName: vFont Create: vFont ;M :M On_size: ( -- ) \ need to repaint in this child-window as the position of the \ text depends on its size Paint: self ;M :M On_Paint: ( -- ) SaveDC: dc \ save device context GetSize: Self white Fillarea: dc Out$ c@ 0<> if vFont SelectObject: dc ltblue SetTextColor: dc TA_CENTER SetTextAlign: dc drop GetSize: self 10 - swap 2/ swap 4 / 2dup Out$ zcount pad place s" lParam:" pad +place lparmLeft 0 (D.) pad +place pad +null pad count Textout: dc then RestoreDC: dc ;M :M ShowLeftSelected: ( Z$text Lparm flNew - ) if to lparmLeft drop paint: Self else 2drop then ;M ;Object \ ------------------------------------------------------------------------ \ Define the left part of the splitter window. \ ------------------------------------------------------------------------ :Object LeftPane <Super Child-Window int SelectedItemLeft LV_ITEM LvItem :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M :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 ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem out$: RightTopPane SetpszText: LvItem maxstring SetcchTextMax: LvItem SetiItem: LvItem Addr: LvItem GetItem: ListViewLeft drop out$: RightTopPane GetlParam: LvItem dup SelectedItemLeft <> if dup to SelectedItemLeft true else false then ; : GetParmsItem ( nItem - Z$text Lparm flNew ) >r LVIF_TEXT LVIF_PARAM or SetMask: LvItem out$: RightTopPane SetpszText: LvItem maxstring SetcchTextMax: LvItem r@ SetiItem: LvItem Addr: LvItem GetItem: ListViewLeft drop out$: RightTopPane GetlParam: LvItem r@ SelectedItemLeft <> if r> to SelectedItemLeft true else r>drop false then ; : HandleListViewLeft ( msg - ) LVNI_SELECTED -1 GetNextItem: ListViewLeft dup -1 = if drop else GetParmsItem ShowLeftSelected: RightTopPane then ; :M WM_NOTIFY ( h m w l -- f ) dup @ GetHandle: ListViewLeft = \ EnableNotify? and if HandleListViewLeft then false ;M :M Start: ( parent -- ) start: super -1 to SelectedItemLeft Self start: ListViewLeft ;M ;Object \ ------------------------------------------------------------------------ \ Define the right part of the splitter window. \ ------------------------------------------------------------------------ :Object RightBottomPane <Super Child-Window :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M :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 ;Object \ ------------------------------------------------------------------------ \ Define the menubar for the main window. \ ------------------------------------------------------------------------ MENUBAR TestBar POPUP "&File" MENUITEM "Bye" bye ; ENDBAR \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\ Splitter window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Object Splitter <Super child-window :M WindowStyle: ( -- style ) \ return the window style WindowStyle: super [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M :M On_Paint: ( -- ) \ screen redraw method 0 0 Width Height LTGRAY FillArea: dc ;M ;Object 200 value LeftWidth 2 value thickness 30 value RightTopHeight \ ------------------------------------------------------------------------ \ Define the the splitter window (this is the main window). \ ------------------------------------------------------------------------ :Object SplitterWindow <Super Window 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any int dragging? int mousedown? : LeftHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - ; : RightBottomHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - RightTopHeight - ; : position-windows ( -- ) 0 ToolBarHeight LeftWidth LeftHeight Move: LeftPane 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 hWnd get-mouse-xy 0 height within swap LeftWidth dup thickness + within and ; \ mouse click routines for Main Window to track the Splitter movement : DoSizing ( -- ) mousedown? dragging? or 0= ?EXIT mousex ( 1+ ) width min thickness 2/ - to LeftWidth position-windows WINPAUSE ; : On_clicked ( -- ) mousedown? 0= IF hWnd Call SetCapture drop THEN true to mousedown? InSplitter? to dragging? DoSizing ; : On_unclicked ( -- ) mousedown? IF Call ReleaseCapture drop THEN false to mousedown? false to dragging? ; : On_DblClick ( -- ) false to mousedown? InSplitter? 0= ?EXIT LeftWidth 8 > IF 0 thickness 2/ - to LeftWidth ELSE 132 Width 2/ min to LeftWidth THEN position-windows ; :M WM_SETCURSOR ( h m w l -- ) hWnd get-mouse-xy ToolBarHeight dup LeftHeight + within swap 0 width within and IF InSplitter? IF SIZEWE-CURSOR ELSE arrow-cursor THEN 1 ELSE DefWindowProc: self THEN ;M :M Classinit: ( -- ) ClassInit: super \ init super class TestBar to CurrentMenu ['] On_clicked SetClickFunc: self ['] On_unclicked SetUnClickFunc: self ['] DoSizing SetTrackFunc: self ['] On_DblClick SetDblClickFunc: self ;M :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M WndClassStyle: ( -- style ) \ CS_DBLCLKS only to prevent flicker in window on sizing. CS_DBLCLKS ;M :M StartSize: ( -- w h ) screen-size >r 2/ r> 2/ ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) self Start: LeftPane self Start: RightTopPane self Start: RightBottomPane self Start: Splitter self OnInit \ perform user function ;M :M On_Done: ( h m w l -- res ) Close: self 0 call PostQuitMessage drop On_Done: super 0 ;M LV_COLUMN lvc :M InitListViewColumns: ( -- ) LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc z" Location" SetpszText: lvc Addr: lvc 1 InsertColumn: ListViewLeft drop LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc z" Contact" SetpszText: lvc Addr: lvc 0 InsertColumn: ListViewRightBottom z" Street and number" SetpszText: lvc Addr: lvc swap 1+ InsertColumn: ListViewRightBottom z" Postal code" SetpszText: lvc Addr: lvc swap 1+ InsertColumn: ListViewRightBottom z" Place" SetpszText: lvc Addr: lvc swap 1+ InsertColumn: ListViewRightBottom drop ;M LV_ITEM LvItem :M InitListViewItems: ( -- ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem \ SetMask: Also erases old parameters 0 SetiItem: LvItem 31 SetlParam: LvItem z" Sweden" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 32 SetlParam: LvItem z" Germany" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft LVIF_TEXT SetMask: LvItem 1+ SetiItem: LvItem z" America" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft drop LVIF_TEXT LVIF_PARAM or SetMask: LvItem 0 SetiItem: LvItem 41 SetlParam: LvItem z" Gordon" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 42 SetlParam: LvItem z" Jack" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom LVIF_TEXT SetMask: LvItem \ Inserting a subitem dup>r SetiItem: LvItem \ Uses the index from "Jack" 2 SetiSubItem: LvItem z" 2043 VD" SetpszText: LvItem Addr: LvItem r> SetItemText: ListViewRightBottom LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 43 SetlParam: LvItem z" Vern" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom drop ;M ;Object : main ( -- ) Start: SplitterWindow InitListViewColumns: SplitterWindow InitListViewItems: SplitterWindow true LVS_EX_FULLROWSELECT SetExtendedStyle: ListViewRightBottom ; \ turnkey? if MessageLoop bye then ; turnkey? [if] NoConsoleIO NoConsoleInImage ' main turnkey ListViewDemo.exe s" WIN32FOR.ICO" s" ListViewDemo.exe" AddAppIcon 1 pause-seconds bye [else] main [then] |
