440 lines
11 KiB
Plaintext
440 lines
11 KiB
Plaintext
*~ Program...........: MATXTAB.PRG
|
|
*~ Author............: Valdis Matison
|
|
*~ Version...........: 2.5
|
|
*~} Project...........:
|
|
*~ Created...........: 11/01/93
|
|
*~ Copyright.........: (c) Matison Consulting Group Inc., 1993
|
|
*~ 187 Dunblaine Avenue
|
|
*~ Toronto, Ontario
|
|
*~ M5M 2S6
|
|
*~
|
|
*~ 416-256-4495
|
|
*~
|
|
*~) Description.......: Replacement for GENXTAB.prg that ships with FoxPro
|
|
*~] Dependencies......:
|
|
*~ Calling Samples...: do MATXTAB with "XTAB", 1, .t., .f., 1, 4, 5, .t., 2, 3, 0, 0, .t., .t., .t., .t.
|
|
*~ do MATXTAB with "XTAB", 1, .t., .f., 1, 2, 6, .t., 3, 4, 5, 0, .t., .t., .t., .t., la_fldlist, 2, 0, 1
|
|
*~ Returns...........: If you initialize a variable named LN_RETURN in the calling program
|
|
*~ this program will return a value in that variable
|
|
*~ This functionality is incomplete
|
|
*~
|
|
*~ 0 = Success!
|
|
*~ - 1 = Unique column count greater than 256
|
|
*~ - 2 = Escape pressed, procedure cancelled
|
|
*~ - 3 = No dbf in current area
|
|
*~ - 4 = Less than three fields in input dbf
|
|
*~ - 5 = Too many fields in results table
|
|
*~ - 6 = Row field must be character
|
|
*~ - 7 = Column field must be character
|
|
*~ > 0 returns Foxpro's error code generated by error()
|
|
*~
|
|
*~ Major change list.:
|
|
*~ Future............: Create a front end, DOS/Windows/MAC
|
|
*~ Notes:............: The error handling is incomplete, the user should decide what errors to trap.
|
|
*~ Naming convention: First letter "l" denotes local variable
|
|
*~ Second letter denotes type
|
|
*~
|
|
*~ Parameter List....: lc_outfile : Name of the output file
|
|
*~ lu_struct : 1 means cursor, 2 means table, 3 means array,
|
|
*~ .t. means cursor, .f. means table
|
|
*~ if blank, same format as input
|
|
*~ ll_closein : .t. means close input file, else keep open
|
|
*~ ll_therm : Included for compatibility with GENXTAB, not used by MATXTAB
|
|
*~ ln_rowfld : Number of field used for rows - field number
|
|
*~ ln_cellfld : Column used for individual totals in results table field number
|
|
*~ ln_colhead : Field used for column headings in XTAB report field number
|
|
*~ ll_xtotal :.t. means create cross totals, else don't bother
|
|
*~
|
|
*~ Differences from Genxtab begin here
|
|
*~
|
|
*~ ln_extfld1 : First extra field to go into output
|
|
*~ ln_extfld2 : Second extra field to go into output
|
|
*~ ln_extfld3 : Third extra field to go into output
|
|
*~ ln_extfld4 : Fourth extra field to go into output
|
|
*~ ll_cnt : Display count for each unique row
|
|
*~ ll_avg : Display average
|
|
*~ ll_min : Display minimum
|
|
*~ ll_max : Display maximum
|
|
*~ la_uniqcol : name of array passed that has the uniqe column names already in list
|
|
*~ ln_rowcol : Number of dimensions in the array that's sent down
|
|
*~ ln_colsort : 0 means smallest to largest
|
|
*~ 1 means largest to smallest
|
|
*~ ln_rowsort : 0 means ascending
|
|
*~ 1 means descending
|
|
*~
|
|
|
|
Parameters lc_outfile, lu_struct, ll_closein, ll_therm, ln_rowfld, ;
|
|
ln_colhead, ln_cellfld, ll_xtotal, ln_extfld1, ln_extfld2, ;
|
|
ln_extfld3, ln_extfld4, ll_cnt, ll_avg, ll_min, ll_max, ;
|
|
la_uniqcol, ln_rowcol, ln_colsort, ln_rowsort
|
|
|
|
External Array la_uniqcol
|
|
|
|
Private lc_colsort, lc_dbfname, lc_colhead, lc_cellfld, ;
|
|
ln_dimens, lc_error, lc_escasta, lc_escape, lc_group, ;
|
|
ln_params, lc_program, lc_rowfld, lc_rowsort, lc_safesta, ;
|
|
lc_talksta, lc_type, lc_where, ln_uniqcnt
|
|
|
|
lc_dbfname = Alias() && Source file taken from alias name
|
|
lc_error = On( "ERROR" )
|
|
lc_escasta = Set( "ESCAPE" )
|
|
lc_escape = On( "ESCAPE" )
|
|
ln_params = Pcount()
|
|
lc_safesta = Set( "SAFETY" )
|
|
lc_talksta = Set( "TALK" )
|
|
|
|
lcOutputDir = ADDBS(SYS(2023))
|
|
|
|
*On Error Do lo_exit With Error()
|
|
Set Escape On
|
|
On Escape Do lo_exit With -2
|
|
Set Safety Off
|
|
Set Talk Off
|
|
|
|
If Empty( Alias() ) && A file must be open in the selected area
|
|
Do lo_exit With -3
|
|
Endif
|
|
|
|
If Fcount() < 3 && At least three fields required
|
|
Do lo_exit With -4
|
|
Endif
|
|
|
|
If ln_params < 1 && Nothing sent down - Determine filename for output
|
|
lc_outfile = 'XTABX.DBF'
|
|
Endif
|
|
|
|
If ln_params < 2 && No format given for output
|
|
|
|
If Isdigit( Left( Justfname( Dbf() ) ,1 ) )
|
|
lu_struct = 1 && Cursor
|
|
Else
|
|
lu_struct = 2 && Table
|
|
Endif
|
|
|
|
Else
|
|
|
|
If Type("lu_struct") = "L" && Logical value
|
|
If lu_struct && True means create a cursor
|
|
lu_struct = 1
|
|
Else && False means table
|
|
lu_struct = 2
|
|
Endif &&
|
|
Endif && Logical or numeric value
|
|
|
|
Endif && No format given for output
|
|
|
|
|
|
If ln_params < 3 && Close input defaults to yes
|
|
ll_closein = .T.
|
|
Endif
|
|
|
|
If ln_params < 5 && Number of field for cross tab rows
|
|
ln_rowfld = 1
|
|
Endif
|
|
|
|
If Type( Field( ln_rowfld ) ) <> "C"
|
|
On Escape Do lo_exit With -6
|
|
Endif
|
|
|
|
|
|
If ln_params < 6 && Number of field for columns
|
|
ln_colhead = 2
|
|
Endif
|
|
|
|
If Type( Field( ln_colhead ) ) <> "C"
|
|
On Escape Do lo_exit With -7
|
|
Endif
|
|
|
|
If ln_params < 7 && Number of field for cross tab cells
|
|
ln_cellfld = 3
|
|
Endif
|
|
|
|
If ln_params < 8
|
|
ll_xtotal = .F.
|
|
Endif
|
|
|
|
If ln_params < 17
|
|
Private la_uniqcol
|
|
Dime la_uniqcol(1)
|
|
Endif
|
|
|
|
If ln_params > 17
|
|
ln_dimens = ln_rowcol
|
|
Else
|
|
ln_dimens = 1
|
|
Endif
|
|
|
|
If ln_params > 18
|
|
Do Case
|
|
Case ln_colsort = 1
|
|
lc_colsort = "DESC"
|
|
|
|
Otherwise
|
|
lc_colsort = "ASC"
|
|
Endcase
|
|
|
|
Else
|
|
lc_colsort = "ASC"
|
|
Endif
|
|
|
|
If ln_params = 20
|
|
Do Case
|
|
Case ln_rowsort = 1
|
|
lc_rowsort = "DESC"
|
|
|
|
Otherwise
|
|
lc_rowsort = "ASC"
|
|
Endcase
|
|
|
|
Else
|
|
lc_rowsort = "ASC"
|
|
Endif
|
|
|
|
lc_colhead = Field( ln_colhead )
|
|
lc_cellfld = lc_dbfname + "." + Field( ln_cellfld )
|
|
lc_group = lc_dbfname + "." + Field( ln_rowfld )
|
|
lc_program = Program( 1 )
|
|
ln_return = 0
|
|
lc_rowfld = lc_group
|
|
lc_where = "ZZ" + "." + ;
|
|
lc_colhead + "=" + ;
|
|
lc_dbfname + "." + ;
|
|
lc_colhead
|
|
|
|
|
|
*do matshow
|
|
|
|
If ln_params < 17
|
|
|
|
lc_type = Type( (lc_colhead) )
|
|
Do Case
|
|
Case lc_type = "C"
|
|
|
|
Select &lc_colhead ;
|
|
from ( lc_dbfname ) ;
|
|
order By 1 &lc_colsort ;
|
|
group By 1 ;
|
|
into Array la_uniqcol
|
|
|
|
Case lc_type = "D"
|
|
|
|
Select "D"+Dtoc( &lc_colhead, 1 ) ;
|
|
from (lc_dbfname) ;
|
|
order By 1 &lc_colsort ;
|
|
group By 1 ;
|
|
into Array la_uniqcol
|
|
|
|
lc_where = "ZZ" + "." + ;
|
|
lc_colhead + "=" + ;
|
|
"'D' +dtoc(" + ;
|
|
lc_dbfname + "." + ;
|
|
"&lc_colhead, 1 )"
|
|
|
|
Endcase
|
|
|
|
ln_uniqcnt = Alen( la_uniqcol )
|
|
* If empty cursor
|
|
IF RECCOUNT(lc_dbfname) = 0
|
|
ln_uniqcnt = 0
|
|
ENDIF
|
|
|
|
Else
|
|
|
|
ln_uniqcnt = Alen( la_uniqcol, ln_dimens )
|
|
|
|
Endif
|
|
|
|
If ln_uniqcnt >256
|
|
Do lo_exit With -1
|
|
Endif
|
|
|
|
Dime la_colname[ ln_uniqcnt + 1, 4 ]
|
|
la_colname[1,1] = lc_colhead
|
|
la_colname[1,2] = "C"
|
|
|
|
If ln_params < 17 && no array sent down
|
|
la_colname[ 1,3 ] = Len( &lc_colhead )
|
|
Else
|
|
la_colname[ 1,3 ] = Len( la_uniqcol[ 1,1 ] ) && What about width ?
|
|
Endif
|
|
|
|
la_colname[1,4] = 0
|
|
|
|
|
|
For ln_k = 2 To ln_uniqcnt + 1
|
|
la_colname[ ln_k, 1 ] = la_uniqcol[ 1, ln_k-1 ]
|
|
la_colname[ ln_k, 2 ] = "N"
|
|
la_colname[ ln_k, 3 ] = 1
|
|
la_colname[ ln_k, 4 ] = 0
|
|
Endfor
|
|
|
|
Create Cursor ZZ From Array la_colname
|
|
|
|
*--Now populate the table with 1's
|
|
For ln_k = 2 To ln_uniqcnt + 1
|
|
Insert Into ZZ ( (lc_colhead), (Field(ln_k)) ) ;
|
|
VALUES (la_colname[ ln_k, 1 ], 1 )
|
|
Endfor
|
|
|
|
*--
|
|
*-- Now create the cross tab
|
|
*--
|
|
|
|
lc_sqlxtab = "SELECT " + lc_rowfld
|
|
|
|
|
|
If ln_params > 8
|
|
If ln_extfld1 > 0
|
|
lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld1, lc_dbfname )
|
|
lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld1, lc_dbfname )
|
|
Endif
|
|
Endif
|
|
|
|
If ln_params > 9
|
|
If ln_extfld2 > 0
|
|
lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld2, lc_dbfname )
|
|
lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld2, lc_dbfname )
|
|
Endif
|
|
Endif
|
|
|
|
If ln_params > 10
|
|
If ln_extfld3 > 0
|
|
lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld3, lc_dbfname )
|
|
lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld3, lc_dbfname )
|
|
Endif
|
|
Endif
|
|
|
|
If ln_params > 11
|
|
If ln_extfld4 > 0
|
|
lc_sqlxtab = lc_sqlxtab + ", " + lc_dbfname + "." + field( ln_extfld4, lc_dbfname )
|
|
lc_group = lc_group + ", " + lc_dbfname + "." + field( ln_extfld4, lc_dbfname )
|
|
Endif
|
|
Endif
|
|
|
|
For ln_k = 1 To ln_uniqcnt
|
|
lc_sqlxtab = lc_sqlxtab + ", " + ;
|
|
"SUM( " + lc_cellfld + ;
|
|
"*ZZ." + ;
|
|
la_uniqcol[ 1, ln_k ] + ") as " + ;
|
|
la_uniqcol[ ln_dimens, ln_k ]
|
|
Endfor
|
|
|
|
*--
|
|
*-- Add totals column if required.
|
|
*-- Add count, average, min, max functions as well
|
|
*--
|
|
|
|
If ll_cnt
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
", COUNT( " + lc_rowfld + " ) as 'XCNT' "
|
|
Endif
|
|
|
|
If ll_avg
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
", AVG( " + lc_cellfld + " ) as 'XAVG' "
|
|
Endif
|
|
|
|
If ll_min
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
", MIN( " + lc_cellfld + " ) as 'XMIN' "
|
|
Endif
|
|
|
|
If ll_max
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
", MAX( " + lc_cellfld + " ) as 'XMAX' "
|
|
Endif
|
|
|
|
If ll_xtotal
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
", SUM( " + lc_cellfld + " ) as 'XTOT' "
|
|
Endif
|
|
|
|
lc_sqlxtab = lc_sqlxtab + ;
|
|
" FROM (lc_dbfname), ZZ " + ;
|
|
" WHERE &lc_where " + ;
|
|
" GROUP BY &lc_group " + ;
|
|
" Order by &lc_group &lc_rowsort " + ;
|
|
" INTO "
|
|
|
|
Do Case
|
|
Case lu_struct = 2 && output to table
|
|
lc_sqlxtab = m.lc_sqlxtab + "TABLE " + m.lcOutputDir + lc_outfile
|
|
|
|
Case lu_struct = 3 && output to array
|
|
lc_sqlxtab = lc_sqlxtab + "ARRAY _XTABX "
|
|
|
|
Public _xtabx
|
|
Dime _xtabx[ 1,1 ]
|
|
|
|
Otherwise && output to cursor DEFAULT
|
|
lc_sqlxtab = lc_sqlxtab + "CURSOR " + lc_outfile
|
|
Endcase
|
|
|
|
*-- Run the query
|
|
|
|
&lc_sqlxtab
|
|
|
|
Do lo_exit With ln_return
|
|
*-- eop MATXTAB
|
|
|
|
|
|
*~!*********************************************
|
|
*~!
|
|
*~! Procedure: lo_exit
|
|
*~!
|
|
*~!*********************************************
|
|
Procedure lo_exit
|
|
*~ Author............: Valdis Matison
|
|
*~ Modified by.......:
|
|
*~} Project...........:
|
|
*~ Created...........: 11/01/93
|
|
*~ Copyright.........: (c) Matison Consulting Group Inc., 1993
|
|
*~) Description.......: Shutdown procedure for MATXTAB
|
|
*~)
|
|
*~] Dependencies......:
|
|
*~ Calling Samples...:
|
|
*~ Parameter List....: ln_ret : Error code
|
|
*~ Returns...........:
|
|
*~ Future ideas......:
|
|
*~ Major change list.:
|
|
|
|
Parameters ln_ret
|
|
ln_return = ln_ret
|
|
|
|
If lc_talksta = "ON"
|
|
Set Talk On
|
|
Endif
|
|
|
|
If lc_safesta = "ON"
|
|
Set Safety On
|
|
Endif
|
|
|
|
If lc_escasta = "OFF"
|
|
Set Escape Off
|
|
Endif
|
|
|
|
*release windows lw_mat
|
|
Clear Typeahead
|
|
|
|
*-- Close input files only if successful
|
|
If ln_ret = 0
|
|
USE IN (SELECT('ZZ'))
|
|
|
|
If ll_closein && close the input file
|
|
USE IN (Select(lc_dbfname))
|
|
Endif
|
|
IF USED(JUSTSTEM(lc_outfile))
|
|
Select (lc_outfile)
|
|
ENDIF
|
|
Endif
|
|
|
|
* On Error &lc_error
|
|
On Escape &lc_escape
|
|
|
|
Return ln_ret
|
|
|
|
*--
|
|
*-- eop lo_exit
|
|
ENDPROC && lo_exit
|
|
|