Source Code 1992 March

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

/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / clipper / clipwind.arc / WN_ADD.PRG < prev next >

Wrap

Text File | 1988-03-14 | 12.8 KB | 326 lines

****************************************************************************** ***** Author: Jim Holley ***** ***** Date : 07/27/87 ***** ***** Comments: ***** ***** This is an example showing some features and uses of the Windows ***** ***** For Clipper Library. This routine performs a windowed database ***** ***** view, with an add routine. The add routine is unique in operation. ***** ***** Special attention should be paid to this routine. The purpose of ***** ***** this routine is to show how an operator can add a record to the ***** ***** database if the information required can not be found through use ***** ***** of the Windows For Clipper functions. ***** ***** The database used is the Customer.DBF file included with the ***** ***** Windows For Clipper package. ***** ***** This program is being release to the Windows For Clipper Library ***** ***** owners. You may use any portion of it anyway you see fit. ***** ****************************************************************************** ***** this is the controller code ***** SET SCOREBOARD OFF SET CONFIRM ON ***** clear the screen ***** CLEAR ***** initialize window ***** start_col = 8 start_row = 12 num_col = 60 num_rows = 10 select_wn = _SINIT_WN(start_col, start_row, num_col, num_rows) ***** set window border character ***** _SST_WNBC(select_wn, 177) ***** open the database ***** USE customer ***** set up infinite loop ***** DO WHILE .T. ***** draw window on the screen ***** _SDRW_WN(select_wn) ***** write some text ***** @ 00,10 SAY "The following will simulate an operator searching a database" @ 01,10 SAY "for specific information. If the information cannot be" @ 02,10 SAY "be found, the operator presses the escape key. At that" @ 03,10 SAY "point, a routine will ask the operator if he/she wishes" @ 04,10 SAY "to add information. The program will take action based" @ 05,10 SAY "on the operators answer. If the operator answers yes, an add" @ 06,10 SAY "routine will be called to get the information needed." @ 07,10 SAY "This is not an example of something that should be done" @ 08,10 SAY "in a real life situation. I don't advise any one to do this" @ 09,10 SAY "unless proper precautions have been made to guard against" @ 10,10 SAY "data coruption." @ 11,22 SAY "PRESS ANY KEY TO BEGIN SIMULATION." INKEY(0) ***** show the customer info in the window ***** IF show_info() = 0 response = option_wn("Would You Like To Add Information", "YN") IF response = "Y" DO add_info WITH start_row, num_rows, start_col ELSE EXIT ENDIF ENDIF GO TOP ***** erase the window ***** _SWNERASE(select_wn) ENDDO RETURN ******************************************************************** ***** This function opens a window in the center of the screen ***** ***** and asks the question specified. It will validate the ***** ***** response based upon the valid answer parameter. ***** ******************************************************************** FUNCTION option_wn PARAMETER question, vald_ans PRIVATE qlen, wn_col, ans_col, wn_width, ans_wn, answer ***** be sure all parameters were passed ***** IF PCOUNT() <> 2 ***** invalid number of parameters, return null ***** RETURN('') ENDIF ***** compute the windows width ***** wn_width = LEN(question) + 4 ***** compute the window starting column ***** wn_col = INT((80 - wn_width) / 2) ***** compute the answer column ***** ans_col = wn_col + wn_width - 1 ***** initialize the window ***** ans_wn = _SINIT_WN(wn_col, 11, wn_width, 1) ***** set window border character ***** _SST_WNBC(ans_wn, 201) ***** draw the window ***** _SDRW_WN(ans_wn) ***** write the question to the window ***** _SWTE_TXT(ans_wn, ' ' + question) ***** initialize the answer variable ***** answer = ' ' ***** get the answer ***** @ 12, ans_col GET answer PICTURE "!" VALID(answer $vald_ans) READ ***** remove the window ***** _SREM_WN(ans_wn) ***** return the operators answer ***** RETURN(answer) ***** all procedures and functions follow ***** FUNCTION show_info ***** declare private variables ***** private srec ***** initialize variables ***** srec = 0 ***** stuff the keyboard with various keystrokes ***** KEYBOARD CHR(1) + CHR(6) + CHR(5) + CHR(24) + CHR(3) + CHR(18) + CHR(27) ***** now call the _wn_dbf function ***** srec = _WN_DBF(select_wn, "custno", "comp_name", "comp_addr1") ***** return ***** RETURN(srec) PROCEDURE add_info PARAMETER a_rows, b_rows, c_rows private num_flds, scroll_rows, cnt1, cnt2, fldname, fldtype, fldsize private targ_row, targ_col, out1, out2, out3, out4, out5, out6, dummy ***** init dummy to a space ***** dummy = ' ' ***** get the number of fields in the database ***** num_flds = FCOUNT() ***** calculate target row for reads ***** targ_row = a_rows + b_rows ***** calculate target column for reads ***** targ_col = c_rows + 3 ***** calculate number or rows to redisplay ***** scroll_rows = b_rows - 1 ***** declare arrays with the same number of ***** ***** elements as there are fields ***** declare input_arr[num_flds] declare output_arr[num_flds] declare pict_arr[num_flds] ***** This step will initialize an array to the type and ***** ***** and size of the corresponding fields in the database ***** ***** in use. It also initializes an array containing the ***** ***** code necessary to display any type of field using the ***** ***** Windows For Clipper routine _SWTE_RECS(). ***** ***** This step also selects a picture to use based on the field ***** ***** type. If character, it will use the "@!" picture function, if ***** ***** numeric it will use "999.999". The number of digits before ***** ***** and after the decimal place will be accurate according to the ***** ***** fields definition within the database. If a date field, an ***** ***** "@D" picture will be used. If logical, an "L" picture will be used. ***** ***** Please NOTE: The picture building portion of this step may be ***** ***** modified to your taste but, the numeric fields need to be formatted ***** ***** because transfering to a memory variable or array causes the ***** ***** data in question to become 14 characters in length. ***** ***** PLEASE NOTE that MEMO fields are not supported. ***** ***** MEMO fields should be handled in a seperate routine. ***** ***** If you need this routine to support memo fields and ***** ***** have a seperate module to edit the memo field, you can ***** ***** can add the following case statement: ***** CASE fldtype = "M" * <<<<< initialize a memo field. NOTE: The memo field is initialized * <<<<< to a maximum size of 5000 bytes. This is in accordance with * <<<<< dBASE III +. You may change this size as desired. ***** input_arr[cnt1] = SPACE(5000) ***** output_arr[cnt1] = fldname ***** The memo edit routine should be called after all other information ***** ***** has been processed. This routine can be made generic, but the code ***** ***** code to do so is not presented here. If this code is desired, you ***** ***** may call me and we can work out the coding techniques. ***** FOR cnt1 = 1 TO num_flds fldname = fieldname(cnt1) fldtype = TYPE("&fldname") IF fldtype = "C" fldsize = LEN(&fldname) ELSE fldsize = 0 ENDIF DO CASE CASE fldtype = "C" ***** initialize character type element ***** input_arr[cnt1] = SPACE(fldsize) output_arr[cnt1] = fldname pict_arr[cnt1] = ["@!"] CASE fldtype = "N" picttemp = "99999999999999" ***** initialize a numeric element ***** fldval = str(&fldname) ***** is there a decimal point ***** IF AT('.', fldval) <> 0 ***** yes, get the length of the field before the decimal ***** before_dec = AT('.',fldval) - 1 ***** now figure out how many digits past the decimal ***** after_dec = LEN(SUBSTR(fldval,AT('.',fldval) + 1)) ***** build the picture string ***** fldpict = ["] + SUBSTR(picttemp, 1, before_dec) + [.] + SUBSTR(picttemp,1,after_dec) + ["] input_arr[cnt1] = 0.0 pict_arr[cnt1] = fldpict ELSE ***** no decimal point. Just store a 0 ***** input_arr[cnt1] = 0 pict_arr[cnt1] = ["] + SUBSTR(picttemp, 1, LEN(fldval)) + ["] ENDIF output_arr[cnt1] = "STR(" + fldname + ")" CASE fldtype = "L" ***** initialize a logical element ***** input_arr[cnt1] = .F. output_arr[cnt1] = "IF(" + fldname + ",'Yes','No')" pict_arr[cnt1] = ["L"] CASE fldtype = "D" ***** initialize a date element ***** input_arr[cnt1] = CTOD(" / / ") output_arr[cnt1] = "CTOD(" + fldname + ")" pict_arr[cnt1] = ["@D"] ENDCASE NEXT ***** move to the bottom last record in the database ***** GO BOTTOM ***** make sure we are at the end of file ***** SKIP ***** main control loop ***** FOR cnt1 = 1 TO num_flds ***** back up scroll_rows records ***** SKIP (scroll_rows * -1) ***** store the contents of the output array into regular ***** ***** memory variable because arrays have difficulty ***** ***** with macro expansion. The subscript has to be check ***** ***** to be sure that we do not exceed the array's size. ***** ***** The field type has to be checked also, to be sure we ***** ***** don't process a memo field. ***** IF cnt1 <= num_flds IF TYPE(fieldname(cnt1)) <> "M" out1 = output_arr[cnt1] ELSE out1 = "dummy" ENDIF ELSE out1 = "dummy" ENDIF IF (cnt1 + 1) <= num_flds IF TYPE(fieldname(cnt1 + 1)) <> "M" out2 = output_arr[cnt1 + 1] ELSE out2 = "dummy" ENDIF ELSE out2 = "dummy" ENDIF IF (cnt1 + 2) <= num_flds IF TYPE(fieldname(cnt1 + 2)) <> "M" out3 = output_arr[cnt1 + 2] ELSE out3 = "dummy" ENDIF ELSE out3 = "dummy" ENDIF IF (cnt1 + 3) <= num_flds IF TYPE(fieldname(cnt1 + 3)) <> "M" out4 = output_arr[cnt1 + 3] ELSE out4 = "dummy" ENDIF ELSE out4 = "dummy" ENDIF IF (cnt1 + 4) <= num_flds IF TYPE(fieldname(cnt1 + 4)) <> "M" out5 = output_arr[cnt1 + 4] ELSE out5 = "dummy" ENDIF ELSE out5 = "dummy" ENDIF IF (cnt1 + 5) <= num_flds IF TYPE(fieldname(cnt1 + 5)) <> "M" out6 = output_arr[cnt1 + 5] ELSE out6 = "dummy" ENDIF ELSE out6 = "dummy" ENDIF ***** loop to redisplay info ***** ***** clear the window ***** _SCLS_WN(select_wn) FOR cnt2 = 1 TO scroll_rows ***** write the field information by using the _swte_recs function ***** ***** no scroll value is needed because we will reference the ***** ***** field at the current array position and then forward. ***** ***** Also, only six fields are presented at a time. This should ***** ***** be enough to let the operator know what is expected next. ***** ***** DO not allow display of memo fields. This will cause strange ***** ***** results using the _SWTE_RECS() function. ***** IF TYPE(fieldname(cnt1)) <> "M" _SWTE_RECS(select_wn, &out1, &out2, &out3, &out4, &out5, &out6) ENDIF SKIP NEXT ***** print field name on window border so operator will ***** ***** know what to enter ***** @ 12,11 SAY fieldname(cnt1) + SPACE(10 - LEN(fieldname(cnt1))) ***** okay, now ready for operator to input data ***** ***** read all but memo fields ***** IF TYPE(fieldname(cnt1)) <> "M" ***** get the picture string ***** pic_format = pict_arr[cnt1] @ targ_row, targ_col GET input_arr[cnt1] PICTURE &pic_format READ ENDIF NEXT ***** This next section is not active, but the code is in place ***** ***** so that you may see it. If this routine is used in your ***** ***** application, some data formating (such as converting to UPPER CASE) ***** ***** may be needed before allowing the information to go into the ***** ***** database. ***** ***** add a blank record ***** APPEND BLANK ***** update field info with data ***** FOR cnt1 = 1 to num_flds fldname = fieldname(cnt1) ***** don't do anything with memo fields ***** IF TYPE(fieldname(cnt1)) <> "M" REPLACE &fldname WITH input_arr[cnt1] ENDIF NEXT ***** return ***** RETURN