home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a106 / 2.ddi / GENXTAB.PR_ / GENXTAB.bin
Encoding:
Text File  |  1994-04-28  |  28.6 KB  |  974 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.    
  633. ***** CGC MYF *****             1994.3.7   
  634. *   @ 3,3 SAY REPLICATE("█",nblocks)
  635.    @ 3,3 SAY REPLICATE("ä",nblocks)
  636. ***** CGC MYF *****
  637.  
  638.    RETURN
  639. ENDCASE
  640. *!*********************************************************************
  641. *!
  642. *!      Procedure: DEACTTHERMO
  643. *!
  644. *!      Called by: GENXTAB.PRG                   
  645. *!
  646. *!*********************************************************************
  647. PROCEDURE deactthermo
  648. RELEASE WINDOW thermomete
  649. RETURN
  650.  
  651. *!*********************************************************************
  652. *!
  653. *!       Function: JUSTSTEM()
  654. *!
  655. *!      Called by: GENXTAB.PRG                   
  656. *!
  657. *!*********************************************************************
  658. FUNCTION juststem
  659. * Return just the stem name from "filname"
  660. PARAMETERS filname
  661. PRIVATE ALL
  662. IF RAT('\',m.filname) > 0
  663.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  664. ENDIF
  665. IF AT(':',m.filname) > 0
  666.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  667. ENDIF
  668. IF AT('.',m.filname) > 0
  669.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1)
  670. ENDIF
  671. RETURN ALLTRIM(UPPER(m.filname))
  672.  
  673. *!*********************************************************************
  674. *!
  675. *!      Procedure: FORCEEXT
  676. *!
  677. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  678. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  679. *!               : ADDBS          (procedure in GENXTAB.PRG)
  680. *!
  681. *!*********************************************************************
  682. FUNCTION forceext
  683. * Force the extension of "filname" to be whatever ext is.
  684. PARAMETERS filname,ext
  685. PRIVATE ALL
  686. IF SUBSTR(m.ext,1,1) = "."
  687.    m.ext = SUBSTR(m.ext,2,3)
  688. ENDIF
  689.  
  690. m.pname = justpath(m.filname)
  691. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  692. IF AT('.',m.filname) > 0
  693.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext
  694. ELSE
  695.    m.filname = m.filname + '.' + m.ext
  696. ENDIF
  697. RETURN addbs(m.pname) + m.filname
  698.  
  699. *!*********************************************************************
  700. *!
  701. *!       Function: DEFAULTEXT()
  702. *!
  703. *!      Called by: GENXTAB.PRG                   
  704. *!
  705. *!          Calls: JUSTPATH       (procedure in GENXTAB.PRG)
  706. *!               : JUSTFNAME()    (function  in GENXTAB.PRG)
  707. *!               : ADDBS          (procedure in GENXTAB.PRG)
  708. *!
  709. *!*********************************************************************
  710. FUNCTION defaultext
  711. * Add a default extension to "filname" if it doesn't have one already
  712. PARAMETERS filname,ext
  713. PRIVATE ALL
  714. IF SUBSTR(ext,1,1) = "."
  715.    m.ext = SUBSTR(m.ext,2,3)
  716. ENDIF
  717.  
  718. m.pname = justpath(m.filname)
  719. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  720. IF !EMPTY(m.filname) AND AT('.',m.filname) = 0
  721.    m.filname = m.filname + '.' + m.ext
  722.    RETURN addbs(m.pname) + m.filname
  723. ELSE
  724.    RETURN filname
  725. ENDIF
  726. *!*********************************************************************
  727. *!
  728. *!       Function: JUSTFNAME()
  729. *!
  730. *!      Called by: GENXTAB.PRG                   
  731. *!               : DEFAULTEXT()   (function  in GENXTAB.PRG)
  732. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  733. *!
  734. *!*********************************************************************
  735. FUNCTION justfname
  736. * Return just the filename (i.e., no path) from "filname"
  737. PARAMETERS filname
  738. PRIVATE ALL
  739. IF RAT('\',m.filname) > 0
  740.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  741. ENDIF
  742. IF AT(':',m.filname) > 0
  743.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  744. ENDIF
  745. RETURN ALLTRIM(UPPER(m.filname))
  746.  
  747. *!*********************************************************************
  748. *!
  749. *!      Procedure: JUSTPATH
  750. *!
  751. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  752. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  753. *!
  754. *!*********************************************************************
  755. FUNCTION justpath
  756. * Return just the path name from "filname"
  757. PARAMETERS filname
  758. PRIVATE ALL
  759. m.filname = ALLTRIM(UPPER(m.filname))
  760. IF '\' $ m.filname
  761.    m.filname = SUBSTR(m.filname,1,RAT('\',m.filname))
  762.    IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ;
  763.      AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
  764.       m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  765.    ENDIF
  766.    RETURN m.filname
  767. ELSE
  768.    RETURN ''
  769. ENDIF
  770.  
  771. *!*********************************************************************
  772. *!
  773. *!      Procedure: ADDBS
  774. *!
  775. *!      Called by: DEFAULTEXT()   (function  in GENXTAB.PRG)
  776. *!               : FORCEEXT       (procedure in GENXTAB.PRG)
  777. *!
  778. *!*********************************************************************
  779. FUNCTION addbs
  780. * Add a backslash to a path name, if there isn't already one there
  781. PARAMETER pathname
  782. PRIVATE ALL
  783. m.pathname = ALLTRIM(UPPER(m.pathname))
  784. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  785.    m.pathname = m.pathname + '\'
  786. ENDIF
  787. RETURN m.pathname
  788.  
  789.  
  790. *!*********************************************************************
  791. *!
  792. *!      Procedure: APPERROR
  793. *!
  794. *!      Called by: GENXTAB.PRG                   
  795. *!
  796. *!          Calls: ALERT          (procedure in GENXTAB.PRG)
  797. *!               : BAILOUT        (procedure in GENXTAB.PRG)
  798. *!
  799. *!*********************************************************************
  800. PROCEDURE apperror
  801. * Simple ON ERROR routine
  802.  
  803. PARAMETERS e_program,e_message,e_source,e_lineno,e_error
  804. ON ERROR
  805. SET MOUSE ON
  806. m.e_source = ALLTRIM(m.e_source)
  807. DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ;
  808.    +'Program: '+m.e_program +';' ;
  809.    +'  Error: '+m.e_message +';' ;
  810.    +' Source: '+IIF(LEN(m.e_source)<50,;
  811.    m.e_source,SUBSTR(m.e_source,1,50)+'...')
  812. DO bailout WITH .T.
  813.  
  814. *!*********************************************************************
  815. *!
  816. *!      Procedure: ALERT
  817. *!
  818. *!      Called by: GENXTAB.PRG                   
  819. *!               : APPERROR       (procedure in GENXTAB.PRG)
  820. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  821. *!
  822. *!*********************************************************************
  823. PROCEDURE alert
  824. * Display an error message, automatically sizing the message window
  825. *    as necessary.  Semicolons in "strg" mean "new line".
  826. PARAMETERS strg
  827. PRIVATE ALL
  828.  
  829. SET MOUSE ON
  830. in_talk = SET('TALK')
  831. SET TALK OFF
  832. in_cons = SET('CONSOLE')
  833.  
  834. m.numlines = OCCURS(';',m.strg) + 1
  835.  
  836. DIMENSION alert_arry[m.numlines]
  837. m.remain = m.strg
  838. m.maxlen = 0
  839. FOR i = 1 TO m.numlines
  840.    IF AT(';',m.remain) > 0
  841.       alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1)
  842.       alert_arry[i] = CHRTRAN(alert_arry[i],';','')
  843.       m.remain = SUBSTR(m.remain,AT(';',m.remain)+1)
  844.    ELSE
  845.       alert_arry[i] = m.remain
  846.       m.remain = ''
  847.    ENDIF
  848.    IF LEN(alert_arry[i]) > SCOLS() - 6
  849.       alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6)
  850.    ENDIF
  851.    IF LEN(alert_arry[i]) > m.maxlen
  852.       m.maxlen = LEN(alert_arry[i])
  853.    ENDIF
  854. ENDFOR
  855.  
  856. m.top_row = INT( (SROWS() - 4 - m.numlines) / 2)
  857. m.bot_row = m.top_row + 3 + m.numlines
  858.  
  859. m.top_col = INT((SCOLS() - m.maxlen - 6) / 2)
  860. m.bot_col = m.top_col + m.maxlen + 6
  861.  
  862. DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  863.    DOUBLE COLOR SCHEME 7
  864. ACTIVATE WINDOW alert
  865.  
  866. FOR i = 1 TO m.numlines
  867.    @ i,3 SAY PADC(alert_arry[i],m.maxlen)
  868. ENDFOR
  869.  
  870. SET CONSOLE OFF
  871. keycode = INKEY(0,'HM')
  872. SET CONSOLE ON
  873.  
  874. RELEASE WINDOW alert
  875. IF m.in_talk = "ON"
  876.    SET TALK ON
  877. ENDIF
  878. IF m.in_cons = "OFF"
  879.    SET CONSOLE OFF
  880. ENDIF
  881.  
  882. RETURN
  883.  
  884. *!*********************************************************************
  885. *!
  886. *!      Procedure: MAKESTRG
  887. *!
  888. *!*********************************************************************
  889. FUNCTION makestrg
  890. PARAMETER in_val
  891. DO CASE
  892. CASE TYPE("in_val") = "C"
  893.    RETURN in_val
  894. CASE TYPE("in_val") $ "NF"
  895.    RETURN ALLTRIM(STR(in_val))
  896. CASE TYPE("in_val") = "D"
  897.    RETURN DTOC(in_val)
  898. CASE TYPE("in_val") = "L"
  899.    IF in_val
  900.       RETURN ".T."
  901.    ELSE
  902.       RETURN ".F."
  903.    ENDIF
  904. OTHERWISE
  905.    RETURN in_val
  906. ENDCASE
  907.  
  908. *!*********************************************************************
  909. *!
  910. *!      Procedure: ESC_PROC
  911. *!
  912. *!      Called by: GENXTAB.PRG                   
  913. *!
  914. *!          Calls: BAILOUT        (procedure in GENXTAB.PRG)
  915. *!
  916. *!*********************************************************************
  917. PROCEDURE esc_proc
  918. WAIT WINDOW "Cross tabulation terminated." TIMEOUT 1
  919. CLEAR TYPEAHEAD
  920. DO bailout
  921.  
  922. *!*********************************************************************
  923. *!
  924. *!      Procedure: BAILOUT
  925. *!
  926. *!      Called by: GENXTAB.PRG                   
  927. *!               : APPERROR       (procedure in GENXTAB.PRG)
  928. *!               : ESC_PROC       (procedure in GENXTAB.PRG)
  929. *!               : MAPNAME()      (function  in GENXTAB.PRG)
  930. *!
  931. *!           Uses: XTABTEMP.DBF   
  932. *!
  933. *!*********************************************************************
  934. PROCEDURE bailout
  935. PARAMETER docancl
  936. PRIVATE docancl
  937. DO CASE
  938. CASE PARAMETERS() = 0
  939.    m.docancl   = .T.
  940. ENDCASE
  941. IF WONTOP('THERMOMETE')
  942.    RELEASE WINDOW thermomete
  943. ENDIF
  944.  
  945. IF USED("XTABTEMP")
  946.    SELECT xtabtemp
  947.    USE
  948. ENDIF
  949. IF FILE("xtabtemp.dbf")
  950.    DELETE FILE xtabtemp.dbf
  951. ENDIF
  952.  
  953. IF m.xsafe_stat = "ON"
  954.    SET SAFETY ON
  955. ENDIF
  956. IF m.xesc_stat = "ON"
  957.    SET ESCAPE ON
  958. ELSE
  959.    SET ESCAPE OFF
  960. ENDIF
  961. IF m.xtalk_stat = "ON"
  962.    SET TALK ON
  963. ENDIF
  964.  
  965. ON ERROR &in_err
  966. ON ESCAPE &in_esc
  967.  
  968. SET MOUSE ON
  969. IF m.docancl
  970.    m.outfname = ''
  971.    CANCEL
  972. ENDIF
  973. *: EOF: GENXTAB.PRG
  974.