The file is available as vfpxtab.prg here are the contents

*:*********************************************************************
*:
*: 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?
>10x!
>
>>Try xtab program.
>>
>>Aashish
>>
>>>Hi y'all.
>>>I need to obtain a cursor with one column for each row corresponding to a code in a master tabla, let me explain further..
>>>There is a parent table and a child table, both have a field called "cedula" which i use to join them, the chilt table has another fiel called "curso" which contains the code of an item, what i need is to obtain a cursor with the following structure:
>>>
>>>cedula,curso1,curso2,curso3,curso4......cursoN
>>>
>>>I made a program that works with macro substitution and creating N cursors which i join at the end, but i think there must be a better way..
>>>
>>>Is that possible?? how??
>>>
>>>Thanks in advance.
>>>
>>>jonamart@cantv.net