VFP 愛用者社區

[Ruey]

*************************************************
* gsXtab1.prg
* Parameters:
*
* pcOutFile - output file/cursor name (default "xtab.dbf")
* plOutCursor - Is outfile cursor or table? (default .t. = cursor)
* plCloseInput - close input table after (default .T. = close)
* plThermometer - show thermometer (default .T. = Show)
*
* pnRowFld - row field name - Default is Field number 1
* pnColFld - column field name - Default is Field Number 2
* pnCellFld - Column data field - Default is Field Number 3
*
* plTotal - total rows and create a total column (default .F. = No)
* pnSum - Is plTotal of totaling options (0-sum, 1-count)
* More options can be added such as % etc.)
* If the pcCellField is not number based,
* plTotal and pnSum wiill get disabled.
*
* plNull - display Null values
*
* The above are the VFPxtab.PRGs default parameters.
*
* Extra provisions built in this routine......
*
* pcGroup - Example "1,2,3" etc can be provided to group.
* pcOrder - Example "1,2,3" etc can be provided to sort output
* pcGroup and pcOrder will be prefixed to pcRowFld and
* pcColFld to get proper totals, if necessary.
* plAvg - Create an Average Column in the result - Default = .f.
* plMin - Create a Minimum Column in the result - Default = .f.
* plMax - Create a Maximum Column in the result - Default = .f.
*************************************************
** gsXtab1
*************************************************
PARAMETERS pcOutFile, plOutCursor, plCloseInput, plThermometer, ;
pnRowFld, pnColFld, pnCellFld, plTotal, pnSum, plNull, ;
pcGroup, pcOrder, plAvg, plMin, plMax

** SET ENGINEBEHAVIOR 70
*************************************************
** Create variables for this routine.
LOCAL n, ni, lcAlias, la_CrossTab, lcSQL, llTotal, ;
pcRowFld, pcColFld, pcCellFld, lcField, lcVer, lcEngine

n = 0 && simple counters and variables
n1 = 0 && simple counters and variables
lcAlias = ALIAS() && input alias
DIMENSION la_CrossTab(1,4) && used for cross tab columns
lcSql = '' && SQL Syntax to get output file
llTotal = .t. && To Decide pcCellFld type is numeric.
*************************************************
** Validity and Parameters Verification
n = PARAMETERS() && Number of parameters passed.

IF EMPTY(lcAlias) && A table must be open in the selected area
=MESSAGEBOX("No table selected.",0+16,"Error")
RETURN
ENDIF

IF n < 1 OR VARTYPE(pcOutFile) # "C"
pcOutFile = "GSXTAB"
ELSE
IF EMPTY(pcOutFile)
pcOutFile = "GSXTAB"
ENDIF
ENDIF

IF USED(pcOutFile)
USE IN (pcOutFile)
ENDIF

IF n < 2 OR VARTYPE(plOutCursor) # "L"
plOutCursor = .t.
ENDIF

IF n < 3 OR VARTYPE(plCloseInput) # "L"
plCloseInput = .t.
ENDIF

IF n < 4 OR VARTYPE(plThermometer) # "L"
plThermometer = .t.
ENDIF

** Checking for validity of counts or field names not yet done
IF n < 5 OR VARTYPE(pnRowFld) # "N"
pnRowFld = 1
pcRowFld = FIELD(1)
ELSE
pcRowFld = FIELD(pnRowFld)
ENDIF

** Checking for validity of counts or field names not yet done
IF n < 6 OR VARTYPE(pnColFld) # "N"
pnColFld = 2
pcColFld = FIELD(2)
ELSE
pcColFld = FIELD(pnColFld)
ENDIF

** Checking for validity of counts or field names not yet done
IF n < 7 OR VARTYPE(pnCellFld) # "N"
pnCellFld = 3
pcCellFld = FIELD(3)
ELSE
pcCellFld = FIELD(pnCellFld)
ENDIF

IF n < 8 OR VARTYPE(plTotal) # "L"
plTotal = .f.
ENDIF

IF n < 9 OR VARTYPE(pnSum) # "N"
pnSum = 0
ENDIF

** n=10 Null values Left to default settings.
** Not considered but kept for compatibility

** n=11 or n=12 field checkings not done.

IF n < 11 OR VARTYPE(pcGroup) # "C"
pcGroup = ''
ENDIF
IF EMPTY(pcGroup)
** pcGroup = "A." + pcRowFld
pcGroup = "1"
ENDIF

IF n < 12 OR VARTYPE(pcOrder) # "C"
pcOrder = ''
ENDIF
IF EMPTY(pcOrder)
** pcOrder = "A." + pcRowFld
pcOrder = "1"
ENDIF

IF n < 13 OR VARTYPE(plAvg) # "L"
plAvg = .f.
ENDIF

IF n < 14 OR VARTYPE(plMin) # "L"
plMin = .f.
ENDIF

IF n < 15 OR VARTYPE(plMax) # "L"
plMax = .f.
ENDIF

** If Col Cell is not numeric.. suitably disable maths functions
IF ! VARTYPE(&pcCellFld) $ "BFINY"
STORE .f. TO plTotal, plAvg, plMin, plMax, llTotal
ENDIF
*************************************************
** Create a CrossTab cursor to get the crosstab fields
** Once the crossTab fields are known, output can be generated
**
** Select all distinct pColFlds to identify crosstabs
** The first column will be left for identification of field
** The last column will be modified as the name for xtab column headers
SELECT DISTINCT &pcColFld, " " ;
FROM (lcALias) ORDER BY 1 INTO ARRAY la_CrossTab
*************************************************
** Check if total number of fields do not exceed 255
IF ALEN(la_CrossTab,1) > 255
=MESSAGEBOX("Number of columns exceed 255. Cannot process.",0+16,"Error")
RETURN
ENDIF
*************************************************
** Check for bad characters and prepare for field names
lcField = ''
n = 1
FOR I=1 TO ALEN(la_crossTab,1)
la_CrossTab(i,2)=goodchars(la_CrossTab(i,1))
** Also checking to avoid duplication of such new names
IF la_CrossTab(i,2) == lcField
n = n+1
lcField = LEFT(la_CrossTab(i,2), (9-LEN(ALLTRIM(STR(n))))) ;
+ "_"+ ALLTRIM(STR(n))
la_CrossTab(i,2) = lcField
ELSE
n = 1
lcField = la_CrossTab(i,2)
ENDIF
ENDFOR

** Create the crossTab cursor to create our output file
** and populate the crossTab table with 1's
n1 = LEN(&pcColFld) && Length of Column Field
CREATE CURSOR gsXtemp (&pcColFld C(n1+1))

FOR n= 1 TO ALEN(la_crossTab,1)
ALTER TABLE gsXtemp ADD COLUMN &la_crossTab(n,2) I
INSERT INTO gsXtemp (&pcColFld,(FIELD(n+1))) ;
VALUES (la_crossTab(n,1),1)
ENDFOR
*************************************************
** Prepare the SQL macro to extract output table

n1 = FCOUNT("gsXtemp") && fields count of Cross Tab including the 1st
SELECT (lcAlias)
lcSql = 'SELECT A.*'

FOR n = 2 TO n1 && since 1st field of gsXtemp table is not wanted
IF llTotal
lcSql = lcSql + ", SUM(A. " + pcCellfld + "*B." + ;
FIELD(n,"gsXtemp") + ") AS '" + FIELD(n,"gsXtemp") + "' "
ELSE
SCATTER FIELDS (pcCellFld) MEMVAR BLANK
lcSql = lcSql + ", IIF(B." + FIELD(n,"gsXtemp") + "=1,A." + ;
pcCellfld + ",M." + pcCellfld + ") AS '" ;
+ FIELD(n,"gsXtemp") + "' "
ENDIF
ENDFOR

IF plTotal AND llTotal && Totals of Row Field required
DO CASE
CASE pnSum = 0 && Total type is SUM
lcSql = lcSql + ", SUM( " + pcCellfld + " ) AS 'XTOT' "
CASE pnSum = 1 && Total type is Count
lcSql = lcSql + ", COUNT( " + pcRowFld + " ) AS 'XCNT' "
** CASE pnSum = 2 && not implemented yet
ENDCASE
ENDIF

IF plAvg AND llTotal
lcSql = lcSql + ", AVG( " + pcCellfld + " ) AS 'XAVG' "
ENDIF

IF plMin AND llTotal
lcSql = lcSql + ", MIN( " + pcCellfld + " ) AS 'XMIN' "
ENDIF

IF plMax AND llTotal
lcSql = lcSql + ", MAX( " + pcCellfld + " ) AS 'XMAX' "
ENDIF

** From tables
** lcSql = lcSql + "FROM " + DBF(lcAlias) + "A, gsXtemp B"
lcSql = lcSql + "FROM " + lcAlias + " A, gsXtemp B"

** Where condition
lcSql = lcSql + " WHERE B." + pcColFld + "=" + "A." + pcColFld

** Group by
lcSql = lcSql + " GROUP BY " + pcGroup

** Order by
lcSql = lcSql + " ORDER BY " + pcOrder

** INTO output
IF plOutCursor && Cursor
lcSql = lcSql + " INTO CURSOR " + pcOutFile + " READWRITE"
ELSE && TABLE
lcSql = lcSql + " INTO DBF " + pcOutFile
ENDIF

** My own quick find of what the SQL looks like
* STRTOFILE(lcSql,"gsx.Prg")
* = MESSAGEBOX(lcSql)
*************************************************
** Get the XTAB table
lcVer = LEFT(VERSION(4),2)
lcEngine = ''
IF lcVer > "07"
lcEngine = SET("ENGINEBEHAVIOR")
SET ENGINEBEHAVIOR 70
ENDIF
&lcSql
** Drop the Col field and the cell field columns
ALTER TABLE (pcOutFile) DROP (pcColFld)
ALTER TABLE (pcOutFile) DROP (pcCellFld)
*************************************************
** Close the input database, if required
IF plCloseinput
USE IN (lcAlias)
ENDIF
*************************************************
IF lcVer > "07"
SET ENGINEBEHAVIOR &lcEngine
ENDIF

RETURN
*************************************************
** EOP
*************************************************
** Check for acceptable characters in Field names
** and return first 10 characters for the purpose
**
PROCEDURE goodChars
LPARAMETERS cChars
LOCAL cGoodChars, nCount, x
cGoodChars = ""
nCount = 0
FOR x=1 TO LEN(cChars)
IF UPPER(SUBSTR(cChars,x,1)) $ "0123456789_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
cGoodChars = cGoodChars + UPPER(SUBSTR(cChars,x,1))
nCount = nCount+1
ENDIF
IF nCount = 10
EXIT
ENDIF
ENDFOR
IF !ISALPHA(SUBSTR(cGoodChars,1))
cGoodChars = "_"+cGoodChars
ENDIF
IF LEN(cGoodChars) > 10
cGoodChars = LEFT(cGoodChars,10)
ENDIF

RETURN cGoodChars
**************************************************
** EOF
**************************************************