home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / FOXP-WIN.300 / DISK5 / VFP5.CAB / VFPXTAB.PRG < prev   
Encoding:
Text File  |  1995-01-11  |  33.9 KB  |  1,159 lines
  1. *:*********************************************************************
  2. *:
  3. *: Procedure file: VFPXTAB.PRG
  4. *:
  5. *:        System: GENXTAB
  6. *:        Author: Microsoft Corp.
  7. *:        Copyright (c) 1993,1994,1995 Microsoft Corp.
  8. *:
  9. *:*********************************************************************
  10. ***********************************************************************
  11. *
  12. * Notes: This program is intended to be called by RQBE or a program
  13. *        generated by RQBE.  On entry, a table should be open in the
  14. *        current work area, and it should contain at most one record
  15. *        for each cell in a cross-tabulation.  This table *must* be in
  16. *        row order, or you will receive an "unexpected end of file"
  17. *        error when you run GENXTAB.
  18. *
  19. *        The rowfld field in each record becomes the y-axis (rows) for
  20. *        a cross-tab and the colfld field becomes the x-axis (columns)
  21. *        The actual cross-tab results are saved to the database name
  22. *        specified by "outfname."
  23. *
  24. *        The basic strategy goes like this.  Produce an empty database
  25. *        with one field/column for each unique value of input field
  26. *        colfld, plus one additional field for input field rowfld values.
  27. *        This process determines the column headings in the database.
  28. *        Next fill in the rows, but only for the first field in the output
  29. *        database--the one that contains values for input field rowfld.
  30. *        At this point, we have column headings "across the top"
  31. *        and row identifiers "down the side."  Finally, look up
  32. *        the cell values for the row/column intersections and put
  33. *        them into the output database.
  34. *
  35. * Parameters:
  36. *
  37. *          Parm1 - output file/cursor name (default "xtab.dbf")
  38. *          Parm2 - cursor only (default .F.)
  39. *          Parm3 - close input table after (default .T.)
  40. *          Parm4 - show thermometer (default .T.)
  41. *          Parm5 - row field     (default 1)
  42. *          Parm6 - column field     (default 2)
  43. *          Parm7 - data field     (default 3)
  44. *          Parm8 - total rows    (default .F.)
  45. *          Parm9 - totaling options (0-sum, 1-count, 2-% of total)
  46. *
  47. * Calling example:
  48. *
  49. *         oNewXtab=CREATE('genxtab','query',.T.,.T.,.T.,1,6,10,.T.,0)
  50. *         oNewXtab.MakeXtab()
  51. *
  52. ***********************************************************************
  53. #DEFINE    C_LOCATEDBF_LOC        "Please locate the input database:"
  54. #DEFINE    C_OUTPUT_LOC        "The input and output databases must be different."
  55. #DEFINE    C_NEED3FLDS_LOC        "Crosstab input databases require at least three fields"
  56. #DEFINE    C_EMPTYDBF_LOC        "Cannot prepare crosstab on empty database"
  57. #DEFINE    C_BADROWFLD_LOC        "The crosstab row field in the input; database cannot be a memo, general or picture  field."
  58. #DEFINE    C_BADCOLFLD_LOC        "The crosstab column field in the input; database cannot be a memo, general or picture field."
  59. #DEFINE    C_BADCELLFLD_LOC    "The crosstab cell field in the input; database cannot be a memo, general or picture field."
  60. #DEFINE    C_NOCOLS_LOC        "No columns found."
  61. #DEFINE    C_XSVALUES_LOC        "There are too many unique values for column field. The maximum is 254."
  62. #DEFINE    C_ENDOUTFILE_LOC    "Unexpected end of output file. The input file may be out of sequence."
  63. #DEFINE    C_UNKNOWNFLD_LOC    "Unknown field type."
  64. #DEFINE    C_XTABTERM_LOC        "Cross tabulation process halted prematurely. Do you want to continue?"
  65. #DEFINE    C_THERM1_LOC        "Generating cross-tabulation ..."
  66. #DEFINE    SUM_FIELDS            0
  67. #DEFINE    COUNT_FIELDS        1
  68. #DEFINE    PERCENT_FIELDS        2
  69.  
  70. LPARAMETER m.p1,m.p2,m.p3,m.p4,m.p5,m.p6,m.p7,m.p8,m.p9
  71. oNewXtab=CREATE("genxtab",m.p1,m.p2,m.p3,m.p4,m.p5,m.p6,m.p7,m.p8,m.p9)
  72. oNewXtab.MakeXtab()
  73.  
  74. DEFINE CLASS genxtab AS custom
  75.  
  76.     * Environment settings
  77.     xtalk_stat = ""
  78.     xsafe_stat = ""
  79.     xesc_stat = ""
  80.     mfieldsto = ""
  81.     fields = ""
  82.     udfparms = ""
  83.     mmacdesk = ""
  84.     in_esc = ""
  85.     outstem  = ""
  86.     failxtab = .F.
  87.     
  88.     * Paramter defaults
  89.     outfname = "xtab.dbf"
  90.     cursonly = .F.
  91.     closeinput = .T.
  92.     therm_on = .T.
  93.     rowfld = 1
  94.     colfld = 2
  95.     cellfld = 3
  96.     xfoot = .F.
  97.     totaltype = 0
  98.     
  99.     * Default field names
  100.     char_blank =     "C_BLANK"
  101.     date_blank =     "D_BLANK"
  102.     null_field =     "NULL"
  103.     sumtotalfld =    "Total"
  104.     counttotalfld =    "Count"
  105.     perctotalfld =    "Percent"
  106.  
  107.     cCountFldType   = "N"
  108.     nCountFldLen    = 4
  109.     nCountFldDec    = 0
  110.     cPercentFldType = "N"
  111.     nPercentFldLen    = 7
  112.     nPercentFldDec    = 3
  113.  
  114.     * Misc thermometer stuff
  115.       g_thermwidth = 0
  116.       lHasModalFormOnTop = .F.
  117.       cOldMessage = ""
  118.  
  119.     * Map European characters to these
  120.     stdascii  = 'ueaaaaceeeiiAaEaAooouuyouaiounN'
  121.     badchars  = 'üéâäàåçêëèïîÄÅÉæÆôöòûùÿÖÜáíóúñÑ/\,-=:;{}[]!@#$%^&*.<>()?'+;
  122.        '+|Ç¢£¥₧ƒªº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧'+;
  123.        '╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■'+CHR(39)+" "
  124.  
  125.  
  126. *!*********************************************************************
  127. *!
  128. *!       PROCEDURE INIT
  129. *!
  130. *!*********************************************************************
  131. PROCEDURE INIT
  132.  
  133.     PARAMETERS outfname, cursonly, closeinput, showtherm, rowfld, colfld, cellfld, xfoot, totaltype
  134.  
  135.     LOCAL cname,nParms,goodchars,i
  136.     m.nParms = PARAMETERS() 
  137.  
  138.     THIS.save_env()
  139.  
  140.     * Set parameters or use default values
  141.     
  142.     IF m.nParms > 0 AND TYPE("m.outfname") = "C"
  143.        THIS.outfname = m.outfname
  144.     ENDIF
  145.     
  146.     IF m.nParms > 1 AND TYPE("m.cursonly") = "L"
  147.         THIS.cursonly = m.cursonly
  148.     ELSE
  149.        * Default to creating the same kind of output as we got as input.
  150.        * If the input "database" is a cursor, make the output a cursor.
  151.        * If the input "database" is an actual database, make the output a table.
  152.        m.cname = THIS.justfname(DBF())
  153.        IF ISDIGIT(LEFT(m.cname,1))
  154.           THIS.cursonly = .T.
  155.        ENDIF
  156.     ENDIF
  157.     
  158.     IF m.nParms > 2 AND TYPE("m.closeinput") = "L"
  159.        * Close the input database
  160.        THIS.closeinput = m.closeinput
  161.     ENDIF
  162.  
  163.     IF m.nParms > 3 AND TYPE("m.showtherm ") = "L"
  164.        * show the thermometer
  165.        THIS.Therm_On = m.showtherm 
  166.     ENDIF
  167.     
  168.     IF m.nParms > 4 AND TYPE("m.rowfld ") = "N"
  169.        * the field position in the input database for the crosstab rows
  170.        THIS.rowfld = m.rowfld
  171.     ENDIF
  172.     
  173.     IF m.nParms > 5  AND TYPE("m.colfld") = "N"
  174.        * the field position in the input database for the crosstab columns
  175.        THIS.colfld = m.colfld
  176.     ENDIF
  177.     
  178.     IF m.nParms > 6  AND TYPE("m.cellfld") = "N"
  179.        * the field position in the input database for the crosstab cells
  180.        THIS.cellfld = m.cellfld 
  181.     ENDIF
  182.     
  183.     IF m.nParms  > 7 AND TYPE("m.xfoot") = "L"
  184.        * Create a total field
  185.        THIS.xfoot = m.xfoot
  186.     ENDIF
  187.  
  188.     IF m.nParms  > 8 AND TYPE("m.totaltype") = "N"
  189.        * Create a total field
  190.        THIS.totaltype = m.totaltype
  191.     ENDIF
  192.  
  193.     THIS.outfname = THIS.removequotes(THIS.outfname)
  194.     THIS.outstem = THIS.juststem(THIS.outfname)
  195.     
  196.     * Let's set the true bad characters which aren't allowed in fields
  197.     * Note: this will differ based on code page
  198.     m.goodchars=""
  199.     FOR i = 1 TO LEN(THIS.badchars)
  200.         IF ISALPHA(SUBSTR(THIS.badchars,m.i,1))
  201.             m.goodchars = m.goodchars + SUBSTR(THIS.badchars,m.i,1)
  202.         ENDIF
  203.     ENDFOR
  204.     THIS.badchars = CHRTRAN(THIS.badchars,m.goodchars,'')
  205.     
  206. ENDPROC
  207.  
  208. *!*********************************************************************
  209. *!
  210. *!       PROCEDURE save_env
  211. *!
  212. *!*********************************************************************
  213. PROCEDURE save_env
  214.     IF SET("TALK") = "ON"
  215.        SET TALK OFF
  216.        THIS.xtalk_stat = "ON"
  217.     ELSE
  218.        THIS.xtalk_stat = "OFF"
  219.     ENDIF
  220.  
  221.     THIS.cOldMessage = SET("MESSAGE",1)
  222.     THIS.xsafe_stat = SET("SAFETY")
  223.     SET SAFETY OFF
  224.     THIS.xesc_stat = SET("ESCAPE")
  225.     SET ESCAPE ON
  226.     THIS.mfieldsto = SET("FIELDS",1)
  227.     THIS.fields = SET("FIELDS")
  228.     SET FIELDS TO
  229.     SET FIELDS OFF
  230.     THIS.udfparms = SET("UDFPARMS")
  231.     SET UDFPARMS TO VALUE
  232.  
  233.     #IF "MAC" $ UPPER(VERSION(1))
  234.        IF _MAC
  235.           THIS.mmacdesk = SET("MACDESKTOP")
  236.            SET MACDESKTOP ON
  237.        ENDIF
  238.     #ENDIF
  239.  
  240.     THIS.in_esc = ON('ESCAPE')
  241. ENDPROC
  242.  
  243. *!*********************************************************************
  244. *!
  245. *!       PROCEDURE Destroy
  246. *!
  247. *!*********************************************************************
  248. PROCEDURE Destroy
  249.  
  250. PRIVATE docancl,cTmpStr
  251.  
  252. IF USED("XTABTEMP")
  253.    USE IN xtabtemp
  254. ENDIF
  255.  
  256. IF FILE("xtabtemp.dbf")
  257.    DELETE FILE xtabtemp.dbf
  258. ENDIF
  259. IF EMPTY(THIS.cOldMessage)
  260.     SET MESSAGE TO
  261. ELSE
  262.     SET MESSAGE TO THIS.cOldMessage
  263. ENDIF
  264. m.cTmpStr = THIS.mfieldsto
  265. SET FIELDS TO &cTmpStr
  266. IF THIS.fields = "ON"
  267.        SET FIELDS ON
  268. ELSE
  269.        SET FIELDS OFF
  270. ENDIF
  271.  
  272. cTmpStr=THIS.udfparms
  273. SET UDFPARMS TO &cTmpStr
  274.  
  275. IF THIS.xsafe_stat = "ON"
  276.    SET SAFETY ON
  277. ENDIF
  278. IF THIS.xesc_stat = "ON"
  279.    SET ESCAPE ON
  280. ELSE
  281.    SET ESCAPE OFF
  282. ENDIF
  283. IF THIS.xtalk_stat = "ON"
  284.    SET TALK ON
  285. ENDIF
  286. #IF "MAC" $ UPPER(VERSION(1))
  287.    IF _MAC
  288.        m.cTmpStr = THIS.mmacdesk
  289.        SET MACDESKTOP &cTmpStr 
  290.    ENDIF
  291. #ENDIF
  292.  
  293. cTmpStr = THIS.in_esc
  294. ON ESCAPE &cTmpStr
  295.  
  296. IF THIS.failxtab    
  297.     THIS.outfname = ''
  298.     THIS.deactthermo()
  299. ENDIF
  300.  
  301. ENDPROC
  302.  
  303. *!*********************************************************************
  304. *!
  305. *!       Function: MakeXTab()
  306. *!
  307. *!*********************************************************************
  308. PROCEDURE MakeXTab
  309.     * Set ON ESCAPE here
  310.     LOCAL oThisXtab,aXtabs
  311.     DIMENSION aXtabs[1]
  312.     =AINSTANCE(aXtabs,'genxtab')
  313.     oThisXtab = aXtabs[1]+".esc_proc()"
  314.     ON ESCAPE &oThisXtab
  315.     
  316.     * Call main program
  317.     THIS.RunXTab()
  318. ENDPROC
  319.  
  320. *!*********************************************************************
  321. *!
  322. *!       Function: RunXTab()
  323. *!
  324. *!*********************************************************************
  325. PROCEDURE RunXTab
  326.  
  327. LOCAL dbfname,dbfstem,ok,cdec,i
  328. LOCAL numflds,rowfldname,colfldname,cellfldname
  329. LOCAL totfldname,gtotal,outf1name,f1,f2,f3
  330. LOCAL colcnt,coluniq,outarray
  331. LOCAL sumallflds,RowFldType 
  332. DIMENSION colcnt[1],coluniq[1],outarray[1]
  333.  
  334. m.dbfname = ALIAS()
  335. m.dbfstem = THIS.Juststem(m.dbfname)
  336.  
  337. * Select one, if no database is open in the current workarea
  338. m.ok = .F.
  339. DO WHILE NOT m.ok
  340.    DO CASE
  341.    CASE EMPTY(m.dbfname)
  342.       m.dbfname = GETFILE('DBF',C_LOCATEDBF_LOC)
  343.       m.dbfstem = THIS.juststem(m.dbfname)
  344.       IF EMPTY(m.dbfname)
  345.          * User canceled out of dialog, so quit the program
  346.          THIS.failxtab = .T.
  347.          RETURN
  348.       ENDIF
  349.    CASE FULLPATH(THIS.defaultext(m.dbfname,'DBF')) == ;
  350.          FULLPATH(THIS.defaultext(THIS.outfname,'DBF'))
  351.       THIS.ALERT(C_OUTPUT_LOC)
  352.       m.dbfname = ''
  353.    OTHERWISE
  354.       IF USED(m.dbfstem)
  355.          SELECT (m.dbfstem)
  356.       ELSE
  357.          SELECT 0
  358.          USE (m.dbfname) ALIAS (m.dbfstem)
  359.       ENDIF
  360.       IF FCOUNT() < 3
  361.          THIS.ALERT(C_NEED3FLDS_LOC)
  362.          m.dbfname = ''
  363.       ELSE
  364.          ok = .T.
  365.       ENDIF
  366.    ENDCASE
  367. ENDDO
  368.  
  369. IF RECCOUNT() = 0
  370.     THIS.ALERT(C_EMPTYDBF_LOC)
  371.     THIS.failxtab = .T.
  372.     RETURN
  373. ENDIF
  374.    
  375. * Gather information on the currently selected database fields
  376.  
  377. DIMENSION inpfields[FCOUNT(),4]
  378. m.numflds = AFIELDS(inpfields)
  379.  
  380. * Map the physical input database field to logical field positions
  381.  
  382. m.rowfldname    = inpfields[THIS.rowfld,1]
  383. m.colfldname    = inpfields[THIS.colfld,1]
  384. m.cellfldname   = inpfields[THIS.cellfld,1]
  385.  
  386. * None of these fields are allowed to be memo fields
  387. IF inpfields[THIS.rowfld,2] $ 'MGP'
  388.    THIS.ALERT(C_BADROWFLD_LOC)
  389.    THIS.failxtab = .T.
  390.    RETURN
  391. ENDIF
  392. IF inpfields[THIS.colfld,2] $ 'MGP'
  393.    THIS.ALERT(C_BADCOLFLD_LOC)
  394.    THIS.failxtab = .T.
  395.    RETURN
  396. ENDIF
  397. IF inpfields[THIS.cellfld,2] $ 'MGP'
  398.    THIS.ALERT(C_BADCELLFLD_LOC)
  399.    THIS.failxtab = .T.
  400.    RETURN
  401. ENDIF
  402.  
  403. THIS.acttherm(C_THERM1_LOC)
  404. THIS.updtherm(5)
  405.  
  406. * Count the number of columns we need to create the cross tab.
  407. * This step could be combined with the following one so that there
  408. * would only be one SELECT operation performed.  It is coded in this
  409. * way to avoid running out of memory if there are an unexpectedly
  410. * large number of unique values of field 2 in the input database.
  411.  
  412. SELECT COUNT(DISTINCT &colfldname) FROM (m.dbfname) INTO ARRAY colcnt
  413.  
  414. DO CASE
  415. CASE colcnt[1] > 254
  416.    THIS.ALERT(C_XSVALUES_LOC)
  417.    THIS.failxtab = .T.
  418.    RETURN
  419. CASE colcnt[1] = 0
  420.    THIS.ALERT(C_NOCOLS_LOC)
  421.    THIS.failxtab = .T.
  422.    RETURN
  423. ENDCASE
  424.  
  425. * Get the number of decimal places in numeric fields
  426. * and extract all the unique values of colfldname  
  427. IF inpfields[THIS.colfld,2] $ 'NF'   && numeric or floating field
  428.    m.cdec = inpfields[THIS.colfld,4]
  429.    * Handle numbers separately to preserve correct sort order
  430.    SELECT DISTINCT &colfldname ;
  431.       FROM (m.dbfname) INTO ARRAY coluniq
  432.    FOR i = 1 TO ALEN(coluniq)
  433.       coluniq[m.i] = THIS.mapname(coluniq[m.i],m.cdec)
  434.    ENDFOR
  435. ELSE        && non-numeric field
  436.    m.cdec = 0
  437.    * Create an array to hold the output database fields.
  438.    SELECT DISTINCT EVAL("THIS.mapname(&colfldname,m.cdec)") FROM (m.dbfname) INTO ARRAY coluniq
  439. ENDIF
  440.  
  441. THIS.updtherm(15)
  442.  
  443. * The field type, length and decimals in the output array control the
  444. * cross-tab cells
  445. IF !THIS.xfoot
  446.    DIMENSION outarray[ALEN(coluniq)+1,4]
  447. ELSE
  448.    DIMENSION outarray[ALEN(coluniq)+2,4]
  449. ENDIF
  450.  
  451. * Field 1 in the output DBF holds the unique values of the row input field.
  452. * It is handled separately from the other fields, which take their names
  453. * from input database colfld and their parameters (e.g., length) from
  454. * input database cellfld.
  455.  
  456. outarray[1,1] = THIS.mapname(inpfields[THIS.rowfld,1])
  457. outarray[1,2] = inpfields[THIS.rowfld,2]                        && field type
  458. outarray[1,3] = inpfields[THIS.rowfld,3]                         && field length
  459. outarray[1,4] = inpfields[THIS.rowfld,4]                        && decimals
  460.  
  461. m.RowFldType = outarray[1,2]
  462.  
  463. FOR i = 2 TO ALEN(coluniq) + 1
  464.    outarray[m.i,1] = THIS.mapname(coluniq[m.i-1],m.cdec)
  465.    outarray[m.i,2] = inpfields[THIS.cellfld,2]                  && field type
  466.    outarray[m.i,3] = inpfields[THIS.cellfld,3]                  && field length
  467.    outarray[m.i,4] = inpfields[THIS.cellfld,4]                  && decimals
  468. ENDFOR
  469.  
  470. * Create a field for the cross-footing, if that option was selected
  471. * By default, make sure we have a numeric field here
  472.  
  473. * Check type of data field, and use count if not numeric.
  474. IF ATC(inpfields[THIS.cellfld,2],"NFYB") = 0 
  475.     THIS.totaltype = COUNT_FIELDS
  476. ENDIF
  477.  
  478. IF THIS.xfoot
  479.    DO CASE
  480.    CASE THIS.totaltype = COUNT_FIELDS
  481.            * Since Max columns is 256, assume N (4)
  482.        outarray[ALEN(coluniq)+2,1] = THIS.counttotalfld
  483.        outarray[ALEN(coluniq)+2,2] = THIS.cCountFldType    && field type
  484.        outarray[ALEN(coluniq)+2,3] = THIS.nCountFldLen    && field length
  485.        outarray[ALEN(coluniq)+2,4] = THIS.nCountFldDec    && field length
  486.    CASE THIS.totaltype = PERCENT_FIELDS
  487.            * Percent of total, use three decimals
  488.           outarray[ALEN(coluniq)+2,1] = THIS.perctotalfld
  489.        outarray[ALEN(coluniq)+2,2] = THIS.cPercentFldType    && field type
  490.        outarray[ALEN(coluniq)+2,3] = THIS.nPercentFldLen    && field length
  491.          outarray[ALEN(coluniq)+2,4] = THIS.nPercentFldDec    && decimals
  492.    OTHERWISE
  493.        outarray[ALEN(coluniq)+2,1] = THIS.sumtotalfld
  494.        outarray[ALEN(coluniq)+2,2] = inpfields[THIS.cellfld,2]           && field type
  495.        outarray[ALEN(coluniq)+2,4] = inpfields[THIS.cellfld,4]           && decimals
  496.         IF ATC(inpfields[THIS.cellfld,2],"YB")#0
  497.            outarray[ALEN(coluniq)+2,3] = inpfields[THIS.cellfld,3]        && field length    
  498.         ELSE
  499.              * Add a little extra space for calculations
  500.            outarray[ALEN(coluniq)+2,3] = MIN(inpfields[THIS.cellfld,3]+2,20)    && field length
  501.         ENDIF
  502.     ENDCASE
  503. ENDIF    
  504.  
  505. * Make sure that the output file is not already in use somewhere
  506. IF USED(THIS.outstem)
  507.    SELECT (THIS.outstem)
  508.    USE
  509. ENDIF
  510.  
  511.  
  512. IF !THIS.cursonly
  513.    CREATE TABLE (THIS.outfname) FROM ARRAY outarray
  514. ELSE
  515.    CREATE CURSOR (THIS.outstem) FROM ARRAY outarray
  516. ENDIF
  517.  
  518. THIS.updtherm(25)
  519.  
  520. * Get rid of the temporary arrays
  521. RELEASE outarray, coluniq, inpfields
  522.  
  523. * -------------------------------------------------------------------------
  524. * Add output database rows and replace the first field
  525. * -------------------------------------------------------------------------
  526.  
  527. * Select distinct rows into a table (instead of an array) so that 
  528. * there can be lots of rows.  If we select into an array, we may 
  529. * run out of RAM if there are many rows.
  530.  
  531. SELECT DISTINCT &rowfldname FROM (m.dbfname) INTO TABLE xtabtemp
  532. THIS.updtherm(30)
  533.  
  534. SELECT (THIS.outstem)
  535. GO TOP
  536. APPEND FROM xtabtemp FIELD (FIELD(1))
  537.  
  538. THIS.updtherm(35)
  539.  
  540. * -------------------------------------------------------------------------
  541. * Look up and replace the cell values
  542. * -------------------------------------------------------------------------
  543. *
  544. * This algorithm makes one pass through the input file, dropping its
  545. * values into the output file.  It exploits the fact that the output
  546. * file is known to be in row order.
  547. *
  548.  
  549. * Start at the top of the output file
  550. SELECT (THIS.outstem)
  551. GOTO TOP
  552. outf1name = FIELD(1)
  553.  
  554. * Start at the top of the input file
  555. SELECT (m.dbfstem)
  556. GOTO TOP
  557.  
  558. SCAN
  559.    m.f1 = EVAL(m.rowfldname)                          && get next row value from input
  560.    m.f2 = THIS.mapname(EVAL(m.colfldname),m.cdec)   && get corresponding column value
  561.    m.f3 = EVAL(m.cellfldname)                         && get cell value
  562.    
  563.    * Find the right row in the output file
  564.    SELECT (THIS.outstem)
  565.    DO WHILE !(EVAL(outf1name) == m.f1) AND !EOF()
  566.       SKIP
  567.    ENDDO
  568.    
  569.    IF !EOF()
  570.       IF TYPE(m.f2) $ "NFYB"
  571.          REPLACE (m.f2) WITH &f2 + m.f3 
  572.       ELSE
  573.          REPLACE (m.f2) WITH m.f3
  574.       ENDIF
  575.    ELSE
  576.       THIS.ALERT(C_ENDOUTFILE_LOC)
  577.       THIS.failxtab = .T.
  578.       RETURN
  579.    ENDIF
  580.    
  581.    SELECT (m.dbfstem)
  582.    
  583.    * Map thermometer to remaining portion of display
  584.    DO CASE
  585.       CASE RECCOUNT() > 1000
  586.          IF RECNO() % 100 = 0
  587.             THIS.updtherm(INT(RECNO() / RECCOUNT() * 65)+ 35)
  588.          ENDIF
  589.       OTHERWISE
  590.          IF RECNO() % 10  = 0
  591.             THIS.updtherm(INT(RECNO() / RECCOUNT() * 65)+ 35)
  592.          ENDIF
  593.    ENDCASE
  594. ENDSCAN
  595.  
  596.  
  597. * Cross-foot the columns and put the results into the total field
  598. IF THIS.xfoot
  599.    SELECT (THIS.outstem)
  600.    m.totfldname = FIELD(FCOUNT())
  601.    IF THIS.totaltype = PERCENT_FIELDS
  602.      * Need to get total here
  603.      PRIVATE aSums,nFirstField
  604.      m.nFirstField = IIF(ATC(m.RowFldType,"NFYB")=0,1,2)
  605.      SUM ALL TO ARRAY aSums
  606.      m.sumallflds = 0
  607.      FOR i = m.nFirstField TO (ALEN(aSums)-1)        &&skip last field which has totals
  608.          m.sumallflds = m.sumallflds + aSums[m.i] 
  609.      ENDFOR
  610.    ENDIF
  611.    SCAN
  612.       * Sum the relevant fields
  613.       m.gtotal = 0
  614.       FOR i = 2 TO FCOUNT() - 1
  615.            DO CASE
  616.         CASE THIS.totaltype = COUNT_FIELDS
  617.              m.gtotal = m.gtotal + IIF( EMPTY(EVAL(FIELD(m.i))) OR ISNULL(EVAL(FIELD(m.i))),0,1)          
  618.           OTHERWISE
  619.              m.gtotal = m.gtotal + EVAL(FIELD(m.i))
  620.           ENDCASE
  621.       ENDFOR
  622.       IF THIS.totaltype = PERCENT_FIELDS
  623.           m.gtotal = IIF(m.sumallflds=0 OR m.gtotal=0,0,ROUND(m.gtotal/m.sumallflds*100,THIS.nPercentFldDec))
  624.       ENDIF
  625.       REPLACE (m.totfldname) WITH m.gtotal
  626.    ENDSCAN
  627. ENDIF
  628.  
  629. THIS.updtherm(100)
  630. THIS.deactthermo()
  631.  
  632. IF USED("XTABTEMP")
  633.    USE IN xtabtemp
  634. ENDIF
  635.  
  636. IF FILE("xtabtemp.dbf")
  637.    DELETE FILE xtabtemp.dbf
  638. ENDIF
  639.  
  640. * Close the input database
  641. IF THIS.closeinput
  642.    SELECT (m.dbfstem)
  643.    USE
  644. ENDIF
  645.  
  646. * Leave the output database/cursor selected
  647. SELECT (THIS.outstem)
  648. GOTO TOP
  649.  
  650. * Do closing housekeeping
  651. RETURN
  652. ENDPROC
  653.  
  654.  
  655. *!*********************************************************************
  656. *!
  657. *!       Function: MAPNAME()
  658. *!
  659. *!*********************************************************************
  660. FUNCTION mapname
  661. * Translate a field value of any type into a string containing a valid
  662. * field name.
  663.  
  664. PARAMETER in_name, in_dec
  665. LOCAL retval 
  666.  
  667. IF PARAMETERS() = 1
  668.    m.in_dec = 0
  669. ENDIF
  670. DO CASE
  671. CASE ISNULL(m.in_name)
  672.     m.retval = THIS.null_field 
  673. CASE TYPE("m.in_name") $ 'CM'
  674.    DO CASE
  675.    CASE EMPTY(m.in_name)
  676.       m.retval = THIS.char_blank
  677.    OTHERWISE
  678.          * We need to replace bad characters here with "_"
  679.       m.retval = SUBSTR(CHRTRAN(m.in_name,THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1)),1,10)
  680.       IF !ISALPHA(LEFT(m.retval,1))
  681.          m.retval = 'C_'+LEFT(m.retval,8)
  682.       ENDIF
  683.    ENDCASE
  684. CASE TYPE("m.in_name") $ 'NFYB'
  685.    m.retval = 'N_'+ALLTRIM(CHRTRAN(STR(m.in_name,8,in_dec),'.',''))
  686. CASE TYPE("m.in_name") $ 'DT'
  687.    DO CASE
  688.    CASE EMPTY(m.in_name)
  689.       m.retval = THIS.date_blank
  690.    OTHERWISE
  691.       m.retval = 'D_' + CHRTRAN(DTOS(m.in_name),THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1))
  692.    ENDCASE
  693. CASE TYPE("m.in_name") = 'L'
  694.    IF m.in_name = .T.
  695.       m.retval = 'T'
  696.    ELSE
  697.       m.retval = 'F'
  698.    ENDIF
  699. OTHERWISE
  700.    * Should never happen
  701.    THIS.alert(C_UNKNOWNFLD_LOC)
  702.    RETURN ""
  703. ENDCASE
  704.  
  705. RETURN PADR(UPPER(ALLTRIM(m.retval)),10)
  706.  
  707. ENDFUNC
  708.  
  709.  
  710. *!*********************************************************************
  711. *!
  712. *!      Procedure: ERROR
  713. *!
  714. *!*********************************************************************
  715. PROCEDURE ERROR
  716. PARAMETERS nError, cMethod, nLine
  717.  
  718. THIS.alert('Line : '+ALLTRIM(STR(m.nLine))+CHR(13) ;
  719.    +'Program: '+m.cMethod+CHR(13) ;
  720.    +'Error: '+ALLT(STR(nError))+CHR(13) ;
  721.    +'Message: '+MESSAGE()+CHR(13);
  722.    +'Code: '+MESSAGE(1))
  723.    THIS.failxtab = .T.
  724.    RETURN TO MakeXtab
  725. ENDPROC
  726.  
  727. *!*********************************************************************
  728. *!
  729. *!      Procedure: ALERT
  730. *!
  731. *!*********************************************************************
  732. PROCEDURE alert
  733. LPARAMETERS strg
  734. =MESSAGEBOX(m.strg)
  735. RETURN
  736. ENDPROC
  737.  
  738. *!*********************************************************************
  739. *!
  740. *!      Procedure: ESC_PROC
  741. *!
  742. *!*********************************************************************
  743. PROCEDURE esc_proc
  744.     CLEAR TYPEAHEAD
  745.     IF MESSAGEBOX(C_XTABTERM_LOC,36) = 6
  746.         RETURN
  747.     ELSE
  748.         THIS.failxtab = .T.
  749.         RETURN TO MakeXtab
  750.     ENDIF
  751. ENDPROC
  752.  
  753. *!*****************************************************************************
  754. *!
  755. *!      Procedure: PARTIALFNAME
  756. *!
  757. *!*****************************************************************************
  758. FUNCTION partialfname
  759. PARAMETER m.filname, m.fillen
  760. * Return a filname no longer than m.fillen characters.  Take some chars
  761. * out of the middle if necessary.  No matter what m.fillen is, this function
  762. * always returns at least the file stem and extension.
  763. PRIVATE m.bname, m.elipse
  764. m.elipse = "..." + c_pathsep
  765. m.bname = THIS.justfname(m.filname)
  766. DO CASE
  767. CASE LEN(m.filname) <= m.fillen 
  768.    RETURN filname
  769. CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen
  770.    RETURN m.bname
  771. OTHERWISE
  772.    m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0)
  773.    RETURN LEFT(THIS.justpath(m.filname),remain)+m.elipse+m.bname
  774. ENDCASE
  775. ENDFUNC
  776.  
  777. *!*****************************************************************************
  778. *!
  779. *!      Procedure: removequotes
  780. *!
  781. *!*****************************************************************************
  782. FUNCTION removequotes
  783. PARAMETER m.fname
  784. PRIVATE m.leftchar, m.rightchar
  785. m.fname = ALLTRIM(m.fname)
  786. m.leftchar = LEFT(m.fname,1)
  787. m.rightchar = RIGHT(m.fname, 1)
  788.  
  789. IF m.leftchar = '"' AND m.rightchar = '"'    ;
  790.     OR m.leftchar = "'" AND m.rightchar = "'"  ;
  791.     OR m.leftchar = '[' AND m.rightchar = ']'
  792.         RETURN SUBSTR(m.fname, 2, LEN(m.fname) - 2)
  793. ELSE
  794.    RETURN m.fname        
  795. ENDIF
  796. ENDFUNC
  797.  
  798. *!*********************************************************************
  799. *!
  800. *!       Function: JUSTSTEM()
  801. *!
  802. *!*********************************************************************
  803. FUNCTION juststem
  804. * Return just the stem name from "filname"
  805. PARAMETERS filname
  806. PRIVATE ALL
  807. IF RAT('\',m.filname) > 0
  808.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  809. ENDIF
  810. IF RAT(':',m.filname) > 0
  811.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  812. ENDIF
  813. IF RAT('.',m.filname) > 0
  814.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1)
  815. ENDIF
  816. RETURN ALLTRIM(UPPER(m.filname))
  817. ENDFUNC
  818.  
  819. *!*********************************************************************
  820. *!
  821. *!      Procedure: FORCEEXT
  822. *!
  823. *!*********************************************************************
  824. FUNCTION forceext
  825. * Force the extension of "filname" to be whatever ext is.
  826. PARAMETERS filname,ext
  827. PRIVATE ALL
  828. IF SUBSTR(m.ext,1,1) = "."
  829.    m.ext = SUBSTR(m.ext,2,3)
  830. ENDIF
  831.  
  832. m.pname = THIS.justpath(m.filname)
  833. m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  834. IF RAT('.',m.filname) > 0
  835.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1) + '.' + m.ext
  836. ELSE
  837.    m.filname = m.filname + '.' + m.ext
  838. ENDIF
  839. RETURN THIS.addbs(m.pname) + m.filname
  840. ENDFUNC
  841.  
  842. *!*********************************************************************
  843. *!
  844. *!       Function: DEFAULTEXT()
  845. *!
  846. *!*********************************************************************
  847. FUNCTION defaultext
  848. * Add a default extension to "filname" if it doesn't have one already
  849. PARAMETERS filname,ext
  850. PRIVATE ALL
  851. IF SUBSTR(ext,1,1) = "."
  852.    m.ext = SUBSTR(m.ext,2,3)
  853. ENDIF
  854.  
  855. m.pname = THIS.justpath(m.filname)
  856. m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  857. IF !EMPTY(m.filname) AND AT('.',m.filname) = 0
  858.    m.filname = m.filname + '.' + m.ext
  859.    RETURN THIS.addbs(m.pname) + m.filname
  860. ELSE
  861.    RETURN filname
  862. ENDIF
  863. ENDFUNC
  864.  
  865. *!*********************************************************************
  866. *!
  867. *!       Function: JUSTFNAME()
  868. *!
  869. *!*********************************************************************
  870. FUNCTION justfname
  871. * Return just the filename (i.e., no path) from "filname"
  872. PARAMETERS filname
  873. PRIVATE ALL
  874. IF RAT('\',m.filname) > 0
  875.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  876. ENDIF
  877. IF RAT(':',m.filname) > 0
  878.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  879. ENDIF
  880. RETURN ALLTRIM(UPPER(m.filname))
  881. ENDPROC
  882.  
  883. *!*********************************************************************
  884. *!
  885. *!      Procedure: JUSTPATH
  886. *!
  887. *!*********************************************************************
  888. FUNCTION justpath
  889. * Return just the path name from "filname"
  890. PARAMETERS m.filname
  891. PRIVATE ALL
  892. m.filname = ALLTRIM(UPPER(m.filname))
  893. m.pathsep = IIF(_MAC,":", "\")
  894. IF _MAC
  895.    m.found_it = .F.
  896.    m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname))
  897.    IF m.maxchar > 0
  898.       m.filname = SUBSTR(m.filname,1,m.maxchar)
  899.       IF RIGHT(m.filname,1) $ ":\" AND LEN(m.filname) > 1 ;
  900.             AND !(SUBSTR(m.filname,LEN(m.filname)-1,1)  $ ":\")
  901.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  902.       ENDIF
  903.       RETURN m.filname
  904.    ENDIF
  905. ELSE
  906.    IF m.pathsep $ filname
  907.       m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname))
  908.       IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ;
  909.             AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep
  910.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  911.       ENDIF
  912.       RETURN m.filname
  913.    ENDIF      
  914. ENDIF
  915. RETURN ''
  916. ENDPROC
  917.  
  918. *!*********************************************************************
  919. *!
  920. *!      Procedure: ADDBS
  921. *!
  922. *!*********************************************************************
  923. FUNCTION addbs
  924. * Add a backslash to a path name, if there isn't already one there
  925. PARAMETER pathname
  926. PRIVATE ALL
  927. m.pathname = ALLTRIM(UPPER(m.pathname))
  928. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  929.    m.pathname = m.pathname + IIF(_MAC,":",'\')
  930. ENDIF
  931. RETURN m.pathname
  932. ENDPROC
  933.  
  934.  
  935. *!*********************************************************************
  936. *!
  937. *!      Procedure: HasModalForm
  938. *!
  939. *!*********************************************************************
  940. PROCEDURE HasModalForm
  941. * Tests to see if a modal form is active so since it conflicts with Therm
  942. LOCAL i
  943. FOR i = 1 TO _SCREEN.FormCount
  944.     IF _Screen.Forms[m.i].Windowtype = 1 OR ;
  945.      (TYPE("_Screen.Forms[m.i].Parent.Windowtype")="N" AND ;
  946.     _Screen.Forms[m.i].Parent.Windowtype = 1)
  947.         RETURN .T.
  948.         EXIT
  949.     ENDIF
  950. ENDFOR
  951. RETURN .F.
  952. ENDPROC
  953.  
  954. *!*********************************************************************
  955. *!
  956. *!      Procedure: ActTherm
  957. *!
  958. *!*********************************************************************
  959. PROCEDURE ActTherm
  960. PARAMETER prompt
  961. IF !THIS.therm_on
  962.     RETURN
  963. ENDIF
  964. * Test to see if we have a modal form up which prevents Therm window from being visible.
  965. IF THIS.HasModalForm()
  966.     THIS.lHasModalFormOnTop = .T.
  967.     RETURN
  968. ENDIF
  969.  
  970. LOCAL m.text,g_dlgface,g_dlgsize,g_dlgstyle
  971. m.g_dlgface     = IIF(_MAC,"Geneva","MS Sans Serif")
  972. m.g_dlgsize     = IIF(_MAC,10,8.000)
  973. m.g_dlgstyle = IIF(_MAC,"","B")
  974.  
  975. m.text = ""
  976. IF _MAC OR _WINDOWS
  977.    IF TXTWIDTH(m.prompt, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle) > 43
  978.       DO WHILE TXTWIDTH(m.prompt+"...", m.g_dlgface, m.g_dlgsize, m.g_dlgstyle) > 43
  979.          m.prompt = LEFT(m.prompt, LEN(m.prompt)-1)
  980.       ENDDO
  981.       m.prompt = m.prompt + "..."
  982.    ENDIF
  983.    DO CASE
  984.    CASE _WINDOWS
  985.       DEFINE WINDOW thermomete ;
  986.          AT  INT((SROW() - (( 5.615 * ;
  987.          FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  988.          FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  989.          INT((SCOL() - (( 63.833 * ;
  990.          FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  991.          FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  992.          SIZE 5.615,63.833 ;
  993.          FONT m.g_dlgface, m.g_dlgsize ;
  994.          STYLE m.g_dlgstyle ;
  995.          NOFLOAT ;
  996.          NOCLOSE ;
  997.          NONE ;
  998.          COLOR RGB(0, 0, 0, 192, 192, 192)
  999.       MOVE WINDOW thermomete CENTER
  1000.       ACTIVATE WINDOW thermomete NOSHOW
  1001.  
  1002.       @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  1003.       @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  1004.       @ 0.000,0.000 TO 0.000,63.833 ;
  1005.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1006.       @ 0.000,0.000 TO 5.615,0.000 ;
  1007.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1008.       @ 0.385,0.667 TO 5.231,0.667 ;
  1009.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1010.       @ 0.308,0.667 TO 0.308,63.167 ;
  1011.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1012.       @ 0.385,63.000 TO 5.308,63.000 ;
  1013.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1014.       @ 5.231,0.667 TO 5.231,63.167 ;
  1015.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1016.       @ 5.538,0.000 TO 5.538,63.833 ;
  1017.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1018.       @ 0.000,63.667 TO 5.615,63.667 ;
  1019.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1020.       @ 3.000,3.333 TO 4.231,3.333 ;
  1021.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1022.       @ 3.000,60.333 TO 4.308,60.333 ;
  1023.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1024.       @ 3.000,3.333 TO 3.000,60.333 ;
  1025.          COLOR RGB(128, 128, 128, 128, 128, 128)
  1026.       @ 4.231,3.333 TO 4.231,60.500 ;
  1027.          COLOR RGB(255, 255, 255, 255, 255, 255)
  1028.       THIS.g_thermwidth = 56.269
  1029.    CASE _MAC
  1030.       DEFINE WINDOW thermomete ;
  1031.          AT  INT((SROW() - (( 5.62 * ;
  1032.          FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1033.          FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  1034.          INT((SCOL() - (( 63.83 * ;
  1035.          FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1036.          FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  1037.          SIZE 5.62,63.83 ;
  1038.          FONT m.g_dlgface, m.g_dlgsize ;
  1039.          STYLE m.g_dlgstyle ;
  1040.          NOFLOAT ;
  1041.          NOCLOSE ;
  1042.             NONE ;
  1043.          COLOR RGB(0, 0, 0, 192, 192, 192)
  1044.       MOVE WINDOW thermomete CENTER
  1045.       ACTIVATE WINDOW thermomete NOSHOW
  1046.  
  1047.       IF ISCOLOR()
  1048.          @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
  1049.              COLOR RGB(192, 192, 192, 192, 192, 192)
  1050.           @ 0.000,0.000 TO 0.000,63.83 ;
  1051.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1052.           @ 0.000,0.000 TO 5.62,0.000 ;
  1053.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1054.           @ 0.385,0.67 TO 5.23,0.67 ;
  1055.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1056.           @ 0.31,0.67 TO 0.31,63.17 ;
  1057.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1058.           @ 0.385,63.000 TO 5.31,63.000 ;
  1059.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1060.           @ 5.23,0.67 TO 5.23,63.17 ;
  1061.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1062.           @ 5.54,0.000 TO 5.54,63.83 ;
  1063.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1064.           @ 0.000,63.67 TO 5.62,63.67 ;
  1065.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1066.           @ 3.000,3.33 TO 4.23,3.33 ;
  1067.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1068.           @ 3.000,60.33 TO 4.31,60.33 ;
  1069.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1070.           @ 3.000,3.33 TO 3.000,60.33 ;
  1071.              COLOR RGB(128, 128, 128, 128, 128, 128)
  1072.           @ 4.23,3.33 TO 4.23,60.33 ;
  1073.              COLOR RGB(255, 255, 255, 255, 255, 255)
  1074.       ELSE
  1075.          @ 0.000, 0.000 TO 5.62, 63.830  PEN 2
  1076.          @ 0.230, 0.500 TO 5.39, 63.333  PEN 1
  1077.        ENDIF
  1078.       @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1079.          COLOR RGB(0,0,0,192,192,192)
  1080.       @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1081.          COLOR RGB(0,0,0,192,192,192)
  1082.  
  1083.       THIS.g_thermwidth = 56.27
  1084.         IF !ISCOLOR()
  1085.                @ 3.000,3.33 TO 4.23,THIS.g_thermwidth + 3.33 
  1086.         ENDIF
  1087.    ENDCASE
  1088.    SHOW WINDOW thermomete TOP
  1089. ELSE
  1090.  
  1091.    DEFINE WINDOW thermomete;
  1092.       FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ;
  1093.       TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57;
  1094.       DOUBLE COLOR SCHEME 5
  1095.    ACTIVATE WINDOW thermomete NOSHOW
  1096.  
  1097.    THIS.g_thermwidth = 50
  1098.    @ 0,3 SAY m.prompt
  1099.    @ 2,1 TO 4,THIS.g_thermwidth+4
  1100.  
  1101.    SHOW WINDOW thermomete TOP
  1102. ENDIF
  1103. RETURN
  1104. ENDPROC
  1105.  
  1106. *!*********************************************************************
  1107. *!
  1108. *!      Procedure: updtherm 
  1109. *!
  1110. *!*********************************************************************
  1111. PROCEDURE updtherm
  1112. PARAMETER Percent
  1113. IF !THIS.therm_on
  1114.     RETURN
  1115. ENDIF
  1116. PRIVATE m.nblocks, m.percent
  1117. IF THIS.lHasModalFormOnTop
  1118.     SET MESSAGE TO C_THERM1_LOC+ALLTRIM(STR(percent))+"%"
  1119.     RETURN
  1120. ENDIF
  1121. IF !WEXIST("thermomete")
  1122.    DO acttherm WITH C_THERM1_LOC
  1123. ENDIF
  1124. ACTIVATE WINDOW thermomete
  1125.  
  1126. m.nblocks = (m.percent/100) * (THIS.g_thermwidth)
  1127. DO CASE
  1128. CASE _WINDOWS
  1129.    @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
  1130.       PATTERN 1 COLOR RGB(128, 128, 128, 128, 128, 128)
  1131. CASE _MAC
  1132.    @ 3.000,3.33 TO 4.23,m.nblocks + 3.33 ;
  1133.       PATTERN 1 COLOR RGB(0, 0, 128, 0, 0, 128)
  1134. OTHERWISE
  1135.    @ 3,3 SAY REPLICATE("█",m.nblocks)
  1136. ENDCASE
  1137. RETURN
  1138.  
  1139. ENDPROC
  1140.  
  1141. *!*********************************************************************
  1142. *!
  1143. *!      Procedure: deactthermo
  1144. *!
  1145. *!*********************************************************************
  1146. PROCEDURE deactthermo
  1147.     IF !THIS.therm_on
  1148.         RETURN
  1149.     ENDIF
  1150.     IF THIS.lHasModalFormOnTop
  1151.         RETURN
  1152.     ENDIF    
  1153.     IF WEXIST("thermomete")
  1154.        RELEASE WINDOW thermomete
  1155.     ENDIF
  1156.     RETURN
  1157. ENDPROC
  1158.  
  1159. ENDDEFINE