DOS Wares

home *** CD-ROM | disk | FTP | other *** search

/ DOS Wares / doswares.zip / doswares / DATABASE / DBASE5 / SAMPLES.ZIP / LIBRARY.PRG < prev next >

Wrap

Text File | 1994-06-24 | 45.0 KB | 1,344 lines

****************************************************************************** * PROGRAM NAME: LIBRARY.PRG * LIBRARY OF PROCEDURES COMMON TO ALL BUSINESS PROGRAMS * SAMPLE BUSINESS APPLICATION PROGRAM * LAST CHANGED: 03/11/93 * WRITTEN BY: Borland International Inc. ****************************************************************************** PROCEDURE Add_new * Add new record to database file * Erase previous record number from screen lAddNew = .T. @ 0,65 SAY SPACE(15) COLOR &c_yellow. * Display F9 lookup key message, if lookup available IF lookup_ok DO Sho_look WITH dbf ENDIF DO Init_fld DO Get_data READ * Erase lookup message from screen @ 0,0 SAY SPACE(51) * If user didn't enter data into key fields, exit without saving IF "" = TRIM(&key.) .OR. READKEY() < 256 RETURN ELSE * Each application checks for duplicates if duplicate keys not allowed * If duplicate key (when not allowed), exit from add mode without saving IF rec_is_dup * Reset status flag and exit rec_is_dup = .F. RETURN ELSE * Append and save validated record DO Sav_data GO record_num ENDIF ENDIF RETURN PROCEDURE Bar_def * Define the main popup OPTION MENU, main_mnu mesg = "Press first letter of Menu choice, or highlight and press <Enter>" DEFINE POPUP main_mnu FROM 2,58 TO 22,78 MESSAGE mesg DEFINE BAR 1 OF main_mnu PROMPT "== OPTION MENU ==" SKIP DEFINE BAR 2 OF main_mnu PROMPT " Add record" DEFINE BAR 3 OF main_mnu PROMPT " Edit record" DEFINE BAR 4 OF main_mnu PROMPT " Delete record" DEFINE BAR 5 OF main_mnu PROMPT "-------------------" SKIP DEFINE BAR 6 OF main_mnu PROMPT " Next record" DEFINE BAR 7 OF main_mnu PROMPT " Previous record" DEFINE BAR 8 OF main_mnu PROMPT " Top record" DEFINE BAR 9 OF main_mnu PROMPT " Bottom record" DEFINE BAR 10 OF main_mnu PROMPT " Skip records" DEFINE BAR 11 OF main_mnu PROMPT " Find record" DEFINE BAR 12 OF main_mnu PROMPT "-------------------" SKIP DEFINE BAR 13 OF main_mnu PROMPT " List records" DEFINE BAR 14 OF main_mnu PROMPT " Output reports" DEFINE BAR 15 OF main_mnu PROMPT " Group records" SKIP FOR dbf = "ACCT_REC" DEFINE BAR 16 OF main_mnu PROMPT " Count records" DEFINE BAR 17 OF main_mnu PROMPT " Index database" DEFINE BAR 18 OF main_mnu PROMPT " Help" DEFINE BAR 19 OF main_mnu PROMPT " Quit to MAIN MENU" * Define the popup dest_mnu for printing reports to a destination DEFINE POPUP dest_mnu FROM 13,10 TO 19,38 MESSAGE mesg DEFINE BAR 1 OF dest_mnu PROMPT "======= DESTINATION =======" SKIP DEFINE BAR 2 OF dest_mnu PROMPT " Printer" DEFINE BAR 3 OF dest_mnu PROMPT " File" DEFINE BAR 4 OF dest_mnu PROMPT " Screen" DEFINE BAR 5 OF dest_mnu PROMPT " Exit to OPTION MENU" * Define the popup rpt_mnu for printing reports to a destination DEFINE POPUP rpt_mnu FROM 11, 5 TO 17,38 MESSAGE mesg DEFINE BAR 1 OF rpt_mnu PROMPT "============ REPORTS ===========" SKIP DEFINE BAR 2 OF rpt_mnu PROMPT " Database report: " + dbf DEFINE BAR 3 OF rpt_mnu PROMPT " Mailing list: " + mlist ; SKIP FOR mlist = "NOT AVAILABLE" DEFINE BAR 4 OF rpt_mnu PROMPT " Custom programmed report: " + cust_rpt ; SKIP FOR cust_rpt = "N/A" DEFINE BAR 5 OF rpt_mnu PROMPT " Exit to OPTION MENU" * Define which procedures are executed by the defined popups ON SELECTION POPUP main_mnu DO Barpop ON SELECTION POPUP rpt_mnu DO Barpop_r ON SELECTION POPUP dest_mnu DO Barpop_d * Define windows for text, msgs, etc. IF "MONO" $ SET( "DISPLAY" ) DEFINE WINDOW alert FROM 15, 3 TO 22,46 DOUBLE COLOR &c_alert. DEFINE WINDOW duplicat FROM 15, 5 TO 21,70 DOUBLE COLOR &c_alert. DEFINE WINDOW lister FROM 5, 5 TO 22,70 DOUBLE COLOR &c_list. DEFINE WINDOW look FROM 6, 5 TO 16,65 DOUBLE COLOR &c_list. DEFINE WINDOW memo_windo FROM 7, 4 TO 19,75 DOUBLE COLOR &c_list. ELSE DEFINE WINDOW alert FROM 15, 3 TO 22,46 PANEL COLOR &c_alert. DEFINE WINDOW duplicat FROM 15, 5 TO 21,70 PANEL COLOR &c_alert. DEFINE WINDOW lister FROM 5, 5 TO 22,70 PANEL COLOR &c_list. DEFINE WINDOW look FROM 6, 5 TO 16,65 PANEL COLOR &c_list. DEFINE WINDOW memo_windo FROM 7, 4 TO 19,75 PANEL COLOR &c_list. ENDIF RETURN PROCEDURE Barpop * Perform action selected by user from OPTION MENU bars DO CASE * BAR() = 1 is title of menu CASE BAR() = 2 && Add record DO Add_new CASE BAR() = 3 && Edit record DO Edit CASE BAR() = 4 && Delete record DO Eraser CASE BAR() = 6 && Next record DO Skip_rec WITH 1 CASE BAR() = 7 && Previous record DO Skip_rec WITH -1 CASE BAR() = 8 && Top record, in active index order GO TOP CASE BAR() = 9 && Bottom record, in active index order GO BOTTOM CASE BAR() = 10 && Skip records DO Skip_rec WITH 0 CASE BAR() = 11 && Find record DO Find_rec WITH key, key1, keyname1, key2, keyname2, key3, keyname3 CASE BAR() = 13 && List records DO List_rec CASE BAR() = 14 && Output reports SAVE SCREEN TO Pre_rept && Save screen image ACTIVATE POPUP rpt_mnu RESTORE SCREEN FROM Pre_rept RELEASE SCREEN Pre_rept CASE BAR() = 15 && Group records DO Filter CASE BAR() = 16 && Count records ************ IF NETWORK() * Turn off file lock to count SET LOCK off DO Kount SET LOCK on *********** ELSE DO Kount ENDIF CASE BAR() = 17 && Index database ************ IF NETWORK() old_tag = ORDER() USE (dbf) EXCLUSIVE IF net_choice <> 27 && check Net_err user choice (Esc=27) DO Indexer SET EXCLUSIVE off USE (dbf) ORDER (old_tag) ENDIF *********************** ELSE DO Indexer ENDIF CASE BAR() = 18 && Help SET COLOR TO &c_standard. DO Helper CASE BAR() = 19 && Quit to Main Menu DEACTIVATE POPUP ENDCASE DO Dstatus && Display record no and filter status DO Show_data && Display screen with current record CLEAR GETS SET COLOR TO &c_popup. RETURN PROCEDURE Barpop_d * Perform action selected by user from Destination menu SET COLOR TO &c_popup. DO CASE * BAR() 1 is title of menu CASE BAR() = 2 && Output to printer ll_esc = .F. DO Prt_menu && Activate menu for print options IF .NOT. ll_esc SET PRINTER on SET CONSOLE off DO Printout && Output selected report SET PRINTER off SET CONSOLE on ENDIF CASE BAR() = 3 && Output to file answer = SPACE(8) ACTIVATE WINDOW alert @ 0,0 SAY "----------- SEND REPORT TO FILE ----------" @ 2,1 SAY "Enter filename for report: " GET answer ; VALID "" <> TRIM(answer) ; MESSAGE "Enter a filename of up to eight characters" READ DEACTIVATE WINDOW alert SET ALTERNATE TO &answer. SET ALTERNATE on SET CONSOLE off GO TOP DO Printout && Output report or labels to file SET ALTERNATE off SET CONSOLE on CASE BAR() = 4 && Output to screen SET COLOR TO &c_standard. CLEAR * Store current page settings plength = _plength rmargin = _rmargin * Set page width & length for screen _plength = 25 _rmargin = 80 DO Printout && Output chosen report/labels to screen CLEAR * Reset page settings _plength = plength _rmargin = rmargin GO record_num && Return to original record CASE BAR() = 5 && Exit to OPTION MENU DEACTIVATE POPUP ENDCASE SET COLOR TO &c_standard. DEACTIVATE POPUP RETURN PROCEDURE Barpop_r * Select available reports menu SET COLOR TO &c_popup. reportype = SPACE(6) DO CASE CASE BAR() = 2 && Output standard report to destination reportype = "LISTING" ACTIVATE POPUP dest_mnu && Activate printer destination menu CASE BAR() = 3 && Output mailing labels to destination reportype = "LABELS" ACTIVATE POPUP dest_mnu && Activate printer destination menu CASE BAR() = 4 && Output custom report to destination reportype = "CUSTOM" ACTIVATE WINDOW alert * Get custom report name from user * First, allow READ errors and warning bell SET BELL ON rpt_name = SPACE(8) @ 0,0 SAY "-------- CUSTOM PROGRAMMED REPORT --------" @ 2,1 SAY "Enter report program name:" GET rpt_name ; VALID FILE(TRIM(rpt_name) + ".prg") ; MESSAGE "Enter a filename of up to eight " + ; "characters, e.g. Emp_rept " ; ERROR "Invalid filename, please re-enter" READ SET BELL OFF DEACTIVATE WINDOW alert IF LASTKEY() <> 27 && A report filename was found SET COLOR TO &c_popup. ACTIVATE POPUP dest_mnu ENDIF ENDCASE SET COLOR TO &c_popup. DEACTIVATE POPUP RETURN PROCEDURE Sub_ret IF erased * Pack deleted records (if any) - erases completely from database ************ IF NETWORK() USE (dbf) EXCLUSIVE ENDIF IF net_choice <> 27 && Skip if user pressed Esc ******************* && error condition ?? CHR(7) ACTIVATE WINDOW alert @ 0,0 SAY "----------- PACKING DATABASE ------------" @ 2,1 SAY "ERASING deleted records now......" @ 3,1 SAY "Please wait......DO NOT TURN OFF" PACK DEACTIVATE WINDOW alert ENDIF ENDIF * Houskeeping CLOSE DATABASES CLEAR WINDOWS RELEASE ALL CLEAR ON KEY LABEL F9 && Turn off ON KEY LABEL F9/F10 commands ON KEY LABEL F10 * Restore environment (in case user began at Control Center or dot prompt) DO Rest_env CLEAR RETURN TO MASTER && Exit Subapplication FUNCTION Duplicat PARAMETERS key * Used if duplicates are not allowed in a database * Set rec_is_dup to .T. if user entered duplicate key data rec_is_dup = .F. IF RECCOUNT() = 0 .OR. "" = TRIM(key) * Do not check if database or key field(s) is empty RETURN rec_is_dup ENDIF record_num = RECNO() && Save current record position SEEK TRIM(key) * Determine if record is duplicate key * PROMPT() used instead of BAR() for clarity DO CASE CASE PROMPT() = " Edit record" * If seek finds a record other than the current one, * the edited record has a duplicate key rec_is_dup = record_num <> RECNO() .AND. FOUND() CASE PROMPT() = " Add record" * New record is duplicate if seek finds any record that matches rec_is_dup = FOUND() ENDCASE IF rec_is_dup && Show duplicate record in window ACTIVATE WINDOW duplicat CLEAR DO Warnbell ? "------------------ DUPLICATE " + dbf + ; " RECORD ------------------" ? " Duplicates not allowed" DO CASE CASE dbf = "CUST" ? " " + cust_id + " " + customer ? "This is the EXISTING record in the database; " + ; "re-enter Cust.ID." CASE dbf = "VENDORS" ? " " + vendor_id + " " + vendor ? "This is the EXISTING record in the database; " + ; "re-enter Vendor ID." CASE dbf = "GOODS" ? " " + part_id + " " + part_name ? "This is the EXISTING record in the database; " + ; "re-enter Part ID." CASE dbf = "ACCT_REC" ? " " + invoice_no + " " + cust_id + " " + DTOC(dat_of_bil) ? "This is the EXISTING record in the database; " + ; "re-enter Invoice ID." ENDCASE WAIT " Press spacebar to continue..." DEACTIVATE WINDOW duplicat ENDIF GO record_num && Return to original record RETURN .NOT. rec_is_dup PROCEDURE Dstatus * Display filter status and current record number * Set colors with blink on/off depending on hardware IF filters_on * Show blinking msg for filter status @ 0,51 SAY "Filter is ON" COLOR &c_blink. ELSE SET COLOR TO &c_standard. * Erase message - filter is off @ 0,51 ENDIF * Show current record number on screen @ 0,66 SAY "Record #" + STR(RECNO(),5,0) COLOR &c_yellow. RETURN PROCEDURE Edit * Edit current record * Display lookup key message if lookup available (set in each application) lAddNew = .F. IF lookup_ok DO Sho_look WITH dbf ENDIF record_num = RECNO() * Load data from record into memory variables IF .NOT. NETWORK() DO Load_fld ELSE DO WHILE .NOT. RLOCK() *------------------------------------------------ *-- Net_Err will continue to make the record lock *-- attempt until the user presses Escape. The *-- escape will terminate the sub-application *------------------------------------------------ DO Net_Err WITH 109, .T. ENDDO DO Load_fld ENDIF DO Get_data READ && Edit data ***** * Erase F9 lookup message from screen @ 0,0 SAY SPACE(51) IF "" = TRIM(&key.) .OR. READKEY() < 256 * Exit if user blanked key, did not change data, or deleted record UNLOCK RETURN ELSE * Save edited data to disk DO Sav_data ENDIF RETURN PROCEDURE Eraser * Erase current record IF NodShake( " ; Erase this data record? ", ; 9, 26, 2, 29, .F. ) DELETE * Position to the next record SKIP * Check if the last record was deleted DO CASE CASE filters_on .AND. EOF() * If no records left in filter subset, turn off filter SET FILTER TO filters_on = .F. * If last record deleted, go to beginning of database GO TOP CASE .NOT. filters_on .AND. EOF() * If last record deleted, go to beginning of database GO TOP ENDCASE * Set erased status flag that record was deleted erased = .T. ENDIF RETURN PROCEDURE Filt_ans * Get answer from user about filtering data into subset IF filters_on *-- Filter window - to turn off filter IF NodShake( " ; GROUP into SUBSET (Filter) ;" + ; " Subset is currently selected. ;" + ; " Turn Filter off?", ; 7, 22, 4, 35, .F. ) choice = "T" ELSE choice = "N" ENDIF ELSE *-- Filter window - to turn on filter IF NodShake( " ; GROUP into SUBSET (Filter) ;" + ; " Select temporary subset of data ;" + ; " by entering filter condition(s) ;" + ; " Proceed?", ; 7, 21, 5, 37, .F. ) choice = "Y" ELSE choice = "N" ENDIF ENDIF RETURN PROCEDURE Findcode PARAMETERS acity * Look up area code for phone number - by city acode = 0 ACTIVATE WINDOW alert CLEAR acode = LOOKUP(Codes->code,TRIM(acity),Codes->city) ? "------------- AREA CODE LOOKUP -----------" IF .NOT. FOUND("Codes") .OR. "" = TRIM(acity) DO Warnbell ? "City: " + TRIM(acity) + " was" AT 2 ? "NOT FOUND in areacodes database." AT 2 ELSE ? ? "AREA CODE is: " + STR(acode,3) AT 2 ? "for " + TRIM(acity) AT 16 ENDIF ? WAIT " Press spacebar to continue..." DEACTIVATE WINDOW alert RETURN PROCEDURE Findcust PARAMETERS custid * Look up customer from customer ID acust = "" ACTIVATE WINDOW alert CLEAR acust = LOOKUP(Cust->customer,TRIM(custid),Cust->cust_id) ? "---------- CUSTOMER ID LOOKUP -----------" IF .NOT. FOUND("Cust") .OR. "" = TRIM(custid) DO Warnbell ? "Customer ID: " + TRIM(custid) + " was" AT 2 ? "NOT FOUND in Cust database." AT 2 ELSE ? "Customer: " + TRIM(acust) AT 2 ? "Phone: " + Cust->phone AT 2 ? "for ID: " + TRIM(custid) AT 12 ENDIF WAIT " Press spacebar to continue..." DEACTIVATE WINDOW alert RETURN PROCEDURE Find_rec PARAMETERS key, key1, keyname1, key2, keyname2, key3, keyname3 * Get target data to find/seek and show data record after retrieving STORE "" TO target1, target2, target3 target1 = IIF(TYPE(key1) = "C", SPACE(LEN(&key1.)), { / / }) * If key2 exists (database requires two keys) IF "NONE" <> key2 target2 = IIF(TYPE(key2) = "C", SPACE(LEN(&key2.)), { / / }) * If key3 exists (database has three keys) IF "NONE" <> key3 target3 = IIF(TYPE(key3) = "C", SPACE(LEN(&key3.)), { / / }) ENDIF ENDIF ACTIVATE WINDOW alert @ 0,0 SAY "-------- ENTER TARGET DATA TO FIND -------" @ 2, 1 SAY keyname1 @ 2,15 GET target1 MESSAGE "Enter " + keyname1 IF "NONE" <> key2 @ 3, 1 SAY keyname2 @ 3,15 GET target2 IF "NONE" <> key3 @ 4, 1 SAY keyname3 @ 4,15 GET target3 ENDIF ENDIF @ 5,1 SAY "Enter partial or entire data" READ DEACTIVATE WINDOW alert target = IIF(type(key1) = "C", target1, DTOC(target1)) IF "NONE" <> key2 target = target + IIF(type(key2) = "C", target2, DTOC(target2)) IF "NONE" <> key3 target = target + IIF(type(key3) = "C", target3, DTOC(target3)) ENDIF ENDIF target = TRIM(target) IF RIGHT(target, 6) = " / /" * If a date key wasn't filled in, remove the template target = LEFT(target, LEN(target) - 6) ENDIF IF "" = target * If user entered nothing (blank key) => exit RETURN ENDIF * Store record no. that the user was viewing record_num = RECNO() * Find record with target key IF .NOT. SEEK(target) * If target not found, uppercase & look again IF .NOT. SEEK(UPPER(target)) * Sound bell and alert user with message DO Warnbell DO Show_msg WITH "Record with target data was NOT found." * Return to original record user was viewing GO record_num ENDIF ENDIF RETURN PROCEDURE Findpart PARAMETERS partid * Look up part data using part ID number in Goods database when * function key pressed p_name = SPACE(30) ACTIVATE WINDOW alert CLEAR p_name = LOOKUP(Goods->part_name,TRIM(partid),Goods->part_id) ? "------------ PART CODE LOOKUP ----------" IF .NOT. FOUND("Goods") .OR. "" = TRIM(partid) DO Warnbell ? "Part ID: " + TRIM(partid) AT 2 ? "was NOT FOUND in Goods database." AT 2 ELSE ? "For ID: " + partid AT 2 ? "Part name: " + TRIM(p_name) AT 2 ? "Qty on hand: " + STR(Goods->qty_onhand,4) AT 2 ? "Price: $ " AT 2, Goods->price PICTURE "99,999.99" ENDIF WAIT " .....Press spacebar to continue....." DEACTIVATE WINDOW alert RETURN PROCEDURE Findvend PARAMETERS vendr * Look up vendor name using vendor ID number in Vendor database * when function key pressed v_name = SPACE(30) ACTIVATE WINDOW alert CLEAR v_name = LOOKUP(Vendors->vendor,TRIM(vendr),Vendors->vendor_id) ? "----------- VENDOR CODE LOOKUP -----------" IF .NOT. FOUND("Vendors") DO Warnbell ? "Vendor ID: " + TRIM(vendr) AT 2 ? "was NOT FOUND in Vendors database." AT 2 ELSE ? "VENDOR is: " + TRIM(v_name) AT 2 ? "Phone: " + Vendors->phone AT 2 ? "for ID: " + vendr AT 16 ENDIF WAIT " Press spacebar to continue..." DEACTIVATE WINDOW alert RETURN PROCEDURE Kount * Count and display number of records in database record_num = RECNO() ACTIVATE WINDOW alert @ 0,0 SAY "------------- COUNT RECORDS -------------" @ 2,1 SAY "Counting, please wait..." * Use count if filter is active (subset of records) COUNT TO kount @ 2,1 SAY "There are: " + STR (kount,6) + " records in "+ dbf ? WAIT " Press any key to continue..." DEACTIVATE WINDOW alert * Return to original record (before count) GO record_num RETURN PROCEDURE List_rec * Lists records (in active index order) from current record on * If filter is active, then subset listed lEscape = SET("ESCAPE") = "ON" SET ESCAPE OFF record_num = RECNO() && Store current record position GO TOP ACTIVATE WINDOW lister answer = " " CLEAR @ 0,0 SAY "------------------------- LIST RECORDS " + ; "-------------------------" ; COLOR &c_red. SCAN WHILE .NOT. answer $ "rR" LIST OFF NEXT 10 &list_flds. WAIT "Press spacebar to continue or R to return to " + ; "OPTION MENU." TO answer CLEAR ENDSCAN DEACTIVATE WINDOW lister IF lEscape SET ESCAPE OFF ENDIF * Return to original record (before viewing list) GO record_num RETURN PROCEDURE Look_msg DO CASE && Show proper lookup msg in window CASE similar = .F. && No similar data found @ 1,1 SAY "Entered "+look_name+" ID does not exist in " + ; look_dbf+" database." ? WAIT "No " + look_name + " ID's are similar - " + ; "press R to return to screen." TO answer CASE similar = .T. .AND. listcount > 0 && Similar data found and listed WAIT "Press spacebar to continue list or " + ; "R to return to screen." TO answer CLEAR ENDCASE CLEAR RETURN FUNCTION Lookupid PARAMETERS l_target, look_dbf, look_name, matchchars * During data entry or editing, validate data entered into any of the * fields of customer ID, parts ID, vendor ID, and employee ID by checking * for their existence in their respective databases - list any similar data * by matching the first one or more characters (between entered data and * database). * Note: matchchars = number of initial matching characters for lookup lists * Example: list will show customers whose cust_id's first two characters * match with the entered cust_id's first two characters (matchchars = 2) IF .NOT. SEEK(l_target,(look_dbf)) && Seek data in its respective dbf ACTIVATE WINDOW look DO Warnbell answer = " " similar = .F. SELECT (look_dbf) && Use appropriate dbf for listing GO TOP DO WHILE .NOT. (EOF() .OR. answer $ "rR") * Show list of records having identical initial character(s) * in ID number @ 0,0 SAY "-------- DATA ENTRY ERROR: " + look_name + ; " ID WAS INVALID -------" @ 1,0 SAY " This is a list of similar " + look_name + ; " ID's" ? listcount = 0 DO CASE && Check which database screen in use CASE dbf = "ORDERS" DO CASE && Check which field is being read CASE VARREAD() = "CUST_ID" SCAN FOR LIKE(SUBSTR(l_target,1,matchchars)+"*",cust_id) ; WHILE listcount <= 4 ? cust_id, customer && Display a record listcount = listcount + 1 && Increment list counter similar = .T. && Data found and listed ENDSCAN CASE VARREAD() = "PART_ID" SCAN FOR LIKE(SUBSTR(l_target,1,matchchars)+"*",part_id) ; WHILE listcount <= 4 ? part_id, SUBSTR(part_name,1,21), ; SUBSTR(descript,1,24) listcount = listcount + 1 && Increment list counter similar = .T. && Data found and listed ENDSCAN CASE VARREAD() = "EMP_ID" SCAN FOR LIKE(SUBSTR(l_target,1,matchchars)+"*",emp_id) ; WHILE listcount <= 4 ? emp_id, lastname, firstname && Display a record listcount = listcount + 1 && Increment list counter similar = .T. && Data found and listed ENDSCAN ENDCASE CASE dbf = "GOODS" SCAN FOR LIKE(SUBSTR(l_target,1,matchchars)+"*",vendor_id) ; WHILE listcount <= 4 ? vendor_id, vendor && Display a record listcount = listcount + 1 && Increment list counter similar = .T. && Data found and listed ENDSCAN CASE dbf = "ACCT_REC" SCAN FOR LIKE(SUBSTR(l_target,1,matchchars)+"*",cust_id) ; WHILE listcount <= 4 ? cust_id, customer && Display a record listcount = listcount + 1 && Increment list counter similar = .T. && Data found and listed ENDSCAN ENDCASE DO Look_msg && Show message in window ENDDO DEACTIVATE WINDOW look SELECT 1 && Use original dbf ENDIF RETURN not_valid = .NOT. FOUND((look_dbf)) PROCEDURE Net_err PARAMETERS err_number, plForce * Error procedure for networks DO CASE CASE err_number = 108 * File is in use by another person IF "" <> TRIM(LKSYS(2)) message = " " + dbf + " is in use by: " + LKSYS(2) ELSE message = " " + dbf + " is in use by someone" ENDIF CASE err_number = 109 * Record is locked by another person message = " Record is locked by: " + LKSYS(2) CASE err_number = 110 * File must be in exclusive use for indexing/packing message = "File should be USEd EXCLUSIVE" CASE err_number = 372 .OR. err_number = 373 * File or record is in use by another message = MESSAGE() OTHERWISE message = " Unknown error: " + MESSAGE() ENDCASE DO Warnbell ACTIVATE WINDOW alert CLEAR ? "------------ NETWORK ERROR --------------" ? ? message AT 1 ? "Press spacebar to try again" AT 1 ? " - or press Esc to Quit" AT 1 SET CONSOLE OFF SET ESCAPE OFF WAIT SET ESCAPE ON SET CONSOLE ON net_choice = LASTKEY() && Wait for user to press a key DEACTIVATE WINDOW alert IF net_choice <> 27 && User did not press Esc key * Execute command again that caused network error IF plForce RETURN ELSE RETRY ENDIF ELSE DO Gen_Err WITH ; IIF( ISBLANK( ERROR() ), err_number, ERROR() ), ; IIF( ISBLANK( MESSAGE() ), message, MESSAGE() ) ENDIF RETURN PROCEDURE Printout * Print report or label DO CASE CASE reportype = "LISTING" REPORT FORM &dbf. CASE reportype = "LABELS" LABEL FORM &dbf. CASE reportype = "CUSTOM" DO &rpt_name. ENDCASE GO record_num RETURN PROCEDURE Prt_menu * Display menu of print options msg_num = "Enter a number" msg_logic = "Enter a Y or N" msg_enum = "Press spacebar for other options" * Set up default values to print variables for reports loffset = 0 lmargin = 0 rmargin = 80 indent = 4 plength = 66 && 60 - HP laserjet printer STORE 1 TO pspacing, pbpage, pcopies pepage = 9999 peject = "NONE " STORE .F. TO pwait, pquality ppitch = "PICA " * ACTIVATE WINDOW lister CLEAR @ 0, 0 SAY "------------------------- PRINT MENU " + ; "---------------------------" COLOR &c_red. @ 2, 1 SAY "Page settings:" @ 3, 1 SAY "=============" @ 4, 1 SAY "Offset from left " GET loffset ; PICTURE "99" MESSAGE msg_num @ 5, 1 SAY "Left margin " GET lmargin ; PICTURE "99" MESSAGE msg_num @ 6, 1 SAY "Right margin " GET rmargin ; PICTURE "99" MESSAGE msg_num @ 7, 1 SAY "Indentation " GET indent ; PICTURE "99" MESSAGE msg_num @ 8, 1 SAY "Page length " GET plength ; PICTURE "99" MESSAGE msg_num @ 9, 1 SAY "Spacing " GET pspacing ; PICTURE "9" RANGE 1,3 MESSAGE msg_num @ 2,26 SAY "Print settings:" @ 3,26 SAY "==============" @ 4,26 SAY "Begin printing on page " GET pbpage ; PICTURE "999" MESSAGE msg_num @ 5,26 SAY "End printing on page " GET pepage ; PICTURE "9999" MESSAGE msg_num @ 6,26 SAY "Number of copies " ; GET pcopies PICTURE "999" MESSAGE msg_num @ 7,26 SAY "Eject paper " GET peject ; PICTURE "@M BEFORE,AFTER,BOTH,NONE" MESSAGE msg_enum @ 8,26 SAY "Wait between pages " GET pwait ; PICTURE "Y" MESSAGE msg_logic @ 9,26 SAY "Pitch " GET ppitch ; PICTURE "@M DEFAULT,PICA,ELITE,CONDENSED" MESSAGE msg_enum @ 10,26 SAY "Quality print " GET pquality ; PICTURE "Y" MESSAGE msg_logic @ 12, 1 SAY "Please enter desired settings; press Esc to cancel" READ DEACTIVATE WINDOW lister IF LASTKEY() = 27 && If Escaped presses ll_esc = .T. ELSE ll_esc = .F. * Assign values to system variables _ploffset = loffset _lmargin = lmargin _rmargin = rmargin _indent = indent _plength = plength _pspacing = pspacing _pbpage = pbpage _pepage = pepage _pcopies = pcopies _peject = peject _pwait = pwait IF PRINTSTATUS() _ppitch = ppitch ENDIF _pquality = pquality ENDIF SET COLOR TO &c_standard. RETURN PROCEDURE Rest_env IF TYPE( "gl_MainMenu" ) = "L" RETURN ENDIF * Restore database environment SET COLOR TO &c_standard. SET SCOREBOARD &scor. SET DELIMITERS &deli. SET HELP &hellp. SET ESCAPE &esca. SET DELETED &delee. SET HEADING &head. SET SAFETY &safe. SET EXACT &exac. SET BELL &bell. SET NEAR &near. * Reset colors to system defaults DO Colo_rese SET CLOCK &clock. SET STATUS &stat. SET TALK &talk. RETURN PROCEDURE Sav_data * If data is new: append record currently in memory to database. * If edited/modified data: replace database record with memory fields. IF NodShake( " ; Save this data to disk? ", ; 9, 26, 2, 29, .F. ) IF lAddNew APPEND BLANK record_num = RECNO() ELSE record_num = RECNO() ENDIF * Replace database file fields with contents of memory variables DO Repl_fld ELSE * Do not save data to disk, return to original record GO record_num ENDIF UNLOCK RETURN PROCEDURE Set_env IF TYPE( "FILTERS_ON" ) = "L" filters_on = .F. ENDIF IF TYPE( "gl_MainMenu" ) = "L" RETURN && Setup already done by BUSINESS.PRG ENDIF PUBLIC talk && First set TALK OFF IF SET( "TALK" ) = "ON" SET TALK OFF talk = "ON" ELSE talk = "OFF" ENDIF PUBLIC c_Save c_save = SET( "ATTRIBUTES" ) PUBLIC c_standard, c_data, c_fields, c_popup, c_alert, c_list PUBLIC c_red, c_blue, c_yellow, c_yelowhit, c_green, c_blink * Set color variables for applications IF ISCOLOR() * Color video card/monitor c_standard = "W/B,BG+/R,B" c_data = "B/W,R/BG,B" c_fields = "B/BG" c_popup = "B/W,GR+/R" c_alert = "GR+/R,B/W,R/G" c_list = "W+/G,GR+/B,GR+/GR" c_red = "R/W" c_blue = "B/W" c_yellow = "GR+/B" c_yelowhit = "GR+/W" c_green = "G/W" c_blink = "GR+*/B" ELSE * Monochrome video card/monitor STORE "W+/N" TO c_standard, c_data, c_popup, c_alert, c_list STORE "W" TO c_red, c_blue, c_yellow, c_yelowhit, c_green, c_fields c_blink = "W+*/N,N/W" ENDIF SET COLOR OF MESSAGES TO &c_blue. SET COLOR TO &c_standard. * Configure working environment * Store SET environment in case started from Control Center or dot prompt PUBLIC scor, deli, hellp, clock, esca, delee, head, stat, safe PUBLIC exac, bell, near scor = SET("SCOREBOARD") deli = SET("DELIMITERS") hellp = SET("HELP") clock = SET("CLOCK") esca = SET("ESCAPE") delee = SET("DELETED") head = SET("HEADING") stat = SET("STATUS") safe = SET("SAFETY") exac = SET("EXACT") bell = SET("BELL") near = SET("NEAR") * Set database environment for applications SET SCOREBOARD off SET DELIMITERS off SET HELP off SET CLOCK off SET ESCAPE on && off SET DELETED on SET HEADING on SET STATUS off SET SAFETY off SET TALK off SET EXACT off SET BELL off SET NEAR off PUBLIC erased, not_valid, rec_is_dup, filters_on, lookup_ok, choice PUBLIC record_num, net_choice PUBLIC target, look_dbf, matchchar, scanfield * Logical variables used for status flags STORE .F. TO erased, not_valid, rec_is_dup, filters_on lookup_ok = .T. * Other variables STORE "" TO choice,subset STORE 0 TO record_num, net_choice ************************************************ * Setup error processing if running on a network IF NETWORK() * Network programming assumes databases have been CONVERTed SET EXCLUSIVE off ON ERROR DO Net_err WITH ERROR() * Retry a reasonable amount of time (depends on computer) SET REPROCESS TO 3 ELSE ON ERROR DO Gen_err WITH ERROR(), MESSAGE() ENDIF RETURN PROCEDURE Gen_Err PARAMETERS pn_Error, pc_Message DO Err_Box WITH pc_Message gl_Error = .T. ON ERROR ON KEY LABEL F1 ON KEY LABEL F9 ON KEY LABEL F10 RETURN TO MASTER * IF TYPE( "gl_MainMenu" ) <> "L" * DO Rest_env && environment back. * ON ERROR * ON KEY LABEL F1 * ON KEY LABEL F9 * ON KEY LABEL F10 * CLEAR ALL * CLOSE ALL * CLEAR * CANCEL * ENDIF *RETURN TO MASTER PROCEDURE Sho_look PARAMETERS db * Show lookup function keys on screen (if available for database) DO CASE CASE db = "EMPLOYEE" .OR. db = "CUST" .OR. db = "VENDORS" look_txt = "Press F9 to look up Area code" CASE db = "GOODS" look_txt = "Press F9 to look up Vendor name and phone" CASE db = "ORDERS" look_txt = "Press F9 to look up Cust data; F10 for Part ID data" CASE db = "ACCT_REC" look_txt = "Press F9 to look up Customer name and phone" ENDCASE @ 0,0 SAY look_txt COLOR &c_blink. i = INKEY(1) && Blink for 1 second @ 0,0 SAY look_txt COLOR &c_yellow. RETURN PROCEDURE Show_msg PARAMETERS u_message _wrap = .T. ACTIVATE WINDOW alert @ 1,0 SAY u_message ? WAIT " Press spacebar to continue..." DEACTIVATE WINDOW alert RETURN PROCEDURE Skip_rec PARAMETERS skipno * Skip forward or backward in database by one or more records DO CASE CASE skipno = 1 && Skip to next record (in active index order) IF .NOT. EOF() SKIP ENDIF CASE skipno = -1 && Skip to previous record (in active index order) IF .NOT. BOF() SKIP -1 ENDIF CASE skipno = 0 * Skip records - to goto/view records ahead of or behind current record numb_2skip = 0 ACTIVATE WINDOW alert @ 0,0 SAY "-------- SKIP NUMBER OF RECORDS ----------" @ 2,1 SAY "How many records do you want to skip?" @ 3,0 SAY " (Example: 15 or -5) ? " ; GET numb_2skip PICTURE "9999" ; MESSAGE "Enter positive no. to go forward " + ; "or negative no. to go backward" READ DEACTIVATE WINDOW alert IF .NOT. (BOF() .AND. numb_2skip < 0) .OR. (EOF() .AND. numb_2skip > 0) SKIP numb_2skip ENDIF ENDCASE * Check whether record pointer hits beginning or end of file DO CASE CASE EOF() GO BOTTOM && reset record pointer if EOF DO Show_msg WITH " Bottom record in " + dbf + " database" CASE BOF() DO Show_msg WITH " Top record in " + dbf + " database" ENDCASE RETURN PROCEDURE Warnbell PRIVATE mwrap mwrap = _wrap && Save _wrap value _wrap = .F. * Sound unique warning for errors SET BELL TO 880,4 ?? CHR(7) SET BELL TO 1400,4 ?? CHR(7) SET BELL TO 880,4 ?? CHR(7) SET BELL TO _wrap = mwrap RETURN FUNCTION NodShake PARAMETERS pc_mssg, pn_up, pn_left, pn_height, pn_max, pl_dflt_no *--------------------------------------------------------------------------- * NAME * NodShake * * DESCRIPTION * Accepts a YES/NO response from user * * SYNOPSIS * DO _NodShake WITH pc_mssg, pn_up, pn_left, pn_height, pn_max, pl_dflt_no * * PARAMETERS * pc_mssg: dialog box message * pn_up: upper corrdinate of dialog box * pn_left: left coordinate of dialog box * pn_height: height of dialog box * pn_max: maximum width of a line in message * pl_dflt_no: flag indicating if default pad highlighted should be "NO" * * EXAMPLE * pl_set = _NodShake( pc_vermssg, 13, 25, 2, 28, .T. ) * * LIMITATIONS * None * * DEPENDENCIES * None *--------------------------------------------------------------------------- PRIVATE ll_ans, ll_console, ll_wrapset, ln_pspset ll_console = SET( "CONSOLE" ) = "OFF" SET CONSOLE ON ll_wrapset = _wrap ln_pspset = _pspacing _wrap = .F. _pspacing = 1 DEFINE WINDOW NodShake DOUBLE ; FROM pn_up, pn_left TO pn_up + pn_height + 4, pn_left + pn_max + 1 DEFINE MENU NodShake DEFINE PAD Yes OF NodShake PROMPT "Yes" ; AT pn_height + 1, (pn_max - 12) / 2; MESSAGE "Select option and press ENTER, or press first letter" + ; " of desired option" ON SELECTION PAD Yes OF NodShake DEACTIVATE MENU DEFINE PAD No OF NodShake PROMPT "No" ; AT pn_height + 1, (pn_max - 12) / 2 + 10 ; MESSAGE "Select option and press ENTER, or press first letter" + ; " of desired option" ON SELECTION PAD No OF NodShake DEACTIVATE MENU ACTIVATE WINDOW NodShake CLEAR ? @ 0, 0 ?? pc_mssg FUNCTION ";" ON KEY LABEL Y KEYBOARD "{Alt-Y}{13}" ON KEY LABEL N KEYBOARD "{Alt-N}{13}" IF pl_dflt_no KEYBOARD "{Alt-N}" ENDIF ON KEY LABEL RIGHTARROW ON KEY LABEL LEFTARROW ACTIVATE MENU NodShake ON KEY LABEL Y ON KEY LABEL N IF PAD() = "YES" ll_ans = .T. ELSE ll_ans = .F. ENDIF RELEASE WINDOW NodShake RELEASE MENU NodShake _wrap = ll_wrapset _pspacing = ln_pspset IF ll_console SET CONSOLE OFF ENDIF RETURN ll_ans *-- EOF: NodShake( pc_mssg, pn_up, pn_left, pn_height, pn_max, pl_dflt_no ) PROCEDURE Err_Box PARAMETERS pc_msg *---------------------------------------------------------------------------- * NAME * Err_Box - Display an error box * * SYNOPSIS * DO Err_Box WITH <pc_msg> * * DESCRIPTION * _Err_Box will display the <pc_msg> string in a box and prompt the * user to press any key to continue processing. _Err_Box will display * the message based on the length of <pc_msg>. * * PARAMETERS * pc_msg - the error message to display in the box. If the length is * greater than 76, the trailing part is chopped off. * * EXAMPLE * DO Err_Box WITH "Incorrect window size" * Displays the message in a window as follows at row 9 on the screen: * +------------------------------+ * | | * | Incorrect window size | * | | * | Press any key to continue... | * | | * +------------------------------+ * Note that the width of the window will increase to accommodate a longer * message string. * * LIMITATIONS * Truncates the message after 76 characters. Assumes an 80 character * wide screen. Looks best with SET CURSOR OFF. * *---------------------------------------------------------------------------- PRIVATE lc_anykey, lc_msg, lc_msglen, lc_win, ln_press, ln_width, ll_trap,; ll_escape lc_anykey = [Press any key to continue...] ln_press = LEN( lc_anykey ) lc_win = WINDOW() && Currently activated window if any lc_msg = LTRIM( RTRIM( pc_msg ) ) && Trimmed message ln_msglen = LEN( lc_msg ) && Trimmed length of message ln_width = 0 && Width of display area in window. ll_escape = SET("ESCAPE") = "ON" SET ESCAPE OFF *-- Determine the width needed for the window: IF ln_msglen <= ln_press ln_width = ln_press ELSE *-- Make sure the message fits in the window: IF ln_msglen > 76 lc_msg = LEFT( lc_msg, 76 ) ln_msglen = 76 ENDIF ln_width = ln_msglen ENDIF DEFINE WINDOW _err_box FROM 9, ((76 - ln_width) + .5) / 2 ; TO 15, (ln_width + 83) / 2 DOUBLE ln_width = ( ln_width + 2 ) *-- Display the message and prompt to the window and wait for a key press ACTIVATE WINDOW _err_box @ 1, ( ln_width - ln_msglen ) / 2 SAY lc_msg @ 3, ( ln_width - ln_press ) / 2 SAY lc_anykey SET CONSOLE OFF && For mouse click recognition WAIT SET CONSOLE ON *-- Clean up the window display and reactivate the previous window RELEASE WINDOW _err_box IF ISBLANK( lc_win ) ACTIVATE SCREEN ENDIF IF ll_escape SET ESCAPE ON ELSE SET ESCAPE OFF ENDIF RETURN *-- EOP: Err_Box WITH pc_msg PROCEDURE Colo_rese PRIVATE old_color, c_messages, c_titles, c_box, c_info, c_fields old_color = c_save * Set the Primary colors SET COLOR TO SET COLOR TO &old_color. CLEAR * Remove primary colors and start at the secondary colors old_color = STUFF(old_color, 1, AT("&",old_color)+2, "") comma = AT(",",old_color) c_messages = LEFT(old_color, comma-1) && Get MESSAGES color old_color = STUFF(old_color, 1, comma, "") && Remove MESSAGES color comma = AT(",",old_color) c_titles = LEFT(old_color, comma-1) && Get TITLES color old_color = STUFF(old_color, 1, comma, "") && Remove TITLES color comma = AT(",",old_color) c_box = LEFT(old_color, comma-1) && Get BOX color old_color = STUFF(old_color, 1, comma, "") && Remove BOX color comma = AT(",",old_color) c_info = LEFT(old_color, comma-1) && Get INFORMATION color old_color = STUFF(old_color, 1, comma, "") && Remove INFORMATION color comma = AT(",",old_color) c_fields = old_color && Get FIELDS color SET COLOR OF MESSAGES TO &c_messages. SET COLOR OF TITLES TO &c_titles. SET COLOR OF BOX TO &c_box. SET COLOR OF INFORMATION TO &c_info. SET COLOR OF FIELDS TO &c_fields. RETURN **************************** END OF LIBRARY.PRG ******************************