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