Power-Programmierung/CD1.mdf/xbase/library/clipper/window/clipwin/wn_add.prg

Text File | 1988-03-13 | 13KB | 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