Mini Kabibi Habibi
*:*********************************************************************
*:
*: 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