home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a087 / 7.ddi / GENXTAB.PR_ / GENXTAB.bin
Encoding:
Text File  |  1994-02-02  |  28.5 KB  |  969 lines
  1. *:*********************************************************************
  2. *:
  3. *: Procedure file: C:\FOXPRO2\GENXTAB\GENXTAB.PRG
  4. *:
  5. *:         System: GENXTAB
  6. *:         Author: Walter J. Kennamer
  7. *:      Copyright (c) 1993, Microsoft Corp.
  8. *:  Last modified: 1/4/93     10:17
  9. *:
  10. *:  Procs & Fncts: APPERROR
  11. *:               : ESC_PROC
  12. *:               : JUSTFNAME()
  13. *:               : JUSTSTEM()
  14. *:               : BAILOUT
  15. *:               : DEFAULTEXT()
  16. *:               : ALERT
  17. *:               : ACTTHERM
  18. *:               : UPDTHERM
  19. *:               : MAPNAME()
  20. *:               : DEACTTHERMO
  21. *:               : FORCEEXT
  22. *:               : JUSTPATH
  23. *:               : ADDBS
  24. *:               : MAKESTRG
  25. *:
  26. *:          Calls: APPERROR       (procedure in GENXTAB.PRG)
  27. *:               : ESC_PROC       (procedure in GENXTAB.PRG)
  28. *:               : JUSTFNAME()    (function  in GENXTAB.PRG)
  29. *:               : JUSTSTEM()     (function  in GENXTAB.PRG)
  30. *:               : BAILOUT        (procedure in GENXTAB.PRG)
  31. *:               : DEFAULTEXT()   (function  in GENXTAB.PRG)
  32. *:               : ALERT          (procedure in GENXTAB.PRG)
  33. *:               : ACTTHERM       (procedure in GENXTAB.PRG)
  34. *:               : UPDTHERM       (procedure in GENXTAB.PRG)
  35. *:               : MAPNAME()      (function  in GENXTAB.PRG)
  36. *:               : DEACTTHERMO    (procedure in GENXTAB.PRG)
  37. *:
  38. *:           Uses: XTABTEMP.DBF   
  39. *:
  40. *:*********************************************************************
  41. ***********************************************************************
  42. *
  43. * Notes: This program is intended to be called by RQBE or a program
  44. *        generated by RQBE.  On entry, a table should be open in the
  45. *        current work area, and it should contain at most one record
  46. *        for each cell in a cross-tabulation.  This table *must* be in
  47. *        row order, or you will receive an "unexpected end of file"
  48. *        error when you run GENXTAB.
  49. *
  50. *        The rowfld field in each record becomes the y-axis (rows) for
  51. *        a cross-tab and the colfld field becomes the x-axis (columns)
  52. *        The actual cross-tab results are saved to the database name
  53. *        specified by "outfname."
  54. *
  55. *        The basic strategy goes like this.  Produce an empty database
  56. *        with one field/column for each unique value of input field
  57. *        colfld, plus one additional field for input field rowfld values.
  58. *        This process determines the column headings in the database.
  59. *        Next fill in the rows, but only for the first field in the output
  60. *        database--the one that contains values for input field rowfld.
  61. *        At this point, we have column headings "across the top"
  62. *        and row identifiers "down the side."  Finally, look up
  63. *        the cell values for the row/column intersections and put
  64. *        them into the output database.
  65. *
  66. *
  67. * Calling example:
  68. *        DO genxtab WITH 'XTAB.DBF',.T.,.T.,.T.,1,2,5,.T.
  69. *
  70. *        This command causes GENXTAB to write the output database to
  71. *        'XTAB.DBF'.  However, XTAB.DBF will be deleted and the output
  72. *        stored to a cursor called XTAB.  The input database will be closed
  73. *        at the conclusion of the program.  The rows in XTAB.DBF will
  74. *        contain the unique values of field 1 in the database that is
  75. *        selected when GENXTAB is called, the columns will contain
  76. *        unique values of field 2 in the input database, and the
  77. *        cell values will come from field 5 in the input database.
  78. *        The thermometer will be shown.  A total field will be created.
  79. *
  80. ***********************************************************************
  81.  
  82. PARAMETERS outfname,   ;
  83.    cursonly,   ;
  84.    closeinput, ;
  85.    showtherm,  ;
  86.    rowfld,     ;
  87.    colfld,     ;
  88.    cellfld,    ;
  89.    xfoot
  90.  
  91. PRIVATE ALL
  92.  
  93. #DEFINE c_dlgface        "MS Sans Serif"
  94. #DEFINE c_dlgsize        8.000
  95. #DEFINE c_dlgstyle        "B"
  96.  
  97. EXTERNAL ARRAY coluniq
  98. EXTERNAL ARRAY colcnt
  99.  
  100. * -------------------------------------------------------------------------
  101. * Do opening housekeeping
  102. * -------------------------------------------------------------------------
  103. IF SET("TALK") = "ON"
  104.    SET TALK OFF
  105.    xtalk_stat = "ON"
  106. ELSE
  107.    xtalk_stat = "OFF"
  108. ENDIF
  109. xsafe_stat = SET("SAFETY")
  110. SET SAFETY OFF
  111. xesc_stat = SET("ESCAPE")
  112. SET ESCAPE ON
  113.  
  114. in_esc = ON('ESCAPE')
  115. in_err = ON('ERROR')
  116.  
  117. ON ERROR DO apperror WITH PROGRAM(),MESSAGE(),MESSAGE(1),LINENO(),ERROR()
  118. ON ESCAPE DO esc_proc
  119.  
  120. * -------------------------------------------------------------------------
  121. * Set default values for parameters
  122. * -------------------------------------------------------------------------
  123. IF PARAMETERS() < 1
  124.    m.outfname = 'XTAB.DBF'
  125. ENDIF
  126. IF PARAMETERS() < 2
  127.    * Default to creating the same kind of output as we got as input.
  128.    * If the input "database" is a cursor, make the output a cursor.
  129.    * If the input "database" is an actual database, make the output a table.
  130.    cname = justfname(DBF())
  131.    DO CASE
  132.    CASE EMPTY(cname)   && create a table if nothing is currently selected
  133.       cursonly = .F.
  134.    CASE ISDIGIT(LEFT(cname,1))
  135.       cursonly = .T.
  136.    OTHERWISE
  137.       cursonly = .F.
  138.    ENDCASE
  139. ENDIF
  140. IF PARAMETERS() < 3
  141.    * Close the input database
  142.    closeinput = .T.
  143. ENDIF
  144. IF PARAMETERS() < 4
  145.    * show the thermometer
  146.    showtherm = .T.
  147. ENDIF
  148. IF PARAMETERS() < 5
  149.    * the field position in the input database for the crosstab rows
  150.    m.rowfld = 1
  151. ENDIF
  152. IF PARAMETERS() < 6
  153.    * the field position in the input database for the crosstab columns
  154.    m.colfld = 2
  155. ENDIF
  156. IF PARAMETERS() < 7
  157.    * the field position in the input database for the crosstab cells
  158.    m.cellfld = 3
  159. ENDIF
  160. IF PARAMETERS() < 8
  161.    * Create a total field?
  162.    m.xfoot = .F.
  163. ENDIF
  164.  
  165. * Define characters that are not allowed in field names
  166. m.badchars     = 'üéâäàåçêëèïîÄÅÉæÆôöòûùÿÖÜáíóúñÑ /\,-=:;{}[]!@#$%^&*.<>()'+;
  167.    '+|Ç¢£¥₧ƒªº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧'+;
  168.    '╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■'+CHR(39)
  169. * Map European characters to these
  170. m.stdascii     = 'ueaaaaceeeiiAaEaAooouuyouaiounN'
  171.  
  172. IF !showtherm
  173.    m.recthresh = 100000000    && don't show the thermometer
  174. ELSE
  175.    m.recthresh = 1            && show it if more than this many input records
  176. ENDIF
  177. m.g_thermwidth = 0              && Thermometer width
  178. m.outstem      = juststem(m.outfname)
  179.  
  180. * -------------------------------------------------------------------------
  181. * Construct the output database structure
  182. * -------------------------------------------------------------------------
  183.  
  184. m.dbfname = ALIAS()
  185.  
  186. m.dbfstem = Juststem(m.dbfname)
  187.  
  188. therm_on = (RECCOUNT() >= recthresh)
  189.  
  190. * Select one, if no database is open in the current workarea
  191. m.ok = .F.
  192. DO WHILE NOT ok
  193.    DO CASE
  194.    CASE EMPTY(m.dbfname)
  195.       m.dbfname = GETFILE('DBF','Please locate the input database')
  196.       m.dbfstem = juststem(m.dbfname)
  197.       IF EMPTY(m.dbfname)
  198.          * User canceled out of dialog, so quit the program
  199.          DO bailout WITH .T.
  200.       ENDIF
  201.    CASE FULLPATH(defaultext(m.dbfname,'DBF')) == ;
  202.          FULLPATH(defaultext(m.outfname,'DBF'))
  203.       SET CURSOR OFF
  204.       WAIT WINDOW "The input and output databases must be different."
  205.       SET CURSOR ON
  206.       m.dbfname = ''
  207.    OTHERWISE
  208.       IF USED(m.dbfstem)
  209.          SELECT (m.dbfstem)
  210.       ELSE
  211.          SELECT 0
  212.          USE (m.dbfname) ALIAS (m.dbfstem)
  213.       ENDIF
  214.       IF FCOUNT() < 3
  215.          DO alert WITH "Crosstab input databases require; at least three fields"
  216.          m.dbfname = ''
  217.       ELSE
  218.          ok = .T.
  219.       ENDIF
  220.    ENDCASE
  221. ENDDO
  222.  
  223. IF RECCOUNT() = 0
  224.    DO alert WITH "Cannot prepare crosstab on empty database"
  225.    DO bailout WITH .T.  
  226. ENDIF
  227.    
  228. * Gather information on the currently selected database fields
  229. DIMENSION inpfields[FCOUNT(),4]
  230. m.numflds = AFIELDS(inpfields)
  231.  
  232. * Map the physical input database field to logical field positions
  233. m.rowfldname    = inpfields[m.rowfld,1]
  234. m.colfldname    = inpfields[m.colfld,1]
  235. m.cellfldname   = inpfields[m.cellfld,1]
  236.  
  237. * None of these fields are allowed to be memo fields
  238. IF inpfields[1,2] $ 'MGP'
  239.    DO alert WITH "The crosstab row field in the input; database cannot be a memo, general or picture  field."
  240.    DO bailout WITH .T.
  241. ENDIF
  242. IF inpfields[2,2] $ 'MGP'
  243.    DO alert WITH "The crosstab column field in the input; database cannot be a memo, general or picture field."
  244.    DO bailout WITH .T.
  245. ENDIF
  246. IF inpfields[3,2] $ 'MGP'
  247.    DO alert WITH "The crosstab cell field in the input; database cannot be a memo, general or picture field."
  248.    DO bailout WITH .T.
  249. ENDIF
  250.  
  251. IF therm_on
  252.    DO acttherm WITH "Generating cross-tabulation ..."
  253.    DO updtherm WITH 5
  254. ENDIF
  255.  
  256. * Set the mouse off to avoid flicker on some systems
  257. SET MOUSE OFF
  258.  
  259. * Count the number of columns we need to create the cross tab.
  260. * This step could be combined with the following one so that there
  261. * would only be one SELECT operation performed.  It is coded in this
  262. * way to avoid running out of memory if there are an unexpectedly
  263. * large number of unique values of field 2 in the input database.
  264. SELECT COUNT(DISTINCT &colfldname) FROM (m.dbfname) INTO ARRAY colcnt
  265.  
  266. DO CASE
  267. CASE colcnt[1] > 254
  268.    DO alert WITH "Too many unique values of "+PROPER(m.colfldname);
  269.       + ".;  The maximum is 254."
  270.    DO bailout WITH .T.
  271. CASE colcnt[1] = 0
  272.    DO alert WITH "No columns found."
  273.    DO bailout WITH .T.
  274. ENDCASE
  275.  
  276. * Get the number of decimal places in numeric fields
  277. * and extract all the unique values of colfldname  
  278. IF inpfields[m.colfld,2] $ 'NF'   && numeric or floating field
  279.    m.cdec = inpfields[m.colfld,4]
  280.    * Handle numbers separately to preserve correct sort order
  281.    SELECT DISTINCT &colfldname ;
  282.       FROM (m.dbfname) INTO ARRAY coluniq
  283.    FOR i = 1 TO ALEN(coluniq)
  284.       coluniq[i] = mapname(coluniq[i],m.cdec)
  285.    ENDFOR
  286. ELSE        && non-numeric field
  287.    m.cdec = 0
  288.    * Create an array to hold the output database fields.
  289.    SELECT DISTINCT mapname(&colfldname,m.cdec) ;
  290.       FROM (m.dbfname) INTO ARRAY coluniq
  291. ENDIF
  292.  
  293. IF therm_on
  294.    DO updtherm WITH 15
  295. ENDIF
  296.  
  297. * The field type, length and decimals in the output array control the
  298. * cross-tab cells
  299. IF !m.xfoot
  300.    DIMENSION outarray[ALEN(coluniq)+1,4]
  301. ELSE
  302.    DIMENSION outarray[ALEN(coluniq)+2,4]
  303. ENDIF
  304.  
  305. * Field 1 in the output DBF holds the unique values of the row input field.
  306. * It is handled separately from the other fields, which take their names
  307. * from input database colfld and their parameters (e.g., length) from
  308. * input database cellfld.
  309.  
  310. outarray[1,1] = mapname(inpfields[1,1])
  311. outarray[1,2] = inpfields[1,2]
  312. outarray[1,3] = inpfields[1,3]
  313. outarray[1,4] = inpfields[1,4]
  314.  
  315. FOR i = 2 TO ALEN(coluniq) + 1
  316.    outarray[i,1] = mapname(coluniq[i-1],m.cdec)
  317.    outarray[i,2] = inpfields[3,2]                   && field type
  318.    outarray[i,3] = inpfields[3,3]                   && field length
  319.    outarray[i,4] = inpfields[3,4]                   && decimals
  320. ENDFOR
  321.  
  322. * Create a field for the cross-footing, if that option was selected
  323. IF m.xfoot
  324.    outarray[ALEN(coluniq)+2,1] = 'XTOTALS'
  325.    outarray[ALEN(coluniq)+2,2] = inpfields[3,2]
  326.    outarray[ALEN(coluniq)+2,3] = inpfields[3,3]
  327.    outarray[ALEN(coluniq)+2,4] = inpfields[3,4]
  328. ENDIF
  329.  
  330. * Make sure that the output file is not already in use somewhere
  331. IF USED(m.outstem)
  332.    SELECT (m.outstem)
  333.    USE
  334. ENDIF
  335.  
  336. IF !cursonly
  337.    CREATE TABLE (outfname) FROM ARRAY outarray
  338. ELSE
  339.    CREATE CURSOR (outfname) FROM ARRAY outarray
  340. ENDIF
  341.  
  342. IF therm_on
  343.    DO updtherm WITH 25
  344. ENDIF
  345.  
  346. * Get rid of the temporary arrays
  347. RELEASE outarray, coluniq, inpfields
  348.  
  349. * -------------------------------------------------------------------------
  350. * Add output database rows and replace the first field
  351. * -------------------------------------------------------------------------
  352.  
  353. * Select distinct rows into a table (instead of an array) so that 
  354. * there can be lots of rows.  If we select into an array, we may 
  355. * run out of RAM if there are many rows.
  356.  
  357. SELECT DISTINCT &rowfldname FROM (m.dbfname) INTO TABLE xtabtemp
  358.  
  359. IF therm_on
  360.    DO updtherm WITH 30
  361. ENDIF
  362.  
  363. SELECT (m.outstem)
  364. APPEND FIELD (FIELD(1)) FROM xtabtemp
  365.  
  366. IF therm_on
  367.    DO updtherm WITH 35
  368. ENDIF
  369. * -------------------------------------------------------------------------
  370. * Look up and replace the cell values
  371. * -------------------------------------------------------------------------
  372. *
  373. * This algorithm makes one pass through the input file, dropping its
  374. * values into the output file.  It exploits the fact that the output
  375. * file is known to be in row order.
  376. *
  377.  
  378. * Start at the top of the output file
  379. SELECT (m.outstem)
  380. GOTO TOP
  381. outf1name = FIELD(1)
  382.  
  383. * Start at the top of the input file
  384. SELECT (m.dbfstem)
  385. GOTO TOP
  386.  
  387. SCAN
  388.    m.f1 = EVAL(m.rowfldname)                  && get next row value from input
  389.    m.f2 = mapname(EVAL(m.colfldname),m.cdec)  && get corresponding column value
  390.    m.f3 = EVAL(m.cellfldname)                 && get cell value
  391.    
  392.    * Find the right row in the output file
  393.    SELECT (m.outstem)
  394.    DO WHILE !(EVAL(outf1name) == m.f1) AND !EOF()
  395.       SKIP
  396.    ENDDO
  397.    
  398.    IF !EOF()
  399.       REPLACE (m.f2) WITH &f2 + m.f3 
  400.    ELSE
  401.       DO alert WITH "Unexpected end of output file.;" ;
  402.          + "The input file may be out of sequence."
  403.       DO bailout WITH .T.
  404.    ENDIF
  405.    
  406.    SELECT (m.dbfstem)
  407.    
  408.    * Map thermometer to remaining portion of display
  409.    IF therm_on
  410.       DO CASE
  411.       CASE RECCOUNT() > 1000
  412.          IF RECNO() % 100 = 0
  413.             DO updtherm WITH INT(RECNO() / RECCOUNT() * 65)+ 35
  414.          ENDIF
  415.       OTHERWISE
  416.          IF RECNO() % 10  = 0
  417.             DO updtherm WITH INT(RECNO() / RECCOUNT() * 65)+ 35
  418.          ENDIF
  419.       ENDCASE
  420.    ENDIF
  421. ENDSCAN
  422.  
  423. * Cross-foot the columns and put the results into the total field
  424. IF m.xfoot
  425.    SELECT (m.outstem)
  426.    m.totfldname = FIELD(FCOUNT())
  427.    SCAN
  428.       * Sum the relevant fields
  429.       m.gtotal = 0
  430.       FOR i = 2 TO FCOUNT() - 1
  431.          m.gtotal = m.gtotal + EVAL(FIELD(i))
  432.       ENDFOR
  433.       
  434.       REPLACE (m.totfldname) WITH m.gtotal
  435.    ENDSCAN
  436. ENDIF
  437.  
  438. IF therm_on
  439.    DO updtherm WITH 100
  440.    DO deactthermo
  441. ENDIF
  442.  
  443. IF USED("XTABTEMP")
  444.    SELECT xtabtemp
  445.    USE
  446. ENDIF
  447. IF FILE("xtabtemp.dbf")
  448.    DELETE FILE xtabtemp.dbf
  449. ENDIF
  450.  
  451. * Close the input database
  452. IF closeinput
  453.    SELECT (m.dbfstem)
  454.    USE
  455. ENDIF
  456.  
  457. * Leave the output database/cursor selected
  458. SELECT (m.outstem)
  459. GOTO TOP
  460.  
  461. * Do closing housekeeping
  462. DO bailout WITH .F.
  463.  
  464.  
  465. RETURN
  466.  
  467.  
  468. *!*********************************************************************
  469. *!
  470. *!       Function: MAPNAME()
  471. *!
  472. *!      Called by: GENXTAB.PRG                   
  473. *!
  474. *!          Calls: ALERT          (procedure in GENXTAB.PRG)
  475. *!               : BAILOUT        (procedure in GENXTAB.PRG)
  476. *!
  477. *!*********************************************************************
  478. FUNCTION mapname
  479. * Translate a field value of any type into a string containing a valid
  480. * field name.
  481.  
  482. PARAMETER in_name, in_dec
  483. IF PARAMETERS() = 1
  484.    in_dec = 0
  485. ENDIF
  486. DO CASE
  487. CASE TYPE("in_name") $ 'CM'
  488.    DO CASE
  489.    CASE EMPTY(m.in_name)
  490.       m.retval = 'C_BLANK'
  491.    OTHERWISE
  492.       m.retval = SUBSTR(CHRTRAN(m.in_name,m.badchars,m.stdascii),1,10)
  493.       IF !ISALPHA(LEFT(m.retval,1))
  494.          m.retval = 'C_'+LEFT(m.retval,8)
  495.       ENDIF
  496.    ENDCASE
  497. CASE TYPE("in_name") $ 'NF'
  498.    m.retval = 'N_'+ALLTRIM(CHRTRAN(STR(m.in_name,8,in_dec),'.',''))
  499. CASE TYPE("in_name") = 'D'
  500.    DO CASE
  501.    CASE EMPTY(m.in_name)
  502.       m.retval = 'D_BLANK'
  503.    OTHERWISE
  504.       m.retval = 'D_' + CHRTRAN(DTOS(m.in_name),m.badchars,m.stdascii)
  505.    ENDCASE
  506. CASE TYPE("in_name") = 'L'
  507.    IF m.in_name = .T.
  508.       m.retval = 'T'
  509.    ELSE
  510.       m.retval = 'F'
  511.    ENDIF
  512. CASE TYPE("in_name") = 'P'
  513.    DO alert WITH "Picture type fields are not allowed here."
  514.    DO bailout WITH .T.
  515. OTHERWISE
  516.    DO alert WITH "Unknown field type."
  517.    DO bailout WITH .T.
  518. ENDCASE
  519. m.retval = PADR(UPPER(ALLTRIM(m.retval)),10)
  520. RETURN m.retval
  521.  
  522. *!*********************************************************************
  523. *!
  524. *!      Procedure: ACTTHERM
  525. *!
  526. *!      Called by: GENXTAB.PRG                   
  527. *!
  528. *!*********************************************************************
  529. *
  530. * Activates thermometer.  Update the thermometer with UPDTHERM().
  531. * Thermometer window is named "thermometer."  Be sure to RELEASE
  532. * this window when done with thermometer.  Creates the global
  533. * m.g_thermwidth.
  534. *
  535. PROCEDURE acttherm
  536. PARAMETER m.prompt
  537. DO CASE
  538. CASE _WINDOWS OR _MAC
  539.    IF txtwidth(m.prompt, c_dlgface, c_dlgsize, c_dlgstyle) > 43
  540.       DO WHILE txtwidth(m.prompt+"...", c_dlgface, c_dlgsize, c_dlgstyle) > 43
  541.          m.prompt = LEFT(m.prompt, LEN(m.prompt)-1)
  542.       ENDDO
  543.       m.prompt = m.prompt + "..."
  544.    ENDIF
  545.    
  546.    DEFINE WINDOW thermomete ;
  547.       AT  INT((SROW() - (( 5.615 * ;
  548.       FONTMETRIC(1, c_dlgface, c_dlgsize, c_dlgstyle )) / ;
  549.       FONTMETRIC(1, wfont(1,""), wfont( 2,""), wfont(3,"")))) / 2), ;
  550.       INT((SCOL() - (( 63.833 * ;
  551.       FONTMETRIC(6, c_dlgface, c_dlgsize, c_dlgstyle )) / ;
  552.       FONTMETRIC(6, wfont(1,""), wfont( 2,""), wfont(3,"")))) / 2) ;
  553.       SIZE 5.615,63.833 ;
  554.       FONT c_dlgface, c_dlgsize ;
  555.       STYLE c_dlgstyle ;
  556.       NOFLOAT ;
  557.       NOCLOSE ;
  558.       NONE ;
  559.       COLOR rgb(0, 0, 0, 192, 192, 192)
  560.    ACTIVATE WINDOW thermomete NOSHOW
  561.    
  562.    @ 1.5,3 SAY m.prompt FONT c_dlgface, c_dlgsize STYLE c_dlgstyle
  563.    @ 0.000,0.000 TO 0.000,63.833 ;
  564.       COLOR rgb(255, 255, 255, 255, 255, 255)
  565.    @ 0.000,0.000 TO 5.615,0.000 ;
  566.       COLOR rgb(255, 255, 255, 255, 255, 255)
  567.    @ 0.385,0.667 TO 5.231,0.667 ;
  568.       COLOR rgb(128, 128, 128, 128, 128, 128)
  569.    @ 0.308,0.667 TO 0.308,63.167 ;
  570.       COLOR rgb(128, 128, 128, 128, 128, 128)
  571.    @ 0.385,63.000 TO 5.308,63.000 ;
  572.       COLOR rgb(255, 255, 255, 255, 255, 255)
  573.    @ 5.231,0.667 TO 5.231,63.167 ;
  574.       COLOR rgb(255, 255, 255, 255, 255, 255)
  575.    @ 5.538,0.000 TO 5.538,63.833 ;
  576.       COLOR rgb(128, 128, 128, 128, 128, 128)
  577.    @ 0.000,63.667 TO 5.615,63.667 ;
  578.       COLOR rgb(128, 128, 128, 128, 128, 128)
  579.    @ 3.000,3.333 TO 4.231,3.333 ;
  580.       COLOR rgb(128, 128, 128, 128, 128, 128)
  581.    @ 3.000,60.333 TO 4.308,60.333 ;
  582.       COLOR rgb(255, 255, 255, 255, 255, 255)
  583.    @ 3.000,3.333 TO 3.000,60.333 ;
  584.       COLOR rgb(128, 128, 128, 128, 128, 128)
  585.    @ 4.231,3.333 TO 4.231,60.500 ;
  586.       COLOR rgb(255, 255, 255, 255, 255, 255)
  587.    m.g_thermwidth = 56.269
  588.    
  589. CASE _DOS OR _UNIX
  590.    PRIVATE m.therm_x1, m.therm_y1, m.therm_x2, m.therm_y2
  591.    m.therm_x1 = INT((SROW()-6)/2)
  592.    m.therm_y1 = INT((SCOL()-57)/2)
  593.    m.therm_x2 = m.therm_x1 + 6
  594.    m.therm_y2 = m.therm_y1 + 57
  595.  
  596.    DEFINE WINDOW thermomete;
  597.       FROM m.therm_x1, m.therm_y1 TO m.therm_x2, m.therm_y2;
  598.       FLOAT DOUBLE COLOR SCHEME 5
  599.  
  600.    ACTIVATE WINDOW thermomete
  601.    @ 0,3 SAY m.prompt
  602.    m.g_thermwidth = 54
  603.    @ 2,1 TO 4,m.g_thermwidth
  604. ENDCASE
  605. SHOW WINDOW thermomete TOP
  606.  
  607. *!*********************************************************************
  608. *!
  609. *!      Procedure: UPDTHERM
  610. *!
  611. *!      Called by: GENXTAB.PRG                   
  612. *!
  613. *!*********************************************************************
  614. PROCEDURE updtherm
  615. PARAMETER m.percent
  616. PRIVATE m.nblocks, m.percent
  617.  
  618. IF !WEXIST("thermomete")
  619.    DO acttherm WITH "Generating cross-tabulation ..."
  620. ENDIF
  621. ACTIVATE WINDOW thermomete
  622.  
  623. DO CASE
  624. CASE _WINDOWS OR _MAC
  625.    m.nblocks = (m.percent/100) * (m.g_thermwidth)
  626.    @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
  627.       pattern 1 COLOR rgb(128, 128, 128, 128, 128, 128)
  628. CASE _DOS OR _UNIX   
  629.    PRIVATE nblocks, percent
  630.    ACTIVATE WINDOW thermomete
  631.    nblocks = (percent/100) * (m.g_thermwidth-4)
  632.    @ 3,3 SAY REPLICATE("█",nblocks)
  633.    RETURN
  634. ENDCASE
  635. *!*********************************************************************
  636. *!
  637. *!      Procedure: DEACTTHERMO
  638. *!
  639. *!      Called by: GENXTAB.PRG                   
  640. *!
  641. *!*********************************************************************
  642. PROCEDURE deactthermo
  643. RELEASE WINDOW thermomete
  644. RETURN
  645.  
  646. *!*********************************************************************
  647. *!
  648. *!       Function: JUSTSTEM()
  649. *!
  650. *!      Called by: GENXTAB.PRG                   
  651. *!
  652. *!*********************************************************************
  653. FUNCTION juststem
  654. * Return just the stem name from "filname"
  655. PARAMETERS filname
  656. PRIVATE ALL
  657. IF RAT('\',m.filname) > 0
  658.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  659. ENDIF
  660. IF AT(':',m.filname) > 0
  661.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  662. ENDIF
  663. IF AT('.',m.filname) > 0
  664.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1)
  665. ENDIF
  666. RETURN ALLTRIM(UPPER(m.filname))
  667.  
  668. *!*********************************************************************
  669. *!
  670. *!      Procedure: FORCEEXT
  671. *!
  672. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  673. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  674. *!               : ADDBS          (procedure in GENXTAB.PRG)
  675. *!
  676. *!*********************************************************************
  677. FUNCTION forceext
  678. * Force the extension of "filname" to be whatever ext is.
  679. PARAMETERS filname,ext
  680. PRIVATE ALL
  681. IF SUBSTR(m.ext,1,1) = "."
  682.    m.ext = SUBSTR(m.ext,2,3)
  683. ENDIF
  684.  
  685. m.pname = justpath(m.filname)
  686. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  687. IF AT('.',m.filname) > 0
  688.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext
  689. ELSE
  690.    m.filname = m.filname + '.' + m.ext
  691. ENDIF
  692. RETURN addbs(m.pname) + m.filname
  693.  
  694. *!*********************************************************************
  695. *!
  696. *!       Function: DEFAULTEXT()
  697. *!
  698. *!      Called by: GENXTAB.PRG                   
  699. *!
  700. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  701. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  702. *!               : ADDBS          (procedure in GENXTAB.PRG)
  703. *!
  704. *!*********************************************************************
  705. FUNCTION defaultext
  706. * Add a default extension to "filname" if it doesn't have one already
  707. PARAMETERS filname,ext
  708. PRIVATE ALL
  709. IF SUBSTR(ext,1,1) = "."
  710.    m.ext = SUBSTR(m.ext,2,3)
  711. ENDIF
  712.  
  713. m.pname = justpath(m.filname)
  714. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  715. IF !EMPTY(m.filname) AND AT('.',m.filname) = 0
  716.    m.filname = m.filname + '.' + m.ext
  717.    RETURN addbs(m.pname) + m.filname
  718. ELSE
  719.    RETURN filname
  720. ENDIF
  721. *!*********************************************************************
  722. *!
  723. *!       Function: JUSTFNAME()
  724. *!
  725. *!      Called by: GENXTAB.PRG                   
  726. *!               : DEFAULTEXT()   (function  in GENXTAB.PRG)
  727. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  728. *!
  729. *!*********************************************************************
  730. FUNCTION justfname
  731. * Return just the filename (i.e., no path) from "filname"
  732. PARAMETERS filname
  733. PRIVATE ALL
  734. IF RAT('\',m.filname) > 0
  735.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  736. ENDIF
  737. IF AT(':',m.filname) > 0
  738.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  739. ENDIF
  740. RETURN ALLTRIM(UPPER(m.filname))
  741.  
  742. *!*********************************************************************
  743. *!
  744. *!      Procedure: JUSTPATH
  745. *!
  746. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  747. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  748. *!
  749. *!*********************************************************************
  750. FUNCTION justpath
  751. * Return just the path name from "filname"
  752. PARAMETERS filname
  753. PRIVATE ALL
  754. m.filname = ALLTRIM(UPPER(m.filname))
  755. IF '\' $ m.filname
  756.    m.filname = SUBSTR(m.filname,1,RAT('\',m.filname))
  757.    IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ;
  758.          AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
  759.       m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  760.    ENDIF
  761.    RETURN m.filname
  762. ELSE
  763.    RETURN ''
  764. ENDIF
  765.  
  766. *!*********************************************************************
  767. *!
  768. *!      Procedure: ADDBS
  769. *!
  770. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  771. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  772. *!
  773. *!*********************************************************************
  774. FUNCTION addbs
  775. * Add a backslash to a path name, if there isn't already one there
  776. PARAMETER pathname
  777. PRIVATE ALL
  778. m.pathname = ALLTRIM(UPPER(m.pathname))
  779. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  780.    m.pathname = m.pathname + '\'
  781. ENDIF
  782. RETURN m.pathname
  783.  
  784.  
  785. *!*********************************************************************
  786. *!
  787. *!      Procedure: APPERROR
  788. *!
  789. *!      Called by: GENXTAB.PRG                   
  790. *!
  791. *!          Calls: ALERT          (procedure in GENXTAB.PRG)
  792. *!               : BAILOUT        (procedure in GENXTAB.PRG)
  793. *!
  794. *!*********************************************************************
  795. PROCEDURE apperror
  796. * Simple ON ERROR routine
  797.  
  798. PARAMETERS e_program,e_message,e_source,e_lineno,e_error
  799. ON ERROR
  800. SET MOUSE ON
  801. m.e_source = ALLTRIM(m.e_source)
  802. DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ;
  803.    +'Program: '+m.e_program +';' ;
  804.    +'  Error: '+m.e_message +';' ;
  805.    +' Source: '+IIF(LEN(m.e_source)<50,;
  806.    m.e_source,SUBSTR(m.e_source,1,50)+'...')
  807. DO bailout WITH .T.
  808.  
  809. *!*********************************************************************
  810. *!
  811. *!      Procedure: ALERT
  812. *!
  813. *!      Called by: GENXTAB.PRG                   
  814. *!               : APPERROR       (procedure in GENXTAB.PRG)
  815. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  816. *!
  817. *!*********************************************************************
  818. PROCEDURE alert
  819. * Display an error message, automatically sizing the message window
  820. *    as necessary.  Semicolons in "strg" mean "new line".
  821. PARAMETERS strg
  822. PRIVATE ALL
  823.  
  824. SET MOUSE ON
  825. in_talk = SET('TALK')
  826. SET TALK OFF
  827. in_cons = SET('CONSOLE')
  828.  
  829. m.numlines = OCCURS(';',m.strg) + 1
  830.  
  831. DIMENSION alert_arry[m.numlines]
  832. m.remain = m.strg
  833. m.maxlen = 0
  834. FOR i = 1 TO m.numlines
  835.    IF AT(';',m.remain) > 0
  836.       alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1)
  837.       alert_arry[i] = CHRTRAN(alert_arry[i],';','')
  838.       m.remain = SUBSTR(m.remain,AT(';',m.remain)+1)
  839.    ELSE
  840.       alert_arry[i] = m.remain
  841.       m.remain = ''
  842.    ENDIF
  843.    IF LEN(alert_arry[i]) > SCOLS() - 6
  844.       alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6)
  845.    ENDIF
  846.    IF LEN(alert_arry[i]) > m.maxlen
  847.       m.maxlen = LEN(alert_arry[i])
  848.    ENDIF
  849. ENDFOR
  850.  
  851. m.top_row = INT( (SROWS() - 4 - m.numlines) / 2)
  852. m.bot_row = m.top_row + 3 + m.numlines
  853.  
  854. m.top_col = INT((SCOLS() - m.maxlen - 6) / 2)
  855. m.bot_col = m.top_col + m.maxlen + 6
  856.  
  857. DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  858.    DOUBLE COLOR SCHEME 7
  859. ACTIVATE WINDOW alert
  860.  
  861. FOR i = 1 TO m.numlines
  862.    @ i,3 SAY PADC(alert_arry[i],m.maxlen)
  863. ENDFOR
  864.  
  865. SET CONSOLE OFF
  866. keycode = INKEY(0,'HM')
  867. SET CONSOLE ON
  868.  
  869. RELEASE WINDOW alert
  870. IF m.in_talk = "ON"
  871.    SET TALK ON
  872. ENDIF
  873. IF m.in_cons = "OFF"
  874.    SET CONSOLE OFF
  875. ENDIF
  876.  
  877. RETURN
  878.  
  879. *!*********************************************************************
  880. *!
  881. *!      Procedure: MAKESTRG
  882. *!
  883. *!*********************************************************************
  884. FUNCTION makestrg
  885. PARAMETER in_val
  886. DO CASE
  887. CASE TYPE("in_val") = "C"
  888.    RETURN in_val
  889. CASE TYPE("in_val") $ "NF"
  890.    RETURN ALLTRIM(STR(in_val))
  891. CASE TYPE("in_val") = "D"
  892.    RETURN DTOC(in_val)
  893. CASE TYPE("in_val") = "L"
  894.    IF in_val
  895.       RETURN ".T."
  896.    ELSE
  897.       RETURN ".F."
  898.    ENDIF
  899. OTHERWISE
  900.    RETURN in_val
  901. ENDCASE
  902.  
  903. *!*********************************************************************
  904. *!
  905. *!      Procedure: ESC_PROC
  906. *!
  907. *!      Called by: GENXTAB.PRG                   
  908. *!
  909. *!          Calls: BAILOUT        (procedure in GENXTAB.PRG)
  910. *!
  911. *!*********************************************************************
  912. PROCEDURE esc_proc
  913. WAIT WINDOW "Cross tabulation terminated." TIMEOUT 1
  914. CLEAR TYPEAHEAD
  915. DO bailout
  916.  
  917. *!*********************************************************************
  918. *!
  919. *!      Procedure: BAILOUT
  920. *!
  921. *!      Called by: GENXTAB.PRG                   
  922. *!               : APPERROR       (procedure in GENXTAB.PRG)
  923. *!               : ESC_PROC       (procedure in GENXTAB.PRG)
  924. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  925. *!
  926. *!           Uses: XTABTEMP.DBF   
  927. *!
  928. *!*********************************************************************
  929. PROCEDURE bailout
  930. PARAMETER docancl
  931. PRIVATE docancl
  932. DO CASE
  933. CASE PARAMETERS() = 0
  934.    m.docancl   = .T.
  935. ENDCASE
  936. IF WONTOP('THERMOMETE')
  937.    RELEASE WINDOW thermomete
  938. ENDIF
  939.  
  940. IF USED("XTABTEMP")
  941.    SELECT xtabtemp
  942.    USE
  943. ENDIF
  944. IF FILE("xtabtemp.dbf")
  945.    DELETE FILE xtabtemp.dbf
  946. ENDIF
  947.  
  948. IF m.xsafe_stat = "ON"
  949.    SET SAFETY ON
  950. ENDIF
  951. IF m.xesc_stat = "ON"
  952.    SET ESCAPE ON
  953. ELSE
  954.    SET ESCAPE OFF
  955. ENDIF
  956. IF m.xtalk_stat = "ON"
  957.    SET TALK ON
  958. ENDIF
  959.  
  960. ON ERROR &in_err
  961. ON ESCAPE &in_esc
  962.  
  963. SET MOUSE ON
  964. IF m.docancl
  965.    m.outfname = ''
  966.    CANCEL
  967. ENDIF
  968. *: EOF: GENXTAB.PRG
  969.