Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a031 / samples.exe / LIBRARY.PRG < prev next >

Wrap

Text File | 1992-03-10 | 43.3 KB | 1,254 lines

****************************************************************************** * PROGRAM NAME: LIBRARY.PRG * LIBRARY OF PROCEDURES COMMON TO ALL BUSINESS PROGRAMS * SAMPLE BUSINESS APPLICATION PROGRAM * LAST CHANGED: 06/20/90 8:00AM * WRITTEN BY: Borland International Inc. ****************************************************************************** PROCEDURE Add_new * Add new record to database file * Erase previous record number from screen @ 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. 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. 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 ON READERROR 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 * Now, put the READ error redirection back. ON READERROR 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 ERROR 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) IF lookup_ok DO Sho_look WITH dbf ENDIF record_num = RECNO() * Load data from record into memory variables DO Load_fld IF NETWORK() && Edit data in a network ready = .F. DO WHILE .NOT. ready IF CHANGE() * If the record was changed by somone since user first accessed it DO Warnbell GO RECNO() && Updates database record with changed data IF DELETED() DO Show_msg WITH "ALERT - Record has been deleted" SKIP DO Show_data RETURN && Exit to OPTION MENU - quit edit ELSE DO Show_msg WITH ; "Data has been changed-screen shows revised data" DO Load_fld && Updates memvars with database data ENDIF ENDIF DO Get_data READ && Edit data * Test if another user changed data while editing this data ready = .NOT. CHANGE() && DO loop will repeat if CHANGE() is .F. ENDDO ELSE && Non-network edit DO Get_data READ && Edit data ENDIF ***** * 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 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 ll_ans = NodShake( " ; GROUP into SUBSET (Filter) ;" + ; " Subset is currently selected. ;" + ; " Turn Filter off?", ; 7, 22, 4, 35, .F. ) ELSE *-- Filter window - to turn on filter ll_ans = NodShake( " ; GROUP into SUBSET (Filter) ;" + ; " Select temporary subset of data ;" + ; " by entering filter condition(s) ;" + ; " Proceed?", ; 7, 21, 5, 37, .F. ) ENDIF IF .NOT. ll_ans && Do not change filter status RETURN TO Barpop && Do not finish processing Filter proceedure choice = "N" ELSE choice = "Y" ENDIF RETURN PROCEDURE Findcode PARAMETERS acity * Look up area code for phone number - by city i = INKEY() 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 ? i= INKEY(3) && Display for 3 seconds DEACTIVATE WINDOW alert RETURN PROCEDURE Findcust PARAMETERS custid * Look up customer from customer ID i= INKEY() 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 i = INKEY() 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 i = INKEY() 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) IF filters_on COUNT TO kount ELSE * Use reccount if filter is not active (all records) kount = RECCOUNT() ENDIF @ 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 record_num = RECNO() && Store current record position 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 * 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 * 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 net_choice = INKEY(0) && 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 RETRY 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 * Restore database environment SET COLOR TO &c_standard. SET SCOREBOARD &scor. SET DELIMITERS &deli. SET HELP &hellp. SET CLOCK &clock. SET ESCAPE &esca. SET DELETED &delee. SET HEADING &head. SET STATUS &stat. SET SAFETY &safe. SET EXACT &exac. SET BELL &bell. SET NEAR &near. * Reset colors to system defaults DO Colo_rese 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 PROMPT() = " Add record" && Add new blank record APPEND BLANK 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 RETURN PROCEDURE Set_env PUBLIC talk && First set TALK OFF talk = SET("TALK") SET TALK off 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,N/W" 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 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 ENDIF ************************************************ * Turns off VALID failure's (PRESS SPACE) ON READERROR ?? RETURN 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 **************************** END OF LIBRARY.PRG ******************************