************************************************************************** * Program Name: db_while.prg * * Author: Jon Cole * * Copyright (c) 1990 by American Management Systems, Inc. * * $Header: D:/prg/db_while.prv 1.27 12 Feb 1990 20:21:16 Jon $ * *------------------------------------------------------------------------* * Created: 2/8/1990 at 12:32 * * $Log: D:/prg/db_while.prv $ * * * Rev 1.27 12 Feb 1990 20:21:16 Jon * added yet another parameter. This one allows choice between * interactive (normal) mode of dbedit() or inactive (display window only). * * Rev 1.26 12 Feb 1990 06:35:58 Jon * added setup questions to demo (ie Allow adding) * * Rev 1.25 12 Feb 1990 06:24:22 Jon * added PROCLIP's setdeleted() * * Rev 1.24 11 Feb 1990 20:53:30 Jon * added some comments * * Rev 1.23 11 Feb 1990 20:01:52 Jon * fixed help * * Rev 1.22 11 Feb 1990 14:55:12 Jon * added another parameter for deletion of records * * Rev 1.21 11 Feb 1990 13:30:22 Jon * Working version (i hope) * ***************************** ALL RIGHTS RESERVED ************************ * Set color strings from a MEM file. The only ones used here * are COLINF , COLINFX , COLCHC , * COLCHCX , and COLSTR . IF FILE("ncolor.mem") * Defines the following vars: colstr, colacc, colnx, colinf, colinfx * colerr, colerrx, colchc, colchcx, colhih, colmnu, colmnux RESTORE FROM ncolor ADDITIVE ELSE msg = "You must run Scolor to set colors before you can run this program." @ 23,0 CLEAR @ 23,Center(msg) SAY msg && PERSONAL QUIT ENDIF PUBLIC colstr, colacc, colnx, colinf, colinfx, colerr, colerrx, colchc PUBLIC colchcx, colhih, colmnu, colmnux *------------------------------------* * NOTES: * * If you want to remove 3rd party libs, search for the following strings: * PERSONAL (my own lib), GETIT, PROCLIP. My personal lib was only used for * centering and messages. Getit was used to clear all SET KEYs and later * restore them. Proclip was used to give it all a professional look. None * of these are needed to make the conditional DBEDIT() work. * Also, one function from LOCKS.PRG is used: add_rec(). It can be replaced * with an APPEND BLANK. * The link line used: * link /se:512 /noe db_while locks,,,getit udf clipper extend proclip * * NOTE: For your own applications you'll need to change (or remove) * one of the REPLACE statements contained here. In this example * it loads the appropriate STATE into the field since that is * not an editable field. * * NOT YET DONE: * Set defaults for all parameters in case they're not passed. * * COMMENT OUT: n_savekeys, n_zapkeys, n_restkeys if you want to use a debugger *------------------------------------* PRIVATE answer, m_idno, condition, target, canadd, candelete, ret_rec SET SCOREBOARD OFF SET CONFIRM ON SET DELETED ON SET COLOR TO (colstr) CLEAR SELECT 0 USE testdata INDEX ON state + lastname + firstname TO testdata DO WHILE .T. * Two parameters are set based on the next GET: CONDITION & TARGET. * TARGET is the value that we will SEEK so that the record pointer * is at the first of the series of records to be displayed. CONDITION * will be tested with each cursor movement (up or down) to determine * if the record should be displayed and the cursor moved. * If all records are to be displayed, then TARGET is set to a NULL and * CONDITION is set to the STRING ".t." A string is used because * CONDITION will be evaluated as a macro later on. u_1 = "Y" @ 12, 0 say "Display a limited set (Y/N/Q)? " get u_1 picture "@!" valid u_1 $"YNQ" read do case case u_1 == "Y" * Display a limited set of records m_idno = "NJ" @ 13,0 say "Only include which state (NY, NJ, FL): " GET m_idno PICTURE "@!" READ condition = "state = m_idno" target = m_idno case u_1 == "N" * Display all records condition = ".t." target = "" otherwise return endcase u_2 = .t. u_3 = .t. u_4 = .t. @ 14, 0 SAY "Allow deleting of records (Y/N)? " get u_2 picture "Y" @ 15, 0 say "Allow adding of records (Y/N)? " get u_3 picture "Y" @ 16, 0 say "Interactive mode (Y/N)? " get u_4 picture "Y" read * set up arrays for dbedit() DECLARE fldnames[5], Head[5], canedit[5], cancursor[5], keyfield[5] * Contents of the columns - NOTE: Deletion is enabled in this example. fldnames[1]= "DELETED()" && logical fldnames[2]= "LASTNAME" && character fldnames[3]= "FIRSTNAME" && character fldnames[4]= "CITY" && character fldnames[5]= "STATE" && character * Column headings Head[1] = "Del" Head[2] = "Lastname" Head[3] = "First" Head[4] = "City" Head[5] = "State" * Allow editing of which fields canedit[1] = .F. canedit[2] = .T. canedit[3] = .T. canedit[4] = .T. canedit[5] = .F. * Allow adding records? canadd = u_3 * Allow deleting of records? candelete = u_2 * Is the cursor allowed in this field? cancursor[1] = .F. cancursor[2] = .T. cancursor[3] = .T. cancursor[4] = .T. cancursor[5] = .F. * This array is used in determining whether or not the screen must be * repainted when edits during DBEDIT() will change the sequence of * the records. If the corresponding field is part of the index key, * then set that KEYFIELD[] to TRUE; otherwise FALSE. keyfield[1] = .F. keyfield[2] = .T. keyfield[3] = .T. keyfield[4] = .F. keyfield[5] = .T. * If interact is TRUE then dbedit() will be in interactive mode (normal). * If it is set to FALSE, the dbedit() will display as many records as * will fit in the window and immediately exit, leaving the display window * on the screen. interact = u_4 * Make the indirect call to dbedit(), which returns * either the record number selected, zero (0) if * was pressed, or -1 if no records match the criteria. ret_rec = dbwhile( 10, 5, 18, 73, fldnames, target, condition, "db_keys", Head, canedit, canadd, candelete, cancursor, keyfield, interact) IF ret_rec >= 0 @ 5, 40 CLEAR TO 5,79 @ 5, 40 SAY "You Picked Record " + IF(ret_rec = 0, "None", STR(ret_rec,6) ) ELSE MESSAGE( "None met the criteria.", "", 12) && PERSONAL ENDIF ENDDO *----------------------------------------------------------------------------* FUNCTION dbwhile PARAMETERS db_top, db_lft, db_btm, db_rt, db_flds, db_target, condition, db_udf, db_hd, db_edit, db_add, db_delete, db_cursor, db_kfield, db_active PRIVATE moldcolor, recnum, db_rows, kright, kleft PRIVATE kenter, kesc, kup, kdown, kpgup, kpgdn, kctrlpgup, kctrlpgdn PRIVATE l_idle, l_pastbof, l_pasteof, l_empty, key_excep, l_quit, l_continu PRIVATE repaint, apnd_tgl, tmpvar, oldscreen, oldkeys PRIVATE append_on, any_index, db_marker, olddelete * Save keys set to procedures and undo them. Requires GETIT.lib oldkeys = N_savekeys() N_zapkeys() * Set help for this function SET KEY 28 TO db_help any_index = (INDEXORD() > 0) && .t. if an index is active - used for repainting append_on = .F. && set default * If deletion is enabled, then display deleted records so that * the status of delete may be toggled. db_delete is TRUE when * deletion is enabled. olddelete = setdeleted( !db_delete) && PROCLIP * See comments under DB_KEYS() mode = IDLE regarding db_marker db_marker = .F. IF TYPE( "DB_TOP") != "N" db_top = 0 ENDIF IF TYPE( "DB_BTM") != "N" db_btm = 24 ENDIF * Calculate the number of rows displayed in the dbedit() window db_rows = (db_btm - db_top) - 1 IF TYPE("DB_LFT") != "N" db_lft = 0 ENDIF IF TYPE("DB_RT") != "N" db_rt = 79 ENDIF IF TYPE("CONDITION") != "C" condition = ".t." && include all records ENDIF IF TYPE("DB_UDF") != "C" db_udf = "" ENDIF if type( "db_active") != "L" db_active = .t. && default to normal dbedit() behavior endif * Convert all fields to strings. * Expand the fields array (DB_FLDS) based on CONDITION * so that blank spaces will appear in DBEDIT() for records * at the top or bottom of display window for which the condition * is not true. * Create another array to hold the conditional field statements. * 2 arrays are needed because the 1st must be kept in tact to * allow editing of fields. DECLARE fld_cond[len(db_flds)] * must blank wrong fields for proper display position FOR J = 1 TO LEN( db_flds) tmpvar = db_flds[j] DO CASE CASE TYPE( "&tmpvar") == "C" fld_cond[j] = "IF( &condition, " + db_flds[j] + ", SPACE( len( &tmpvar)) )" CASE TYPE( "&tmpvar") == "N" fld_cond[j] = "IF( &condition, transform( " + db_flds[j] + ", '@('), SPACE( len( tostr(&tmpvar))) )" CASE TYPE( "&tmpvar") == "L" fld_cond[j] = "IF( &condition, transform( " + db_flds[j] + ",'Y'), SPACE(1) )" CASE TYPE( "&tmpvar") == "D" fld_cond[j] = "IF( &condition, dtoc( " + db_flds[j] + "), SPACE(8) )" ENDCASE NEXT j IF TYPE("DB_HD") != "A" db_hd = "" ENDIF * NAME Keys for easier code reading kenter = 13 kesc = 27 kup = 5 kdown = 24 kright = 4 kleft = 19 kpgup = 18 kpgdn = 3 kctrlpgup = 31 kctrlpgdn = 30 * dbedit modes l_idle = 0 l_pastbof = 1 l_pasteof = 2 l_empty = 3 key_excep = 4 * udf return values l_quit = 0 l_continu = 1 repaint = 2 apnd_tgl = 3 moldcolor = Setcolor() if db_active * if normal (interactive) mode has been requested, save screen * so that after user finishes interactive mode, the window will * disappear, returning the original display. oldscreen = Savebox( db_top-2, db_lft-2, db_btm+2, db_rt+2) endif BEGIN SEQUENCE * SET UP mtopno, mbotno, top_recs[] and bot_recs[] DECLARE top_recs[db_rows], bot_recs[db_rows] IF ! db_setup( .T.) && 1st time this is called recnum = -1 && flag for none meeting criteria BREAK ENDIF * set outline colors Setcolor( colchcx) * draw box @ db_top-1, db_lft-1 TO db_btm+1, db_rt+1 DOUBLE @ db_btm+1, db_rt-9 SAY " Help" * shadow the box * vertical shadow newcolor( db_top, db_rt+2, db_btm+2, db_rt+2, "w/n") && PROCLIP * horizontal shadow newcolor( db_btm+2, db_lft, db_btm+2, db_rt+2, "w/n") && PROCLIP * set up cursor control keys SET KEY kup TO key_ok SET KEY kdown TO key_ok SET KEY kpgup TO key_ok SET KEY kpgdn TO key_ok SET KEY kctrlpgup TO go_top SET KEY kctrlpgdn TO go_bot * set dbedit() colors Setcolor( colchc) if !db_active * Since inactive mode has been requested stuff an to * immediately terminate dbedit(). keyboard chr( kesc) endif * Finally, the direct call to dbedit() Dbedit( db_top, db_lft, db_btm, db_rt, fld_cond, "db_keys", "", Head) END sequence * release cursor control keys SET KEY kup TO SET KEY kdown TO SET KEY kpgup TO SET KEY kpgdn TO SET KEY kctrlpgup TO SET KEY kctrlpgdn TO * restore colors and screens, if applicable if db_active Restbox( oldscreen) && Requires PROCLIP endif Setcolor( moldcolor ) * Reset all SET KEYs to procedures. Requires GETIT n_restkeys(oldkeys) * return SET DELETED to its prior state SETDELETED( olddelete) && PROCLIP RELEASE mtopno, mbotno, db_marker RETURN recnum *--------------------------------* FUNCTION db_keys PARAMETERS mode, column PRIVATE ret_val, keypress, tmpvar, tmpfld, X, totkeys, foundone, J keypress = LASTKEY() ret_val = l_continu && default DO CASE CASE ! db_cursor[column] * When dbedit() is 1st executed its UDF is called in IDLE mode. * Since the 1st column may not be a permitted column for the cursor * (based on db_cursor[]), we must check it out & move immediately * if necessary. KEYBOARD( CHR(kright)) ret_val = l_continu CASE mode = l_idle DO CASE CASE (keypress = kleft) * A left arrow was pressed. This routine won't be executed * until AFTER the cursor has already been moved right once. * Find the first column to left of current column that is * marked TRUE in DB_CURSOR[]. If none are or the current * column is already the first, do nothing. * If any keys are stuffed into the keyboard as a result of this * routine, a marker (db_marker) is set TRUE. This is needed because * the stuffed key will force DBEDIT() to call its UDF() once * more & we don't want the cursor moved again. IF ! db_marker IF !db_cursor[column] totkeys = 0 && initialize counter foundone = .F. && initialize flag IF column != 1 FOR J = column-1 TO 1 STEP -1 totkeys = totkeys + 1 && increment to count how many IF db_cursor[j] foundone = .T. EXIT && exit the for/next loop ENDIF NEXT j ENDIF IF totkeys != 0 .AND. foundone KEYBOARD( REPLICATE( CHR(kleft), totkeys)) db_marker = .T. ELSE KEYBOARD( CHR(kright) ) ENDIF ENDIF ELSE * This is the second time DB_KEYS() is being called for this * keypress. Ignore it and reset the flag. db_marker = .F. ENDIF ret_val = l_continu CASE (keypress = kright) * A right arrow was pressed. Find the first column to right of * current column that is marked TRUE in DB_CURSOR[]. If none * are or the current column is already the last, do nothing. * This routine won't be executed until AFTER the cursor has * already been moved right once. * If any keys are stuffed into the keyboard as a result of this * routine, a marker (db_marker) is set TRUE. This is needed because * the stuffed key will force DBEDIT() to call its UDF() once * more & we don't want the cursor moved again. IF ! db_marker IF !db_cursor[column] totkeys = 0 && initialize counter foundone = .F. && initialize flag IF column != LEN( db_flds) && if this isn't the last column FOR J = column+1 TO LEN( db_flds) totkeys = totkeys + 1 && increment to count how many IF db_cursor[j] foundone = .T. EXIT && exit the for/next loop ENDIF NEXT j ENDIF IF totkeys != 0 .AND. foundone KEYBOARD( REPLICATE( CHR(kright), totkeys)) db_marker = .T. ELSE KEYBOARD( CHR(kleft)) ENDIF ENDIF ELSE * This is the second time DB_KEYS() is being called for this * keypress. Ignore it and reset the flag. db_marker = .F. ENDIF ret_val = l_continu CASE append_on * After APPEND mode is toggled on, DBEDIT() calls its UDF() once * more in mode IDLE. msg = " < New Record > " X = (( (db_rt+1) - (db_lft) ) - LEN(msg) ) / 2 @ db_btm+1, (db_lft-1 + X) SAY msg ret_val = l_continu CASE (! &condition) * I found this case to be necessary, but I don't understand * why. The symptom that made it necessary was that holding * down the up/dn arrows or the pgup/pgdn causes different * behavior than repeated single presses of those keys. * Without this CASE the cursor will INTERMITTANTLY move beyond * the valid records (ie those with &condition being TRUE). IF keypress = kup .OR. keypress = kpgup GOTO mtopno ELSEIF keypress = kdown .OR. keypress = kpgdn GOTO mbotno ENDIF ret_val = l_continu OTHERWISE SET KEY kup TO key_ok SET KEY kdown TO key_ok SET KEY kpgup TO key_ok SET KEY kpgdn TO key_ok ret_val = l_continu ENDCASE * DBEDIT()'s PAST BEGINNING OF FILE mode can happen for two reasons: * 1. An attempt was made to cursor up at first record. * 2. APPEND mode was just exited (a record was added), which causes * DBEDIT's key handling UDF to be called in this mode. CASE mode = l_pastbof IF append_on && if append mode active, turn it off append_on = .F. ret_val = apnd_tgl ELSE GOTO mtopno ret_val = l_continu ENDIF CASE mode = l_pasteof GOTO mbotno ret_val = l_continu CASE mode = key_excep DO CASE CASE (keypress = kenter) .OR. (keypress = kesc) && Quit or ? recnum = IF( keypress = kesc, 0, RECNO() ) ret_val = l_quit CASE keypress = 20 && go to 1st rec in window GOTO mtopno ret_val = l_continu CASE keypress = 10 && goto last rec in window GOTO mbotno ret_val = l_continu CASE keypress = -1 .AND. db_add && Add a record IF MESSAGE( "Are you sure you want to add one (Y/N)?", "YN", 12) == "Y" && PERSONAL IF ! append_on && if not in append mode, turn it on append_on = .T. ret_val = apnd_tgl ENDIF ENDIF CASE keypress > 31 .AND. keypress < 127 .AND. db_edit[column] * If data was entered and user is in an editable column, Edit field BEGIN SEQUENCE tmpvar = db_flds[column] tmpvar = &tmpvar. @ ROW(), COL() GET tmpvar KEYBOARD CHR(keypress) && stuff keyboard with keypress CURSOR( IF( Inslock(), "full", "std")) READ CURSOR( "off") IF LASTKEY() != kesc && if user didn't abort, add the record IF append_on * Physically add the record (append) to the dbf IF ! EMPTY(tmpvar) IF add_rec(5) ret_val = IF( any_index, repaint, apnd_tgl) * THIS LINE MUST CHANGE FOR EACH APPLICATION ! REPLACE state WITH target ELSE MESSAGE( "Couldn't add the record.", "", 12) && PERSONAL BREAK ENDIF ENDIF ELSE * Editing an existing record. Repaint the window * if a key field was edited. IF ! db_kfield[column] ret_val = l_continu ELSE ret_val = IIF( any_index, repaint, l_continu) ENDIF ENDIF tmpfld = db_flds[column] REPLACE &tmpfld. WITH tmpvar IF db_kfield[column] .OR. append_on * If a key field was edited or a record added, reset * beginning and ending markers and arrays db_setup( .F.) && not the 1st time this is called * reset the APPEND flag append_on = .F. * Redraw the box to erase the "" message Setcolor( colchcx) * draw box @ db_top-1, db_lft-1 TO db_btm+1, db_rt+1 DOUBLE @ db_btm+1, db_rt-9 SAY " Help" Setcolor( colchc) ENDIF KEYBOARD CHR( kright) && move to next field ENDIF END sequence CASE keypress = 7 .AND. db_delete * The delete key was pressed and deletion is enabled msg = IF( !DELETED(), "DELETE", "UNDELETE") IF MESSAGE( "Are you sure you want to " + msg + " this one (Y/N)?", "YN", 12) == "Y" IF ! DELETED() DELETE ELSE RECALL ENDIF ENDIF ret_val = l_continu ENDCASE OTHERWISE ret_val = l_continu ENDCASE RETURN ret_val *--------------------------------* PROCEDURE go_top KEYBOARD CHR(20) RETURN *--------------------------------* PROCEDURE go_bot KEYBOARD CHR(10) RETURN *--------------------------------* FUNCTION db_setup PARAMETERS firstpass PUBLIC mtopno, mbotno PRIVATE ret_val, target, oldsoft, oldrec Afill(top_recs, 0) Afill(bot_recs, 0) STORE 0 TO mtopno, mbotno * if this is NOT the first time DB_SETUP() is being called, then * store the current record number so that we can return to it. IF ! firstpass oldrec = RECNO() ENDIF IF condition != ".t." SEEK db_target ELSE GO TOP ENDIF IF FOUND() .OR. (condition == ".t.") * MUST already be on top record when this procedure is called mtopno = RECNO() * fill top records into top_recs[] FOR I = 1 TO db_rows top_recs[i] = RECNO() SKIP IF .NOT. &condition EXIT ENDIF NEXT i * With softseek set on, seek the first record after condition. * This is accomplished by incrementing the right most character * of the string M_IDNO by one ascii character. After SEEKing the * resulting string (TARGET), back up one record to get to the last * record which matches CONDITION. This record number is then * stored in MBOTNO. IF condition != ".t." target = LEFT( m_idno, LEN(m_idno)-1) + CHR( ASC( RIGHT(m_idno, 1)) + 1) oldsoft = Setsoft(.T.) SEEK target Setsoft( oldsoft) SKIP -1 mbotno = RECNO() ELSE GOTO BOTTOM mbotno = RECNO() ENDIF * fill bottom db_rows records into top_recs[] FOR I = 1 TO db_rows bot_recs[i] = RECNO() SKIP -1 IF .NOT. &condition EXIT ENDIF NEXT i GO mtopno ret_val = .T. && some were found ELSE ret_val = .F. && none were found ENDIF * If this is not the first time db_setup() was called, then * return to the record that was current before this udf was called. IF ! firstpass GOTO oldrec ENDIF RETURN ret_val *--------------------------------------* PROCEDURE key_ok * The purpose of this function is to intercept cursor keys before * DBEDIT() has a chance to execute them. Here we test to see if * we want the key to be processed. If so, stuff the key back into * the keyboard. The keys are intercepted by using SET KEY TO KEY_OK. PRIVATE keypress keypress = LASTKEY() CLEAR TYPEAHEAD DO CASE CASE ((RECNO() <> mtopno .AND. keypress = kup) .OR. ; (RECNO() <> mbotno .AND. keypress = kdown) ) SET KEY keypress TO && ok to process up/dn arrow KEYBOARD CHR(keypress) CASE keypress = kpgup IF Ascan(top_recs, RECNO()) = 0 && ok to process PgUp SET KEY keypress TO KEYBOARD CHR(keypress) ELSE KEYBOARD CHR(20) && go top record number if on top screen ENDIF CASE keypress = kpgdn IF Ascan(bot_recs, RECNO()) = 0 && ok to process PgDn SET KEY keypress TO KEYBOARD CHR(keypress) ELSE KEYBOARD CHR(10) && go bottom record number if on last screen ENDIF ENDCASE RETURN *--------------------------------------* PROCEDURE db_help PRIVATE oldbox, helpbox, TOP, lft, btm, rt, msg, oldcolor oldcolor = Setcolor( colinf) TOP = 10 lft = 11 btm = 22 rt = 68 oldbox = Savebox( TOP-1, lft-1, btm+2, rt+2) && PROCLIP helpbox = Createbox( btm - TOP, rt - lft, TOP, lft) && PROCLIP * clear the help box Boxfill( helpbox, " ", colinf) && PROCLIP * draw the box Boxframe( helpbox, "ÚÄ¿³ÙÄÀ³", colinfx) && PROCLIP msg = " H E L P " Printbox( helpbox, 0, Center(msg, rt-lft), msg) && PROCLIP msg = "/ = Up/Down" Printbox( helpbox, 1, 1, msg) && PROCLIP msg = " = Screen Up/Down" Printbox( helpbox, 2, 1, msg) && PROCLIP msg = " = Last record" Printbox( helpbox, 3, 1, msg) && PROCLIP msg = " = First record" Printbox( helpbox, 4, 1, msg) && PROCLIP msg = " = Select Record - except during an edit" Printbox( helpbox, 5, 1, msg) && PROCLIP msg = " = Add a Record (if permitted)" Printbox( helpbox, 6, 1, msg) && PROCLIP msg = "{text} = Edit (if permitted)" Printbox( helpbox, 7, 1, msg) && PROCLIP msg = " = Delete/undelete record (if permitted)" Printbox( helpbox, 8, 1, msg) && PROCLIP msg = " = Quit" Printbox( helpbox, 9, 1, msg) && PROCLIP msg = " < Press any key to continue > " Printbox( helpbox, 11, Center(msg, rt-lft), msg) && PROCLIP Restbox( helpbox) && PROCLIP * shadow the box * vertical shadow newcolor( TOP, rt, btm, rt, "w/n") && PROCLIP * horizontal shadow newcolor( btm, lft, btm, rt, "w/n") && PROCLIP INKEY(0) Restbox( oldbox) && PROCLIP Setcolor( oldcolor) RETURN *--------------------------------------* * EOF db_while.prg