home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a013 / 1.ddi / SOURCE.EXE / F_SELVAL.PRG < prev    next >
Encoding:
Text File  |  1991-01-25  |  11.0 KB  |  433 lines
  1. *****************************************************************
  2. FUNCTION SELVALUE
  3. *****************************************************************
  4.  
  5. * Creates a temporary file based on operator selections
  6.  
  7. * Copyright(c) 1991 -- James Occhiogrosso
  8.  
  9. # include 'inkey.ch'
  10. # include 'setcurs.ch'
  11. # include 'dl_keys.ch'
  12. # define MAX_NDX 5
  13.  
  14. LOCAL old_cursor := SETCURSOR(SC_NONE)
  15. LOCAL mvar, selvar
  16.  
  17. PRIVATE aborted, counter, db_file, fieldcnt, filt_strg,         ;
  18.         filt_word, fldnames, hilow, ndx_file, ndx_strg,         ;
  19.         ndx_word, num_flds, num_sels, pass, temp_file, var_prefix
  20.  
  21. PARAMETERS say_proc, get_proc
  22. PRIVATE bSayProc := {|| &say_proc() }, bGetProc := {|| &get_proc()}
  23.  
  24.  
  25. * Initialize main variables
  26. db_file = ALIAS()
  27. aborted = .F.
  28.  
  29. * Create unique temporary DBF file
  30. temp_file = TEMPFILE("DBF")
  31.  
  32. IF EMPTY(temp_file)
  33.     RETURN('')
  34. ENDIF
  35.  
  36. * Display the screen
  37. CLEAR
  38. EVAL(bSayProc)
  39.  
  40. * Outer loop is restarts only on an entry error
  41. DO WHILE .T.
  42.     SELECT (db_file)
  43.     * Initialize inner loop variables
  44.     filt_strg := ndx_strg := hilow := ''
  45.     counter := pass := 1
  46.     num_flds := 0
  47.  
  48.     DO WHILE pass <= 2
  49.         * Load array with field names
  50.         fieldcnt = FCOUNT()
  51.         fldnames := ARRAY(fieldcnt)
  52.         AFIELDS(fldnames)
  53.  
  54.         CLRVARS()
  55.         IF pass = 1
  56.             hilow = ' LOW '
  57.             filt_word = 'lofilt'
  58.             var_prefix = 'lo_'
  59.             filt_strg = ''
  60.         ELSE
  61.             hilow = ' HIGH '
  62.             filt_word = 'hifilt'
  63.             var_prefix = 'hi_'
  64.         ENDIF
  65.  
  66.         * Get selection values from operator
  67.         TONE(2000,1)
  68.         GETSEL(fldnames)
  69.         
  70.         * Get number of selection field entries
  71.         num_flds = counter - 1
  72.  
  73.         IF num_flds != 0
  74.             * Fill array with selections
  75.             num_sels := ARRAY(num_flds)
  76.             ACOPY(fldnames, num_sels, 1, num_flds, 1)
  77.  
  78.             * Create lo/hi filt1 thru filt "n" variables,
  79.             * each containing 15 parses (4 fields)
  80.  
  81.             MAKFILT(num_sels)
  82.  
  83.             * Create lo_mvar and hi_mvar variables
  84.             FOR counter = 1 TO num_flds
  85.                 mvar = 'm' + num_sels[counter]
  86.                 selvar = var_prefix + num_sels[counter]
  87.                 &selvar = &mvar
  88.             NEXT
  89.             filt_strg = IF(pass = 1, filt_strg + ' .AND. ', ;
  90.                            filt_strg)
  91.             RELEASE num_sels
  92.         ELSE
  93.             * No selections entered by operator
  94.             IF pass = 2
  95.                 * If second pass remove ' .AND. '
  96.                 filt_strg = SUBSTR(filt_strg, 1, ;
  97.                             LEN(filt_strg) - 7)
  98.             ENDIF
  99.         ENDIF
  100.         pass++
  101.     ENDDO
  102.  
  103.     * Get operator's desired index fields
  104.     TONE(2000,1)
  105.     MAKNDX(fldnames)
  106.     IF aborted
  107.         EXIT
  108.     ENDIF
  109.     @ 20, 0 CLEAR TO 24, 79
  110.     CENTERON(22, 'Creating report file. Please wait. ')
  111.     IF LEN(filt_strg) > 0
  112.         COPY TO (temp_file) FOR &filt_strg
  113.     ELSE
  114.         COPY TO (temp_file)
  115.     ENDIF
  116.  
  117.     USE (temp_file) NEW
  118.  
  119.     * No records in temporary file, query operator
  120.     IF RECCOUNT() = 0
  121.         ?? CHR(7)
  122.         CENTERON(24, 'No records selected. ' + ;
  123.                      'Do you want to try again? Y/N   ')
  124.         ans = .T.
  125.         @ 24, COL() -2 GET ans PICTURE 'Y'
  126.         READ
  127.         IF ans
  128.             * Repaint screen if operator wants to reenter
  129.             EVAL(bSayProc)
  130.             @ 20, 0 CLEAR TO 24, 79
  131.  
  132.             * Close the temporary file and loop to beginning
  133.             USE
  134.             LOOP
  135.         ELSE
  136.             * Otherwise, return with aborted true
  137.             aborted = .T.
  138.             EXIT
  139.         ENDIF
  140.     ELSE
  141.         * Create index.
  142.         @ 24, 0
  143.         CENTERON(22, 'Indexing report file. ' + ;
  144.                      LTRIM(STR(LASTREC())) + ' records.')
  145.  
  146.         ndx_file = SUBSTR(temp_file,1,8)
  147.         INDEX ON &ndx_strg TO (ndx_file)
  148.     ENDIF
  149.     EXIT
  150. ENDDO WHILE .T.
  151.  
  152. SETCURSOR(old_cursor)
  153.  
  154. IF aborted
  155.     * If aborted for any reason, erase all temporary files
  156.  
  157.     IF UPPER(ALIAS()) + '.DBF'  = UPPER(temp_file)
  158.         * If temporary file is still open, close it.
  159.         USE
  160.         * And reselect the original DBF file
  161.         SELECT (db_file)
  162.     ENDIF
  163.  
  164.     * Erase temporary files
  165.     IF FILE(temp_file)
  166.         ERASE (temp_file)
  167.     ENDIF
  168.  
  169.     * Erase temporary DBT file
  170.     temp_file = SUBSTR(temp_file, 1, 11) + 'T'
  171.     IF FILE(temp_file)
  172.         ERASE (temp_file)
  173.     ENDIF
  174.  
  175.     * Erase temporary index file
  176.     temp_file = SUBSTR(temp_file, 1, 8) + INDEXEXT()
  177.     IF FILE(temp_file)
  178.         ERASE (temp_file)
  179.     ENDIF
  180.  
  181.  
  182.     * Set return value to null to indicate no report file
  183.     temp_file = ''
  184. ENDIF
  185.  
  186. RETURN(temp_file)
  187.  
  188.  
  189. *****************************************************************
  190. STATIC PROCEDURE GETSEL
  191. *****************************************************************
  192.  
  193. * Get low and high selection values
  194.  
  195. LOCAL varname
  196.  
  197. PARAMETERS fldnames
  198.  
  199. CLRVARS()
  200. DO WHILE .T.
  201.     * Get selections for all memory variables
  202.     ans = .F.
  203.     DO WHILE .NOT. ans
  204.          EVAL(bGetProc)
  205.          @ 21, 5 SAY 'Enter ' + SPACE(LEN(hilow)) + ;
  206.                      ' selection values.  Press PgDn when done.'
  207.          SETCOLOR(colbarhi)
  208.          @ 21, 11 SAY hilow
  209.          SETCOLOR(colstd)
  210.          @ 23, 5 SAY 'You may enter data in a maximum of ' + ;
  211.                      '10 field areas'
  212.          SETCURSOR(SC_INSERT)
  213.          READ
  214.          ans = .T.
  215.          @ 21, 58 SAY '  Finished? Y/N ' GET ans PICTURE 'Y'
  216.          READ
  217.          @ 21, 58 CLEAR TO 23, 79
  218.     ENDDO
  219.     SETCURSOR(SC_NONE)
  220.     @ 21, 0
  221.     * Remove unused fields from array
  222.     counter = 1
  223.     DO WHILE TYPE("fldnames[counter]") # 'U'
  224.         varname = 'm' + fldnames[counter]
  225.         IF EMPTY(&varname)
  226.              ADEL(fldnames,counter)
  227.              IF counter = LEN(fldnames)
  228.                  EXIT
  229.              ENDIF
  230.              LOOP
  231.         ENDIF
  232.         counter++
  233.     ENDDO
  234.  
  235.     * Loop if operator entered too many selection fields.
  236.     * Maximum is 10 high plus 10 low.
  237.  
  238.     IF counter-1 > 10
  239.         ?? CHR(7)
  240.         CENTERON(24,'Too many selection fields.  Maximum is 10.')
  241.         LOOP
  242.     ELSE
  243.         EXIT
  244.     ENDIF
  245.  
  246. ENDDO WHILE .T.
  247. @ 24, 0
  248.  
  249. RETURN
  250.  
  251.  
  252. *****************************************************************
  253. STATIC PROCEDURE MAKNDX
  254. *****************************************************************
  255. *
  256. * Create an index expression
  257.  
  258. * Clear screen and redisplay memory variables
  259. CLRVARS()
  260. EVAL(bGetProc)
  261.  
  262. @ 20, 0 CLEAR TO 24, 79
  263.  
  264. @ 20, 7 SAY 'Position cursor on beginning of field(s) you '   + ;
  265.             'want to index on.'
  266. @ 21, 7 SAY 'Press plus key to select.   Up to 5 fields can ' + ;
  267.             'be selected in '
  268. @ 22, 7 SAY 'any order. Selected order will display.  Press ' + ;
  269.             'PgDn when done.'
  270.  
  271. ans = .F.
  272. DO WHILE .NOT. ans
  273.     counter = 0
  274.     ndx_strg = ''
  275.     ndx_word = ''
  276.  
  277.     * Set the "+" key to call FINDVAR procedure
  278.     SET KEY K_PLUS TO FINDVAR
  279.     EVAL(bGetProc)
  280.     SETCURSOR(SC_INSERT)
  281.     READ
  282.     SET KEY K_PLUS TO
  283.     ans = .T.
  284.     TONE(2000,1)
  285.     CENTERON(24, 'To abort, press Esc. -- Otherwise, ' + ;
  286.                  'are index selections correct? Y/N    ')
  287.     @ 24, col()-4 GET ans PICTURE 'Y'
  288.     READ
  289.     @ 24, 0
  290.     SETCURSOR(SC_NONE)
  291.     IF ans .AND. .NOT. EMPTY(ndx_strg) .AND. LASTKEY() != K_ESC
  292.         EXIT
  293.     ELSEIF LASTKEY() = K_ESC
  294.         aborted = .T.
  295.         EXIT
  296.     ELSEIF EMPTY(ndx_strg)
  297.         ?? CHR(7)
  298.         CENTERON(24, 'At least one index must be selected. ' + ;
  299.                      'Please reenter. ')
  300.         ans = .F.
  301.     ENDIF
  302.  
  303.     EVAL(bSayProc)
  304. ENDDO
  305.  
  306. RETURN
  307.  
  308.  
  309. *****************************************************************
  310. STATIC PROCEDURE MAKFILT
  311. *****************************************************************
  312.  
  313. * Create filter statement from selected fields
  314.  
  315. LOCAL filt_cnt := 1, filt_var := ''
  316.  
  317. PARAMETERS num_sels
  318.  
  319. counter := 1
  320. DO WHILE (counter <= num_flds .OR. counter = 1)
  321.     filt_var = filt_word + LTRIM(STR(filt_cnt))
  322.     &filt_var = ''
  323.     FOR counter = counter TO counter + 3
  324.         IF TYPE('num_sels[counter]') = 'C' .AND. pass = 1
  325.             &filt_var = &filt_var + num_sels[counter] + ' >= ' +;
  326.                         var_prefix + num_sels[counter]
  327.         ELSEIF TYPE('num_sels[counter]') = 'C' .AND. pass = 2
  328.             &filt_var = &filt_var + num_sels[counter] + ' <= ' +;
  329.                         var_prefix + num_sels[counter]
  330.         ENDIF
  331.         IF (counter % 4) != 0 .AND. counter < num_flds
  332.             &filt_var = &filt_var + ' .AND. '
  333.         ELSE
  334.             filt_cnt++
  335.             counter++
  336.             EXIT
  337.         ENDIF
  338.     NEXT
  339. ENDDO
  340.  
  341. * Create filter string
  342. counter = 1
  343. filt_cnt--
  344. DO WHILE counter <= filt_cnt
  345.     filt_var = filt_word + LTRIM(STR(counter))
  346.     filt_strg = filt_strg + &filt_var
  347.     IF counter # filt_cnt
  348.         filt_strg = filt_strg + ' .AND. '
  349.     ENDIF
  350.     counter++
  351. ENDDO
  352. RETURN
  353. *
  354.  
  355.  
  356. *****************************************************************
  357. STATIC PROCEDURE FINDVAR
  358. *****************************************************************
  359.  
  360. /* Mark field for indexing
  361.  
  362. Loads the current GET variable into ndxfld, and displays
  363. a number next to the selected GET field (in highlighted color). 
  364. The index expression is stored in ndx_word and then added to
  365. ndx_strg in the caller to form an index expression.
  366.  
  367. To keep index sizes manageable, character fields are indexed
  368. on the first 10 characters only.  Number of allowed indexes is 
  369. limited to 5 to keep run times reasonable. If more are needed, 
  370. change the MAX_NDX constant defined at the top of the file.
  371.  
  372. */
  373.  
  374. LOCAL fldlen := 0,  fldlens := {}, ndxfld, subscrp
  375. LOCAL old_color := SETCOLOR(colblink)
  376.  
  377. PARAMETERS callproc, linenum, inputvar
  378.  
  379. * Clear the hot key
  380. SET KEY K_PLUS TO
  381. ndxfld = inputvar
  382.  
  383.  
  384. * Determine data type for index expression
  385.  
  386. IF TYPE(ndxfld) = 'D'
  387.     ndx_word = 'DTOS(' + SUBSTR(ndxfld,2) + ')'
  388.     fldlen = LEN(DTOC(&ndxfld)) + 1
  389.  
  390. ELSEIF TYPE(ndxfld) = 'C'
  391.     * Index only on first 10 characters
  392.     IF LEN(&ndxfld) > 10
  393.         ndx_word = 'SUBSTR(' + SUBSTR(ndxfld,2) + ', 1, 10)'
  394.     ELSE
  395.         ndx_word = SUBSTR(ndxfld,2)
  396.     ENDIF
  397.     fldlen = LEN(&ndxfld) + 1
  398.  
  399. ELSEIF TYPE(ndxfld) = 'N'
  400.     ndx_word = 'STR(' + SUBSTR(ndxfld,2) + ')'
  401.     fldnames := ARRAY(fieldcnt)
  402.     fldlens  := ARRAY(fieldcnt)
  403.     AFIELDS(fldnames, '', fldlens)
  404.     subscrp = ASCAN(fldnames, SUBSTR(ndxfld,2))
  405.     fldlen = fldlens[subscrp] + 1
  406.  
  407. ELSE
  408.     ndx_word = ''
  409.     fldlen = 0
  410.  
  411. ENDIF
  412.  
  413. counter++
  414. IF counter <= MAX_NDX
  415.     * Display index number and force jump to next field
  416.     SWAPCOLOR(ROW(), COL() - 1, LTRIM(STR(counter)))
  417.     KEYBOARD CHR(13)
  418. ENDIF
  419.  
  420. IF counter = 1
  421.     ndx_strg = ndx_word
  422. ELSEIF counter <= MAX_NDX
  423.     ndx_strg = ndx_strg + ' + ' + ndx_word
  424. ELSE
  425.     * Stuff PgDn in keyboard to force exit from read
  426.     KEYBOARD CHR(3)
  427. ENDIF
  428.  
  429. SETCOLOR(old_color)
  430. SET KEY K_PLUS TO FINDVAR
  431. RETURN
  432.  
  433.