Import initial din SVN ROAAUTO/Trunk @HEAD
This commit is contained in:
439
COMUN/programe/matxtab.prg
Normal file
439
COMUN/programe/matxtab.prg
Normal file
@@ -0,0 +1,439 @@
|
||||
*~ 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
|
||||
|
||||
Reference in New Issue
Block a user