> >*:********************************************************************* >*: >*: Procedure file: VFPXTAB.PRG >*: >*: System: GENXTAB >*: Author: Microsoft Corp. >*: Copyright (c) 1993,1994,1995 Microsoft Corp. >*: Version: 4.0 >*: >*:********************************************************************* >*********************************************************************** >* >* Notes: This program is intended to be called by RQBE or a program >* generated by RQBE. On entry, a table should be open in the >* current work area, and it should contain at most one record >* for each cell in a cross-tabulation. This table *must* be in >* row order, or you will receive an "unexpected end of file" >* error when you run _GENXTAB. >* >* The rowfld field in each record becomes the y-axis (rows) for >* a cross-tab and the colfld field becomes the x-axis (columns) >* The actual cross-tab results are saved to the database name >* specified by "outfname." >* >* The basic strategy goes like this. Produce an empty database >* with one field/column for each unique value of input field >* colfld, plus one additional field for input field rowfld values. >* This process determines the column headings in the database. >* Next fill in the rows, but only for the first field in the output >* database--the one that contains values for input field rowfld. >* At this point, we have column headings "across the top" >* and row identifiers "down the side." Finally, look up >* the cell values for the row/column intersections and put >* them into the output database. >* >* Parameters: >* >* Parm1 - output file/cursor name (default "xtab.dbf") >* Parm2 - cursor only (default .F.) >* Parm3 - close input table after (default .T.) >* Parm4 - show thermometer (default .T.) >* Parm5 - row field (default 1) >* Parm6 - column field (default 2) >* Parm7 - data field (default 3) >* Parm8 - total rows (default .F.) >* Parm9 - totaling options (0-sum, 1-count, 2-% of total) >* Parm10 - display Null values >* >* Calling example: >* >* oNewXtab=CREATE('genxtab','query',.T.,.T.,.T.,1,6,10,.T.,0) >* oNewXtab.MakeXtab() >* >*********************************************************************** >#DEFINE C_LOCATEDBF_LOC "Input table:" >#DEFINE C_OUTPUT_LOC "The input and output databases must be different." >#DEFINE C_NEED3FLDS_LOC "Crosstab input databases require at least three fields" >#DEFINE C_EMPTYDBF_LOC "Cannot prepare crosstab on empty database" >#DEFINE C_BADROWFLD_LOC "The crosstab row field in the input; database cannot be a memo, general or picture field." >#DEFINE C_BADCOLFLD_LOC "The crosstab column field in the input; database cannot be a memo, general or picture field." >#DEFINE C_BADCELLFLD_LOC "The crosstab cell field in the input; database cannot be a memo, general or picture field." >#DEFINE C_NOCOLS_LOC "No columns found." >#DEFINE C_XSVALUES_LOC "There are too many unique values for column field. The maximum is 254." >#DEFINE C_ENDOUTFILE_LOC "Unexpected end of output file. The input file may be out of sequence. Check to see that Row field is ordered." >#DEFINE C_UNKNOWNFLD_LOC "Unknown field type." >#DEFINE C_XTABTERM_LOC "Cross tabulation process halted prematurely. Do you want to continue?" >#DEFINE C_BADALIAS_LOC "Please use a different alias from one of these reserved words -- THIS, THISFORM, THISFORMSET." > >#DEFINE ERR_LINE_LOC "Line: " >#DEFINE ERR_PROGRAM_LOC "Program: " >#DEFINE ERR_ERROR_LOC "Error: " >#DEFINE ERR_MESSAGE_LOC "Message: " >#DEFINE ERR_CODE_LOC "Code: " > >#DEFINE THERMCOMPLETE_LOC "Complete." >#DEFINE C_THERM1_LOC "Generating cross-tab output:" >#DEFINE C_THERM2_LOC "Initializing cross-tab engine" >#DEFINE C_THERM3_LOC "Reading input field information" >#DEFINE C_THERM4_LOC "Creating output datasource" >#DEFINE C_THERM5_LOC "Calculating cross-tab values" >#DEFINE C_THERM6_LOC "Totaling output columns" > >#DEFINE SUM_FIELDS 0 >#DEFINE COUNT_FIELDS 1 >#DEFINE PERCENT_FIELDS 2 >#DEFINE AVERAGE_FIELDS 3 >#DEFINE MAX_FIELDS 4 >#DEFINE MIN_FIELDS 5 > >#DEFINE WIN32FONT 'MS Sans Serif' >#DEFINE WIN95FONT 'Arial' >#DEFINE DBCS_LOC "81 82 86 88" > >#DEFINE C_SUMFIELD_LOC "Total" >#DEFINE C_COUNTFIELD_LOC "Count" >#DEFINE C_PERCENTFIELD_LOC "Percent" > > >LPARAMETER p1,p2,p3,p4,p5,p6,p7,p8,p9,p10 >* For background compatibility with FP2.x >IF PARAMETERS() < 3 > p3 = .T. >ENDIF >IF PARAMETERS() < 4 > p4 = .T. >ENDIF > >LOCAL liOldLanguageOptions >liOldLanguageOptions = _vfp.LanguageOptions >_vfp.LanguageOptions = 0 && turn off strict memvar checking (jd 11/26/00) > >oNewXtab=CREATE("genxtab",m.p1,m.p2,m.p3,m.p4,m.p5,m.p6,m.p7,m.p8,m.p9,m.p10) >IF TYPE("oNewXtab")="O" > oNewXtab.MakeXtab() >ENDIF > >oNewXTab = .F. >RELEASE oNewXTab > >_vfp.LanguageOptions = liOldLanguageOptions && restore memvar checking value (jd 11/26/00) > >RETURN > >*********************************************************************** >*********************************************************************** >DEFINE CLASS genxtab AS custom > > shownulls = .F. &&controls display of NULLs > > * Environment settings > xtalk_stat = "" > xsafe_stat = "" > xesc_stat = "" > mfieldsto = "" > fields = "" > udfparms = "" > mmacdesk = "" > in_esc = "" > outstem = "" > setnull = "" > failxtab = .F. > setcompat = "" > > * Parameter defaults > outfname = "xtab.dbf" > cursonly = .F. > closeinput = .T. > therm_on = .T. > rowfld = 1 > colfld = 2 > cellfld = 3 > xfoot = .F. > totaltype = 0 > sumtype = 0 > > * Default field names, captions and settings > char_blank = "C_BLANK" > date_blank = "D_BLANK" > null_field = "NULL" > sumtotalfld = C_SUMFIELD_LOC > counttotalfld = C_COUNTFIELD_LOC > perctotalfld = C_PERCENTFIELD_LOC > cCountFldType = "N" > nCountFldLen = 4 > nCountFldDec = 0 > cPercentFldType = "N" > nPercentFldLen = 7 > nPercentFldDec = 3 > > * Misc thermometer stuff > lHasModalFormOnTop = .F. > cOldMessage = "" > oThermRef = "" > > * Map European characters to these > stdascii = 'ueaaaaceeeiiAaEaAooouuyouaiounN' > badchars = "" > > iLanguageOptions = 0 > >*!********************************************************************* >*! >*! PROCEDURE INIT >*! >*!********************************************************************* >PROCEDURE INIT > > PARAMETERS outfname, cursonly, closeinput, showtherm, rowfld, colfld, cellfld, xfoot, totaltype, shownulls > > LOCAL cname,nParms,goodchars,i > m.nParms = PARAMETERS() > IF USED('THIS') .or. USED('THISFORM') .or. USED('THISFORMSET') > =MESSAGEBOX(C_BADALIAS_LOC) > RETURN .F. > ENDIF > THIS.save_env() > IF VERSION(3) $ DBCS_LOC > this.badchars = '/,-=:;!@#$%&*.<>()?[]\'+; > '+'+CHR(34)+CHR(39)+" " > ELSE > this.badchars = '‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š ¡¢£¤¥/\,-=:;{}[]!@#$%^&*.<>()?'+; > '+|€›œžŸ¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ'+; > 'ÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþ'+CHR(34)+CHR(39)+" " > ENDIF > > _vfp.LanguageOptions = 0 > > * Set parameters or use default values > > IF m.nParms > 0 AND TYPE("m.outfname") = "C" > THIS.outfname = m.outfname > ENDIF > > * Default to creating the same kind of output as we got as input. > * If the input "database" is a cursor, make the output a cursor. > * If the input "database" is an actual database, make the output a table. > m.cname = THIS.justfname(DBF()) > DO CASE > CASE EMPTY(m.cname) && create a table if nothing is currently selected > THIS.cursonly = .F. > CASE ATC(".DBF",THIS.outfname)#0 > THIS.cursonly = .F. > CASE ISDIGIT(LEFT(m.cname,1)) OR ATC(".TMP",m.cname)#0 > THIS.cursonly = .T. > CASE TYPE("m.cursonly") = "L" > THIS.cursonly = m.cursonly > OTHERWISE > THIS.cursonly = .F. > ENDCASE > > IF m.nParms > 2 AND TYPE("m.closeinput") = "L" > * Close the input database > THIS.closeinput = m.closeinput > ENDIF > > IF m.nParms > 3 AND TYPE("m.showtherm ") = "L" > * show the thermometer > THIS.Therm_On = m.showtherm > ENDIF > > IF m.nParms > 4 AND TYPE("m.rowfld ") = "N" > * the field position in the input database for the crosstab rows > THIS.rowfld = m.rowfld > ENDIF > > IF m.nParms > 5 AND TYPE("m.colfld") = "N" > * the field position in the input database for the crosstab columns > THIS.colfld = m.colfld > ENDIF > > IF m.nParms > 6 AND TYPE("m.cellfld") = "N" > * the field position in the input database for the crosstab cells > THIS.cellfld = m.cellfld > ENDIF > > IF m.nParms > 7 AND TYPE("m.xfoot") = "L" > * Create a total field > THIS.xfoot = m.xfoot > ENDIF > > IF m.nParms > 8 AND TYPE("m.totaltype") = "N" > * Create a total field > THIS.totaltype = m.totaltype > ENDIF > > IF m.nParms > 9 AND TYPE("m.shownulls") = "L" > * Display nulls > THIS.shownulls = m.shownulls > ENDIF > > IF THIS.shownulls > SET NULL ON > ELSE > SET NULL OFF > ENDIF > > THIS.outfname = THIS.removequotes(THIS.outfname) > THIS.outstem = THIS.juststem(THIS.outfname) > > * Let's set the true bad characters which aren't allowed in fields > * Note: this will differ based on code page > m.goodchars="" > FOR i = 1 TO LEN(THIS.badchars) > IF ISALPHA(SUBSTR(THIS.badchars,m.i,1)) > m.goodchars = m.goodchars + SUBSTR(THIS.badchars,m.i,1) > ENDIF > ENDFOR > THIS.badchars = CHRTRAN(m.THIS.badchars,m.goodchars,'') >ENDPROC > >*!********************************************************************* >*! >*! PROCEDURE save_env >*! >*!********************************************************************* >PROCEDURE save_env > IF SET("TALK") = "ON" > SET TALK OFF > THIS.xtalk_stat = "ON" > ELSE > THIS.xtalk_stat = "OFF" > ENDIF > > THIS.iLanguageOptions = _vfp.LanguageOptions > > THIS.setcompat = SET("COMP") > SET COMP OFF > THIS.cOldMessage = SET("MESSAGE",1) > THIS.xsafe_stat = SET("SAFETY") > SET SAFETY OFF > THIS.xesc_stat = SET("ESCAPE") > SET ESCAPE ON > THIS.mfieldsto = SET("FIELDS",1) > THIS.fields = SET("FIELDS") > SET FIELDS TO > SET FIELDS OFF > THIS.udfparms = SET("UDFPARMS") > SET UDFPARMS TO VALUE > THIS.setnull = SET("NULL") > > #IF "MAC" $ UPPER(VERSION(1)) > IF _MAC > THIS.mmacdesk = SET("MACDESKTOP") > SET MACDESKTOP ON > ENDIF > #ENDIF > > THIS.in_esc = ON('ESCAPE') >ENDPROC > >*!********************************************************************* >*! >*! PROCEDURE Destroy >*! >*!********************************************************************* >PROCEDURE Destroy > >PRIVATE docancl,cTmpStr > >IF USED("XTABTEMP") > USE IN xtabtemp >ENDIF > >IF FILE("xtabtemp.dbf") > DELETE FILE xtabtemp.dbf >ENDIF >IF EMPTY(THIS.cOldMessage) > SET MESSAGE TO >ELSE > SET MESSAGE TO THIS.cOldMessage >ENDIF >m.cTmpStr = THIS.mfieldsto >SET FIELDS TO &cTmpStr >IF THIS.fields = "ON" > SET FIELDS ON >ELSE > SET FIELDS OFF >ENDIF > >cTmpStr=THIS.udfparms >SET UDFPARMS TO &cTmpStr > >IF THIS.xsafe_stat = "ON" > SET SAFETY ON >ENDIF >IF THIS.xesc_stat = "ON" > SET ESCAPE ON >ELSE > SET ESCAPE OFF >ENDIF >IF THIS.setnull = "OFF" > SET NULL OFF >ELSE > SET NULL ON >ENDIF >IF THIS.xtalk_stat = "ON" > SET TALK ON >ENDIF >IF THIS.setcompat = "ON" > SET COMP ON >ENDIF >#IF "MAC" $ UPPER(VERSION(1)) > IF _MAC > m.cTmpStr = THIS.mmacdesk > SET MACDESKTOP &cTmpStr > ENDIF >#ENDIF > >cTmpStr = THIS.in_esc >ON ESCAPE &cTmpStr > >IF THIS.failxtab > THIS.outfname = '' > THIS.deactthermo() >ENDIF > >_vfp.LanguageOptions = THIS.iLanguageOptions > >ENDPROC > >*!********************************************************************* >*! >*! Function: MakeXTab() >*! >*!********************************************************************* >PROCEDURE MakeXTab > * Set ON ESCAPE here > LOCAL oThisXtab > oThisXtab = THIS.Name+".esc_proc()" > ON ESCAPE &oThisXtab > > * Call main program > THIS.RunXTab() >ENDPROC > >*!********************************************************************* >*! >*! Function: RunXTab() >*! >*!********************************************************************* >PROCEDURE RunXTab > >LOCAL dbfname,dbfstem,ok,cdec,i,tempdbf >LOCAL numflds,rowfldname,colfldname,cellfldname >LOCAL totfldname,gtotal,outf1name,f1,f2,f3 >LOCAL colcnt,coluniq,outarray,nTotFields,cSaveFld >LOCAL sumallflds,RowFldType,cTmpField >LOCAL nFldLen,cFldType,nFldDec,nAccumTot,nTmpTot >DIMENSION colcnt[1],coluniq[1],outarray[1] > >m.dbfname = ALIAS() >m.dbfstem = THIS.Juststem(m.dbfname) > >THIS.acttherm(C_THERM1_LOC) >THIS.updtherm(5,C_THERM2_LOC) > >* Select one, if no database is open in the current workarea >m.ok = .F. >DO WHILE NOT m.ok > DO CASE > CASE EMPTY(m.dbfname) > m.dbfname = GETFILE('DBF',C_LOCATEDBF_LOC) > m.dbfstem = THIS.juststem(m.dbfname) > IF EMPTY(m.dbfname) > * User canceled out of dialog, so quit the program > THIS.failxtab = .T. > RETURN > ENDIF > CASE FULLPATH(THIS.defaultext(m.dbfname,'DBF')) == ; > FULLPATH(THIS.defaultext(THIS.outfname,'DBF')) > THIS.ALERT(C_OUTPUT_LOC) > m.dbfname = '' > OTHERWISE > IF USED(m.dbfstem) > SELECT (m.dbfstem) > ELSE > SELECT 0 > USE (m.dbfname) ALIAS (m.dbfstem) > ENDIF > IF FCOUNT() < 3 > THIS.ALERT(C_NEED3FLDS_LOC) > m.dbfname = '' > ELSE > ok = .T. > ENDIF > ENDCASE >ENDDO > >IF RECCOUNT() = 0 > THIS.ALERT(C_EMPTYDBF_LOC) > THIS.failxtab = .T. > RETURN >ENDIF > >* Gather information on the currently selected database fields > >DIMENSION inpfields[FCOUNT(),4] >m.numflds = AFIELDS(inpfields) > >* Map the physical input database field to logical field positions > >m.rowfldname = inpfields[THIS.rowfld,1] >m.colfldname = inpfields[THIS.colfld,1] >m.cellfldname = inpfields[THIS.cellfld,1] > >* None of these fields are allowed to be memo fields >IF inpfields[THIS.rowfld,2] $ 'MGP' > THIS.ALERT(C_BADROWFLD_LOC) > THIS.failxtab = .T. > RETURN >ENDIF >IF inpfields[THIS.colfld,2] $ 'MGP' > THIS.ALERT(C_BADCOLFLD_LOC) > THIS.failxtab = .T. > RETURN >ENDIF >IF inpfields[THIS.cellfld,2] $ 'MGP' > THIS.ALERT(C_BADCELLFLD_LOC) > THIS.failxtab = .T. > RETURN >ENDIF > >* Count the number of columns we need to create the cross tab. >* This step could be combined with the following one so that there >* would only be one SELECT operation performed. It is coded in this >* way to avoid running out of memory if there are an unexpectedly >* large number of unique values of field 2 in the input database. > >THIS.updtherm(10,C_THERM3_LOC) >tempdbf = IIF(UPPER(JUSTEXT(DBF()))#"TMP",DBF(),m.dbfname) >SELECT COUNT(DISTINCT &colfldname) FROM (m.tempdbf) INTO ARRAY colcnt > >DO CASE >CASE colcnt[1] > 254 > THIS.ALERT(C_XSVALUES_LOC) > THIS.failxtab = .T. > RETURN >CASE colcnt[1] = 0 > THIS.ALERT(C_NOCOLS_LOC) > THIS.failxtab = .T. > RETURN >ENDCASE > >* Get the number of decimal places in numeric fields >* and extract all the unique values of colfldname >IF inpfields[THIS.colfld,2] $ 'NFB' && numeric or floating field > m.cdec = inpfields[THIS.colfld,4] > * Handle numbers separately to preserve correct sort order > SELECT DISTINCT &colfldname ; > FROM (m.tempdbf) INTO ARRAY coluniq > FOR i = 1 TO ALEN(coluniq) > coluniq[m.i] = THIS.mapname(coluniq[m.i],m.cdec) > ENDFOR >ELSE && non-numeric field > m.cdec = 0 > * Create an array to hold the output database fields. > SELECT DISTINCT EVAL("THIS.mapname(&colfldname,m.cdec)") FROM (m.tempdbf) INTO ARRAY coluniq >ENDIF > >THIS.updtherm(15,C_THERM3_LOC) > >* The field type, length and decimals in the output array control the >* cross-tab cells >IF !THIS.xfoot > DIMENSION outarray[ALEN(coluniq)+1,5] >ELSE > DIMENSION outarray[ALEN(coluniq)+2,5] >ENDIF > >* Field 1 in the output DBF holds the unique values of the row input field. >* It is handled separately from the other fields, which take their names >* from input database colfld and their parameters (e.g., length) from >* input database cellfld. > >outarray[1,1] = ALLTRIM(THIS.mapname(inpfields[THIS.rowfld,1])) >outarray[1,2] = inpfields[THIS.rowfld,2] && field type >outarray[1,3] = inpfields[THIS.rowfld,3] && field length >outarray[1,4] = inpfields[THIS.rowfld,4] && decimals >outarray[1,5] = .T. && allow NULLs > >m.RowFldType = outarray[1,2] > >* Get field data type, width, and deci >cFldType = inpfields[THIS.cellfld,2] >nFldLen = inpfields[THIS.cellfld,3] >nFldDec = inpfields[THIS.cellfld,4] > >* Set data types for data cells >FOR i = 2 TO ALEN(coluniq) + 1 > outarray[m.i,1] = ALLTRIM(THIS.mapname(coluniq[m.i-1],m.cdec)) && field name > outarray[m.i,2] = m.cFldType && field type > outarray[m.i,3] = m.nFldLen && field length > outarray[m.i,4] = m.nFldDec && decimals > outarray[m.i,5] = .T. && allow NULLs >ENDFOR > >outarray[1,1] = THIS.CheckField(@coluniq,outarray[1,1]) >cSaveFld = outarray[1,1] > >* Create a field for the cross-footing, if that option was selected >* By default, make sure we have a numeric field here > >* Check type of data field, and use count if not numeric. >IF ATC(inpfields[THIS.cellfld,2],"NFYBI") = 0 > THIS.totaltype = COUNT_FIELDS >ENDIF > >IF THIS.xfoot > nTotFields = ALEN(coluniq)+2 > DO CASE > CASE THIS.totaltype = COUNT_FIELDS > * Since Max columns is 256, assume N (4) > outarray[m.nTotFields,1] = THIS.CountTotalFld > outarray[m.nTotFields,2] = THIS.cCountFldType && field type > outarray[m.nTotFields,3] = THIS.nCountFldLen && field length > outarray[m.nTotFields,4] = THIS.nCountFldDec && field length > CASE THIS.totaltype = PERCENT_FIELDS > * Percent of total, use three decimals > outarray[m.nTotFields,1] = THIS.perctotalfld > outarray[m.nTotFields,2] = THIS.cPercentFldType && field type > outarray[m.nTotFields,3] = THIS.nPercentFldLen && field length > outarray[m.nTotFields,4] = THIS.nPercentFldDec && decimals > OTHERWISE > outarray[m.nTotFields,1] = THIS.sumtotalfld > outarray[m.nTotFields,2] = inpfields[THIS.cellfld,2] && field type > outarray[m.nTotFields,4] = inpfields[THIS.cellfld,4] && decimals > IF ATC(inpfields[THIS.cellfld,2],"YB")#0 > outarray[m.nTotFields,3] = inpfields[THIS.cellfld,3] && field length > ELSE > * Add a little extra space for calculations > outarray[m.nTotFields,3] = MIN(inpfields[THIS.cellfld,3]+2,20) && field length > ENDIF > ENDCASE > outarray[m.nTotFields,5] = .T. &&allow nulls > > * Check for unique name > IF ALLTRIM(UPPER(outarray[m.nTotFields,1]))==ALLTRIM(UPPER(outarray[1,1])) > DO CASE > CASE LEN(ALLTRIM(outarray[1,1]))<9 > outarray[m.nTotFields,1] = ALLTRIM(outarray[1,1])+"_1" > CASE RIGHT(outarray[1,1],2) = "_1" > outarray[m.nTotFields,1] = LEFT(outarray[1,1],8)+"_2" > OTHERWISE > outarray[m.nTotFields,1] = LEFT(outarray[1,1],8)+"_1" > ENDCASE > ENDIF > outarray[m.nTotFields,1] = THIS.CheckField(@coluniq,outarray[m.nTotFields,1]) >ENDIF > >* Make sure that the output file is not already in use somewhere >IF USED(THIS.outstem) > SELECT (THIS.outstem) > USE >ENDIF > >IF !THIS.cursonly > CREATE TABLE (THIS.outfname) FREE FROM ARRAY outarray > THIS.outstem = ALIAS() &&ensure we have correct long name >ELSE > CREATE CURSOR (THIS.outstem) FROM ARRAY outarray >ENDIF > >THIS.updtherm(25,C_THERM3_LOC) > >* Get rid of the temporary arrays >RELEASE outarray, coluniq, inpfields > >* ------------------------------------------------------------------------- >* Add output database rows and replace the first field >* ------------------------------------------------------------------------- > >* Select distinct rows into a table (instead of an array) so that >* there can be lots of rows. If we select into an array, we may >* run out of RAM if there are many rows. > >SELECT DISTINCT &rowfldname. AS &cSaveFld. FROM (m.tempdbf) INTO TABLE xtabtemp >THIS.updtherm(30,C_THERM4_LOC) > >SELECT (THIS.outstem) >GO TOP >APPEND FROM xtabtemp FIELD (FIELD(1)) > > >THIS.updtherm(35,C_THERM5_LOC) > >* ------------------------------------------------------------------------- >* Look up and replace the cell values >* ------------------------------------------------------------------------- >* >* This algorithm makes one pass through the input file, dropping its >* values into the output file. It exploits the fact that the output >* file is known to be in row order. >* > >* Start at the top of the output file >SELECT (THIS.outstem) >GOTO TOP >outf1name = FIELD(1) > >* Start at the top of the input file >SELECT (m.dbfstem) >GOTO TOP > >SCAN > > m.f1 = EVAL(m.rowfldname) && get next row value from input > m.f2 = THIS.mapname(EVAL(m.colfldname),m.cdec) && get corresponding column value > m.f3 = EVAL(m.cellfldname) && get cell value > > * Find the right row in the output file > SELECT (THIS.outstem) > > GO TOP > > DO WHILE !EOF() > DO CASE > CASE ISNULL(EVAL(outf1name)) AND ISNULL(m.f1) > EXIT > CASE EVAL(outf1name) == m.f1 > EXIT > ENDCASE > SKIP > ENDDO > > IF EOF() > THIS.ALERT(C_ENDOUTFILE_LOC) > THIS.failxtab = .T. > RETURN > ENDIF > > * SUM or replace for non numeric data types > IF TYPE(m.f2) $ "NFYBI" > IF ISNULL(&f2) > nAccumTot = IIF(ISNULL(m.f3),.NULL.,m.f3) > ELSE > nAccumTot = &f2 + IIF(ISNULL(m.f3),0,m.f3) > ENDIF > REPLACE (m.f2) WITH m.nAccumTot > ELSE > REPLACE (m.f2) WITH m.f3 > ENDIF > > SELECT (m.dbfstem) > > * Map thermometer to remaining portion of display > DO CASE > CASE RECCOUNT() > 1000 > IF RECNO() % 100 = 0 > THIS.updtherm(INT(RECNO()/RECCOUNT()*60)+35,C_THERM5_LOC) > ENDIF > OTHERWISE > IF RECNO() % 10 = 0 > THIS.updtherm(INT(RECNO()/RECCOUNT()*55)+35,C_THERM5_LOC) > ENDIF > ENDCASE >ENDSCAN > > >* Cross-foot the columns and put the results into the total field >IF THIS.xfoot > THIS.updtherm(90,C_THERM6_LOC) > SELECT (THIS.outstem) > m.totfldname = FIELD(FCOUNT()) > IF THIS.totaltype = PERCENT_FIELDS > * Need to get total here > PRIVATE aSums,nFirstField > m.nFirstField = IIF(ATC(m.RowFldType,"NFIYB")=0,1,2) > SUM ALL TO ARRAY aSums > m.sumallflds = 0 > FOR i = m.nFirstField TO (ALEN(aSums)-1) &&skip last field which has totals > m.sumallflds = m.sumallflds + aSums[m.i] > ENDFOR > ENDIF > SCAN > * Sum the relevant fields > m.gtotal = .NULL. > FOR i = 2 TO FCOUNT() - 1 > IF ISNULL(EVAL(FIELD(m.i))) > LOOP > ENDIF > IF ISNULL(m.gtotal) AND !ISNULL(EVAL(FIELD(m.i))) > gtotal = 0 > ENDIF > DO CASE > CASE THIS.totaltype = COUNT_FIELDS > * Count values > IF THIS.shownulls > gtotal = m.gtotal + IIF(ISNULL(EVAL(FIELD(m.i))),0,1) > ELSE > cTmpField = field(m.i) > gtotal = m.gtotal + IIF(ISBLANK(&cTmpField),0,1) > ENDIF > OTHERWISE > * SUM values > gtotal = m.gtotal + EVAL(FIELD(m.i)) > ENDCASE > ENDFOR > IF THIS.totaltype = PERCENT_FIELDS > gtotal = IIF(m.sumallflds=0 OR ISNULL(m.gtotal) OR m.gtotal=0,0,ROUND(m.gtotal/m.sumallflds*100,THIS.nPercentFldDec)) > ENDIF > REPLACE (m.totfldname) WITH m.gtotal > ENDSCAN >ENDIF > >THIS.updtherm(100) > >IF USED("XTABTEMP") > USE IN xtabtemp >ENDIF > >IF FILE("xtabtemp.dbf") > DELETE FILE xtabtemp.dbf >ENDIF > >* Close the input database >IF THIS.closeinput > SELECT (m.dbfstem) > USE >ENDIF > >* Leave the output database/cursor selected >SELECT (THIS.outstem) >GOTO TOP >THIS.deactthermo() > >* Do closing housekeeping >RETURN >ENDPROC > > >*!********************************************************************* >*! >*! Function: MAPNAME() >*! >*!********************************************************************* >FUNCTION mapname >* Translate a field value of any type into a string containing a valid >* field name. > >PARAMETER in_name, in_dec >LOCAL retval > >IF PARAMETERS() = 1 > m.in_dec = 0 >ENDIF >DO CASE >CASE ISNULL(m.in_name) > m.retval = THIS.null_field >CASE TYPE("m.in_name") $ 'CM' > DO CASE > CASE EMPTY(m.in_name) > m.retval = THIS.char_blank > OTHERWISE > * We need to replace bad characters here with "_" > m.retval = CHRTRANC(m.in_name,THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1)) > > IF !ISALPHA(LEFT(m.retval,1)) > m.retval = 'C_'+m.retval > ENDIF > > IF !this.cursonly && Leemi new code if a cursor, don't truncate > * Now have to truncate to 10 bytes (not 10 chars) > m.retval=SUBSTR(m.retval,1,10) && first 10 bytes > IF LEN(RIGHTC(m.retval,1)) = 1 AND IsLeadByte(RIGHTC(m.retval,1)) && last byte is Double byte > m.retval = SUBSTR(m.retval,1,9) > ENDIF > ENDIF > > ENDCASE >CASE TYPE("m.in_name") $ 'NFIYB' > m.retval = 'N_'+ALLTRIM(CHRTRANC(STR(m.in_name,8,MIN(in_dec,18)),'.','')) > m.retval = CHRTRANC(m.retval,'-,','__') >CASE TYPE("m.in_name") $ 'DT' > DO CASE > CASE EMPTY(m.in_name) > m.retval = THIS.date_blank > OTHERWISE > m.retval = 'D_' + CHRTRANC(DTOS(m.in_name),THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1)) > ENDCASE >CASE TYPE("m.in_name") = 'L' > IF m.in_name = .T. > m.retval = 'T' > ELSE > m.retval = 'F' > ENDIF >OTHERWISE > * Should never happen > THIS.alert(C_UNKNOWNFLD_LOC) > RETURN "" >ENDCASE > >IF !THIS.Cursonly > RETURN PADR(UPPER(ALLTRIM(m.retval)),10) >ELSE > RETURN PADR(UPPER(ALLTRIM(m.retval)),30) >ENDIF > >ENDFUNC > >*!********************************************************************* >*! >*! Procedure: CheckField >*! >*!********************************************************************* >PROCEDURE CheckField >PARAMETER aCheckArray,cCheckValue >* Checks to see if field name is unique, else assigns a new one >LOCAL oldExact,nTmpCnt,cTmpCntStr,cOldValue >oldexact = SET("EXACT") >SET EXACT ON >IF LEN(ALLTRIM(m.cCheckValue)) > 10 > cCheckValue = LEFT(ALLTRIM(m.cCheckValue),10) >ENDIF >cOldValue = m.cCheckValue >nTmpCnt = 1 >DO WHILE ASCAN(aCheckArray,m.cCheckValue)#0 > cTmpCntStr = "_"+ALLTRIM(STR(m.nTmpCnt)) > cCheckValue = LEFT(ALLTRIM(m.cOldValue),10-LEN(m.cTmpCntStr)) + m.cTmpCntStr > nTmpCnt = m.nTmpCnt + 1 >ENDDO >SET EXACT &oldexact >RETURN m.cCheckValue >ENDPROC > >*!********************************************************************* >*! >*! Procedure: ERROR >*! >*!********************************************************************* >PROCEDURE ERROR >PARAMETERS nError,cMethod,nLine >THIS.alert(ERR_LINE_LOC+ALLTRIM(STR(m.nLine))+CHR(13) ; > +ERR_PROGRAM_LOC+m.cMethod+CHR(13) ; > +ERR_ERROR_LOC+ALLTRIM(STR(nError))+CHR(13) ; > +ERR_MESSAGE_LOC+MESSAGE()+CHR(13); > +ERR_CODE_LOC+MESSAGE(1)) > > THIS.failxtab = .T. > RETURN TO MakeXtab >ENDPROC > >*!********************************************************************* >*! >*! Procedure: ALERT >*! >*!********************************************************************* >PROCEDURE alert >LPARAMETERS strg >=MESSAGEBOX(m.strg) >RETURN >ENDPROC > >*!********************************************************************* >*! >*! Procedure: ESC_PROC >*! >*!********************************************************************* >PROCEDURE esc_proc > CLEAR TYPEAHEAD > IF MESSAGEBOX(C_XTABTERM_LOC,36) = 6 > RETURN > ELSE > THIS.failxtab = .T. > RETURN TO MakeXtab > ENDIF >ENDPROC > >*!***************************************************************************** >*! >*! Procedure: PARTIALFNAME >*! >*!***************************************************************************** >FUNCTION partialfname >PARAMETER m.filname, m.fillen >* Return a filname no longer than m.fillen characters. Take some chars >* out of the middle if necessary. No matter what m.fillen is, this function >* always returns at least the file stem and extension. >PRIVATE m.bname, m.elipse >m.elipse = "..." + c_pathsep >m.bname = THIS.justfname(m.filname) >DO CASE >CASE LEN(m.filname) <= m.fillen > RETURN filname >CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen > RETURN m.bname >OTHERWISE > m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0) > RETURN LEFT(THIS.justpath(m.filname),remain)+m.elipse+m.bname >ENDCASE >ENDFUNC > >*!***************************************************************************** >*! >*! Procedure: removequotes >*! >*!***************************************************************************** >FUNCTION removequotes >PARAMETER m.fname >PRIVATE m.leftchar, m.rightchar >m.fname = ALLTRIM(m.fname) >m.leftchar = LEFT(m.fname,1) >m.rightchar = RIGHT(m.fname, 1) > >IF m.leftchar = '"' AND m.rightchar = '"' ; > OR m.leftchar = "'" AND m.rightchar = "'" ; > OR m.leftchar = '[' AND m.rightchar = ']' > RETURN SUBSTR(m.fname, 2, LEN(m.fname) - 2) >ELSE > RETURN m.fname >ENDIF >ENDFUNC > >*!********************************************************************* >*! >*! Function: JUSTSTEM() >*! >*!********************************************************************* >FUNCTION juststem >* Return just the stem name from "filname" >PARAMETERS filname >PRIVATE ALL >IF RAT('\',m.filname) > 0 > m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255) >ENDIF >IF RAT(':',m.filname) > 0 > m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255) >ENDIF >IF RAT('.',m.filname) > 0 > m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1) >ENDIF >RETURN ALLTRIM(UPPER(m.filname)) >ENDFUNC > >*!********************************************************************* >*! >*! Procedure: FORCEEXT >*! >*!********************************************************************* >FUNCTION forceext >* Force the extension of "filname" to be whatever ext is. >PARAMETERS filname,ext >PRIVATE ALL >IF SUBSTR(m.ext,1,1) = "." > m.ext = SUBSTR(m.ext,2,3) >ENDIF > >m.pname = THIS.justpath(m.filname) >m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname))) >IF RAT('.',m.filname) > 0 > m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1) + '.' + m.ext >ELSE > m.filname = m.filname + '.' + m.ext >ENDIF >RETURN THIS.addbs(m.pname) + m.filname >ENDFUNC > >*!********************************************************************* >*! >*! Function: DEFAULTEXT() >*! >*!********************************************************************* >FUNCTION defaultext >* Add a default extension to "filname" if it doesn't have one already >PARAMETERS filname,ext >PRIVATE ALL >IF SUBSTR(ext,1,1) = "." > m.ext = SUBSTR(m.ext,2,3) >ENDIF > >m.pname = THIS.justpath(m.filname) >m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname))) >IF !EMPTY(m.filname) AND AT('.',m.filname) = 0 > m.filname = m.filname + '.' + m.ext > RETURN THIS.addbs(m.pname) + m.filname >ELSE > RETURN filname >ENDIF >ENDFUNC > >*!********************************************************************* >*! >*! Function: JUSTFNAME() >*! >*!********************************************************************* >FUNCTION justfname >* Return just the filename (i.e., no path) from "filname" >PARAMETERS filname >PRIVATE ALL >IF RAT('\',m.filname) > 0 > m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255) >ENDIF >IF RAT(':',m.filname) > 0 > m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255) >ENDIF >RETURN ALLTRIM(UPPER(m.filname)) >ENDPROC > >*!********************************************************************* >*! >*! Procedure: JUSTPATH >*! >*!********************************************************************* >FUNCTION justpath >* Return just the path name from "filname" >PARAMETERS m.filname >PRIVATE ALL >m.filname = ALLTRIM(UPPER(m.filname)) >m.pathsep = IIF(_MAC,":", "\") >IF _MAC > m.found_it = .F. > m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname)) > IF m.maxchar > 0 > m.filname = SUBSTR(m.filname,1,m.maxchar) > IF RIGHT(m.filname,1) $ ":\" AND LEN(m.filname) > 1 ; > AND !(SUBSTR(m.filname,LEN(m.filname)-1,1) $ ":\") > m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1) > ENDIF > RETURN m.filname > ENDIF >ELSE > IF m.pathsep $ filname > m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname)) > IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ; > AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep > m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1) > ENDIF > RETURN m.filname > ENDIF >ENDIF >RETURN '' >ENDPROC > >*!********************************************************************* >*! >*! Procedure: ADDBS >*! >*!********************************************************************* >FUNCTION addbs >* Add a backslash to a path name, if there isn't already one there >PARAMETER pathname >PRIVATE ALL >m.pathname = ALLTRIM(UPPER(m.pathname)) >IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname) > m.pathname = m.pathname + IIF(_MAC,":",'\') >ENDIF >RETURN m.pathname >ENDPROC > > >*!********************************************************************* >*! >*! Procedure: HasModalForm >*! >*!********************************************************************* >PROCEDURE HasModalForm >* Tests to see if a modal form is active and uses status bar >* Note: This is commented out, however, if you prefer to use the status bar >* remove the following line >RETURN .F. >LOCAL i >FOR i = 1 TO _SCREEN.FormCount > IF _Screen.Forms[m.i].Windowtype = 1 OR ; > (TYPE("_Screen.Forms[m.i].Parent.Windowtype")="N" AND ; > _Screen.Forms[m.i].Parent.Windowtype = 1) > RETURN .T. > EXIT > ENDIF >ENDFOR >RETURN .F. >ENDPROC > >*!********************************************************************* >*! >*! Procedure: ActTherm >*! >*!********************************************************************* >PROCEDURE ActTherm >PARAMETER prompt >IF !THIS.therm_on > RETURN >ENDIF >IF VARTYPE(m.prompt)#"C" > prompt="" >ENDIF >* Test to see if we have a modal form up which prevents Therm window from being visible. >IF THIS.HasModalForm() > THIS.lHasModalFormOnTop = .T. > RETURN >ENDIF >THIS.oThermRef = CREATEOBJECT("thermometer",m.prompt) >THIS.oThermRef.Show() >ENDPROC > >*!********************************************************************* >*! >*! Procedure: updtherm >*! >*!********************************************************************* >PROCEDURE updtherm >LPARAMETER Percent,cTask >IF !THIS.therm_on > RETURN >ENDIF >IF THIS.lHasModalFormOnTop > SET MESSAGE TO C_THERM1_LOC+ALLTRIM(STR(m.percent))+"%" > RETURN >ENDIF >IF m.Percent = 100 > THIS.oThermRef.Complete() >ELSE > THIS.oThermRef.Update(m.Percent,cTask) >ENDIF >ENDPROC > >*!********************************************************************* >*! >*! Procedure: deactthermo >*! >*!********************************************************************* >PROCEDURE deactthermo > IF !THIS.therm_on > RETURN > ENDIF > IF THIS.lHasModalFormOnTop > RETURN > ENDIF > IF TYPE("THIS.oThermRef") = "O" > THIS.oThermRef.Release() > ENDIF >ENDPROC > >ENDDEFINE > > >*********************************************************************** >*********************************************************************** >DEFINE CLASS thermometer AS form > > Top = 196 > Left = 142 > Height = 88 > Width = 356 > AutoCenter = .T. > BackColor = RGB(192,192,192) > BorderStyle = 0 > Caption = "" > Closable = .F. > ControlBox = .F. > MaxButton = .F. > MinButton = .F. > Movable = .F. > AlwaysOnTop = .F. > ipercentage = 0 > ccurrenttask = '' > shpthermbarmaxwidth = 322 > cthermref = "" > Name = "thermometer" > > ADD OBJECT shape10 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 81, ; > Left = 3, ; > Top = 3, ; > Width = 1, ; > Name = "Shape10" > > > ADD OBJECT shape9 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 1, ; > Left = 3, ; > Top = 3, ; > Width = 349, ; > Name = "Shape9" > > > ADD OBJECT shape8 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 82, ; > Left = 352, ; > Top = 3, ; > Width = 1, ; > Name = "Shape8" > > > ADD OBJECT shape7 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 1, ; > Left = 3, ; > Top = 84, ; > Width = 350, ; > Name = "Shape7" > > > ADD OBJECT shape6 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 86, ; > Left = 354, ; > Top = 1, ; > Width = 1, ; > Name = "Shape6" > > > ADD OBJECT shape4 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 1, ; > Left = 1, ; > Top = 86, ; > Width = 354, ; > Name = "Shape4" > > > ADD OBJECT shape3 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 85, ; > Left = 1, ; > Top = 1, ; > Width = 1, ; > Name = "Shape3" > > > ADD OBJECT shape2 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 1, ; > Left = 1, ; > Top = 1, ; > Width = 353, ; > Name = "Shape2" > > > ADD OBJECT shape1 AS shape WITH ; > BackStyle = 0, ; > Height = 88, ; > Left = 0, ; > Top = 0, ; > Width = 356, ; > Name = "Shape1" > > > ADD OBJECT shape5 AS shape WITH ; > BorderStyle = 0, ; > FillColor = RGB(192,192,192), ; > FillStyle = 0, ; > Height = 15, ; > Left = 17, ; > Top = 47, ; > Width = 322, ; > Name = "Shape5" > > > ADD OBJECT lbltitle AS label WITH ; > FontName = WIN32FONT, ; > FontSize = 8, ; > BackStyle = 0, ; > BackColor = RGB(192,192,192), ; > Caption = "", ; > Height = 16, ; > Left = 18, ; > Top = 14, ; > Width = 319, ; > WordWrap = .F., ; > Name = "lblTitle" > > > ADD OBJECT lbltask AS label WITH ; > FontName = WIN32FONT, ; > FontSize = 8, ; > BackStyle = 0, ; > BackColor = RGB(192,192,192), ; > Caption = "", ; > Height = 16, ; > Left = 18, ; > Top = 27, ; > Width = 319, ; > WordWrap = .F., ; > Name = "lblTask" > > > ADD OBJECT shpthermbar AS shape WITH ; > BorderStyle = 0, ; > FillColor = RGB(128,128,128), ; > FillStyle = 0, ; > Height = 16, ; > Left = 17, ; > Top = 46, ; > Width = 0, ; > Name = "shpThermBar" > > > ADD OBJECT lblpercentage AS label WITH ; > FontName = WIN32FONT, ; > FontSize = 8, ; > BackStyle = 0, ; > Caption = "0%", ; > Height = 13, ; > Left = 170, ; > Top = 47, ; > Width = 16, ; > Name = "lblPercentage" > > > ADD OBJECT lblpercentage2 AS label WITH ; > FontName = WIN32FONT, ; > FontSize = 8, ; > BackColor = RGB(0,0,255), ; > BackStyle = 0, ; > Caption = "Label1", ; > ForeColor = RGB(255,255,255), ; > Height = 13, ; > Left = 170, ; > Top = 47, ; > Width = 0, ; > Name = "lblPercentage2" > > > ADD OBJECT shape11 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 1, ; > Left = 16, ; > Top = 45, ; > Width = 322, ; > Name = "Shape11" > > > ADD OBJECT shape12 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 1, ; > Left = 16, ; > Top = 61, ; > Width = 323, ; > Name = "Shape12" > > > ADD OBJECT shape13 AS shape WITH ; > BorderColor = RGB(128,128,128), ; > Height = 16, ; > Left = 16, ; > Top = 45, ; > Width = 1, ; > Name = "Shape13" > > > ADD OBJECT shape14 AS shape WITH ; > BorderColor = RGB(255,255,255), ; > Height = 17, ; > Left = 338, ; > Top = 45, ; > Width = 1, ; > Name = "Shape14" > > > ADD OBJECT lblescapemessage AS label WITH ; > FontBold = .F., ; > FontName = WIN32FONT, ; > FontSize = 8, ; > Alignment = 2, ; > BackStyle = 0, ; > BackColor = RGB(192,192,192), ; > Caption = "", ; > Height = 14, ; > Left = 17, ; > Top = 68, ; > Width = 322, ; > WordWrap = .F., ; > Name = "lblEscapeMessage" > > >*!********************************************************************* >*! >*! Procedure: complete >*! >*!********************************************************************* >PROCEDURE complete > * This is the default complete message > parameters m.cTask > private iSeconds > if parameters() = 0 > m.cTask = THERMCOMPLETE_LOC > endif > this.Update(100,m.cTask) >ENDPROC > > >*!********************************************************************* >*! >*! Procedure: update >*! >*!********************************************************************* >PROCEDURE update > * m.iProgress is the percentage complete > * m.cTask is displayed on the second line of the window > > parameters iProgress,cTask > > if parameters() >= 2 .and. type('m.cTask') = 'C' > * If we're specifically passed a null string, clear the current task, > * otherwise leave it alone > this.cCurrentTask = m.cTask > endif > > if ! this.lblTask.Caption == this.cCurrentTask > this.lblTask.Caption = this.cCurrentTask > endif > > m.iPercentage = m.iProgress > m.iPercentage = min(100,max(0,m.iPercentage)) > > if m.iPercentage = this.iPercentage > RETURN > endif > > if len(alltrim(str(m.iPercentage,3)))<>len(alltrim(str(this.iPercentage,3))) > iAvgCharWidth=fontmetric(6,this.lblPercentage.FontName, ; > this.lblPercentage.FontSize, ; > iif(this.lblPercentage.FontBold,'B','')+ ; > iif(this.lblPercentage.FontItalic,'I','')) > this.lblPercentage.Width=txtwidth(alltrim(str(m.iPercentage,3)) + '%', ; > this.lblPercentage.FontName,this.lblPercentage.FontSize, ; > iif(this.lblPercentage.FontBold,'B','')+ ; > iif(this.lblPercentage.FontItalic,'I','')) * iAvgCharWidth > this.lblPercentage.Left=int((this.shpThermBarMaxWidth- ; > this.lblPercentage.Width) / 2)+this.shpThermBar.Left-1 > this.lblPercentage2.Left=this.lblPercentage.Left > endif > this.shpThermBar.Width = int((this.shpThermBarMaxWidth)*m.iPercentage/100) > this.lblPercentage.Caption = alltrim(str(m.iPercentage,3)) + '%' > this.lblPercentage2.Caption = this.lblPercentage.Caption > if this.shpThermBar.Left + this.shpThermBar.Width -1 >= ; > this.lblPercentage2.Left > if this.shpThermBar.Left + this.shpThermBar.Width - 1 >= ; > this.lblPercentage2.Left + this.lblPercentage.Width - 1 > this.lblPercentage2.Width = this.lblPercentage.Width > else > this.lblPercentage2.Width = ; > this.shpThermBar.Left + this.shpThermBar.Width - ; > this.lblPercentage2.Left - 1 > endif > else > this.lblPercentage2.Width = 0 > endif > this.iPercentage = m.iPercentage >ENDPROC > >*!********************************************************************* >*! >*! Procedure: Init >*! >*!********************************************************************* >PROCEDURE Init > * m.cTitle is displayed on the first line of the window > * m.iInterval is the frequency used for updating the thermometer > parameters cTitle, iInterval > this.lblTitle.Caption = iif(empty(m.cTitle),'',m.cTitle) > this.shpThermBar.FillColor = rgb(128,128,128) > local cColor > > * Check to see if the fontmetrics for MS Sans Serif matches > * those on the system developed. If not, switch to Arial. > * The RETURN value indicates whether the font was changed. > if fontmetric(1, WIN32FONT, 8, '') <> 13 .or. ; > fontmetric(4, WIN32FONT, 8, '') <> 2 .or. ; > fontmetric(6, WIN32FONT, 8, '') <> 5 .or. ; > fontmetric(7, WIN32FONT, 8, '') <> 11 > this.SetAll('FontName', WIN95FONT) > endif > > m.cColor = rgbscheme(1, 2) > m.cColor = 'rgb(' + substr(m.cColor, at(',', m.cColor, 3) + 1) > this.BackColor = &cColor > this.Shape5.FillColor = &cColor >ENDPROC > >ENDDEFINE > >>>Can you give me an URL or something to find it?