Menu
▾
▴
[Win32forth-cvs] win32forth/demos/MiniDB EditDB.f, NONE, 1.1.4.1 MiniDB.f, NONE, 1.2.2.1 STARTDB.F, NONE, 1.1.4.1
|
From: George H. <geo...@us...> - 2008-08-26 20:54:04
|
Update of /cvsroot/win32forth/win32forth/demos/MiniDB In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32682 Added Files: Tag: V612xx EditDB.f MiniDB.f STARTDB.F Log Message: Added MiniDB demo --- NEW FILE: MiniDB.f --- \ $Id: MiniDB.f,v 1.2.2.1 2008/08/26 20:54:00 georgeahubert Exp $ Anew -MiniDB.f Needs ListView.f Needs Resources.f Require startdb.f Require EditDB.f 0 value turnkey? 20 constant FontHeight : DoEdit ( record# -- ) Start: DBDialog ; : DoAdd ( -- ) 0 Start: DBDialog ; \ ------------------------------------------------------------------------ \ Define the Listview for the database table \ ------------------------------------------------------------------------ :object ListViewDB <super ListView :M WindowStyle: ( -- style ) WindowStyle: super [ LVS_REPORT LVS_SHOWSELALWAYS or LVS_SINGLESEL or ] literal or ;M ;object \ ------------------------------------------------------------------------ \ Define the main window. \ ------------------------------------------------------------------------ :Object SimpleDBWindow <Super Window 0 value ToolBarHeight \ set to height of toolbar if any 0 value StatusBarHeight \ set to height of status bar if any LV_COLUMN lvc LV_ITEM LvItem ButtonControl NewEntry :M WindowHasMenu: ( -- f ) true ;M :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M :M WndClassStyle: ( -- style ) CS_DBLCLKS ;M :M StartSize: ( -- w h ) screen-size >r 2/ r> 2/ ;M :M On_Size: ( -- ) 0 0 width height 20 - Move: ListViewDB 0 height 20 - width 20 Move: NewEntry ;M :M On_Init: ( -- ) self Start: ListviewDB color: white SetBKColor: ListviewDB self Start: NewEntry 0 height 20 - width 20 Move: NewEntry s" New Record" SetText: NewEntry ['] DoAdd SetFunc: NewEntry ;M :M On_Done: ( h m w l -- res ) Close: self turnkey? if 0 call PostQuitMessage drop then On_Done: super 0 ;M : GetLParmItem ( nItem -- Lparm ) LVIF_PARAM SetMask: LvItem SetiItem: LvItem Addr: LvItem GetItem: ListViewDB drop GetlParam: LvItem ; : ItemEdit ( -- ) LVNI_SELECTED -1 GetNextItem: ListViewDB dup -1 = if drop else GetLParmItem DoEdit then ; : HandleListViewDB ( msg - ) 2 cells + @ case NM_DBLCLK of ItemEdit endof endcase ; :M WM_NOTIFY ( h m w l -- f ) dup @ GetHandle: ListViewDB = if HandleListViewDB then false ;M :M InitListViewColumns: ( -- ) LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc fieldcnt: MiniDB ?dup if 1 ?do i fieldname: MiniDB drop SetpszText: lvc Addr: lvc i InsertColumn: ListViewDB drop loop then ;M :M InitListViewItems: ( -- ) -1 begin fieldcnt: MiniDB ?dup if 1 ?do LVIF_TEXT i 1 = if LVIF_PARAM or then SetMask: LvItem i 1 = if 1+ SetiItem: LvItem 0 getint: MiniDB SetlParam: LvItem 1 getstr: MiniDB drop SetpszText: LvItem Addr: LvItem InsertItem: ListViewDB else dup SetiItem: LvItem i 1- SetiSubItem: LvItem i getstr: MiniDB drop SetpszText: LvItem Addr: LvItem over SetItemText: ListViewDB drop then loop then nextrow: MiniDB until drop ;M :M RefreshListViewItems: ( -- ) GetAllCustomers InitListViewItems: self paint: self ;m ;Object \ Patch deferred words :noname ( -- ) Dirty: DBDialog if s" INSERT OR REPLACE INTO Customers (id, name, sirname, abode) VALUES(?,?,?,?)" execute: MiniDB record#: DBDialog -if 0 bindint: MiniDB else 0 0 0 bindstr: MiniDB then BindText: DBDialog DeleteAllItems: ListViewDB GetAllCustomers InitListViewItems: SimpleDBWindow then close: DBDialog ; is Add-modifyDB :noname ( -- ) close: DBDialog ; is RejectDB : main ( -- ) [ turnkey? ] [if] Start-database [then] Start: SimpleDBWindow GetAllCustomers InitListViewColumns: SimpleDBWindow InitListViewItems: SimpleDBWindow true LVS_EX_FULLROWSELECT SetExtendedStyle: ListViewDB [ turnkey? ] [if] MessageLoop bye [then] ; turnkey? [if] ' main turnkey ListViewDemo.exe s" WIN32FOR.ICO" s" ListViewDemo.exe" AddAppIcon 1 pause-seconds bye [else] main [then] --- NEW FILE: EditDB.f --- \ $Id: EditDB.f,v 1.1.4.1 2008/08/26 20:54:00 georgeahubert Exp $ \ Dialog for editing and adding to simple database. G. Hubert Friday, December 07 2007 Require TextBox.f \ Use TextBoxes rather than EditControls for the extra methods. defer Add-ModifyDB \ must be referenced outside of the dialog object defer RejectDB \ must be referenced outside of the dialog object COLOR_BTNFACE call GetSysColor New-Color DialogColor : InitDialogColor ( -- ) COLOR_BTNFACE call GetSysColor InitColor: DialogColor ; initialization-chain chain-add InitDialogColor :Object DBDialog <super DialogWindow int record# StaticControl FirstLabel StaticControl NameLabel StaticControl AbodeLabel TextBox First TextBox Name TextBox Abode ButtonControl Accept ButtonControl Reject :M WindowStyle: ( -- style ) WS_CAPTION WS_POPUPWINDOW or WS_CLIPCHILDREN or ;M :M StartSize: ( -- w h ) 250 160 ;m :m Start: ( record# -- ) to record# Start: Super ;m :m On_Init: ( -- ) record# if s" Editing Database" else s" Adding Record to Database" then SetTitle: self self Start: FirstLabel self Start: NameLabel self Start: AbodeLabel self Start: First self Start: Name self Start: Abode 10 20 80 20 move: FirstLabel 10 60 80 20 move: NameLabel 10 100 80 20 move: AbodeLabel 90 20 120 20 move: First 90 60 120 20 move: Name 90 100 120 20 move: Abode s" First Name:" SetText: FirstLabel s" Sirname:" SetText: NameLabel s" Abode:" SetText: AbodeLabel record# if s" SELECT * FROM Customers WHERE id = " new$ dup>r place record# (.) r@ +place r@ +null r> count execute: MiniDB 1 getstr: MiniDB SetText: First 2 getstr: MiniDB SetText: Name 3 getstr: MiniDB SetText: Abode false SetModify: First false SetModify: Name false SetModify: Abode then IDOK SetID: Accept self Start: Accept 10 130 100 25 Move: Accept s" Accept" SetText: Accept GetStyle: Accept BS_DEFPUSHBUTTON OR SetStyle: Accept ['] Add-modifyDB SetFunc: Accept self Start: Reject 140 130 100 25 Move: Reject s" Reject" SetText: Reject ['] RejectDB SetFunc: Reject ;m :M On_Paint: ( -- ) \ screen redraw procedure 0 0 width height ( LTGRAY ) DialogColor FillArea: dc ;M :m record#: ( -- record# ) record# ;m : BufferText ( addr len -- addr len ) new$ dup>r place r@ +null r> count ; :m BindText: ( -- ) GetText: First BufferText 1 bindstr: MiniDB GetText: Name BufferText 2 bindstr: MiniDB GetText: Abode BufferText 3 bindstr: MiniDB ;m :m Dirty: ( -- f ) IsModified?: First IsModified?: Name or IsModified?: Abode or ;m ;object --- NEW FILE: STARTDB.F --- \ $Id: STARTDB.F,v 1.1.4.1 2008/08/26 20:54:00 georgeahubert Exp $ \ Build the database if it doesn't already exist require sqlite.f SQLiteDB MiniDB : Create-Customers-Table ( -- ) s" CREATE TABLE Customers (id INTEGER PRIMARY KEY, name varchar, sirname varchar, abode varchar)" execute: MiniDB ; : Add-Customers ( -- ) s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Robin " 0 bindstr: MiniDB s" Hood " 1 bindstr: MiniDB s" Sherwood Forest " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Isaac " 0 bindstr: MiniDB s" Newton " 1 bindstr: MiniDB s" Cambridge " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Maid " 0 bindstr: MiniDB s" Marian " 1 bindstr: MiniDB s" Sherwood Forest " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Friar " 0 bindstr: MiniDB s" Tuck " 1 bindstr: MiniDB s" Sherwood Forest " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Will " 0 bindstr: MiniDB s" Scarlet " 1 bindstr: MiniDB s" Sherwood Forest " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Alan A " 0 bindstr: MiniDB s" Dale " 1 bindstr: MiniDB s" Sherwood Forest " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" George " 0 bindstr: MiniDB s" Hubert " 1 bindstr: MiniDB s" UK " 2 bindstr: MiniDB s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)" execute: MiniDB s" Queen " 0 bindstr: MiniDB s" Elizabeth " 1 bindstr: MiniDB s" Buckingham Palace" 2 bindstr: MiniDB ; : Create-database ( -- ) Create-Customers-Table Add-Customers ; : Start-database ( -- ) s" Mini.db" 2dup file-status nip -rot open: MiniDB if create-database then ; : GetAllCustomers ( -- ) s" SELECT * FROM Customers" execute: MiniDB ; : qdump ( -- ) fieldcnt: MiniDB 0 ?do i fieldname: MiniDB type 20 #tab loop cr cr begin fieldcnt: MiniDB 0 ?do i getstr: MiniDB type 20 #tab loop cr nextrow: MiniDB until ; Start-database GetAllCustomers cr .( The database contains the following data.) cr qdump |
