From ceb4cd9a199958f4d0ba544aa9a9e7eac0b7db40 Mon Sep 17 00:00:00 2001 From: Luiz Rafael Culik Date: Sun, 13 Feb 2000 17:55:07 +0000 Subject: [PATCH] See changelog 20000213 15:50 --- harbour/ChangeLog | 18 + harbour/doc/funclist.txt | 4 +- harbour/include/rptdef.ch | 172 +++++ harbour/makefile.bc | 16 +- harbour/source/rtl/tlabel.prg | 456 ++++++++++++ harbour/source/rtl/treport.prg | 1284 ++++++++++++++++++++++++++++++++ harbour/tests/ee.frm | Bin 0 -> 1990 bytes harbour/tests/ee.lbl | Bin 0 -> 1034 bytes harbour/tests/testlbl.prg | 10 + harbour/tests/testrpt.prg | 9 + 10 files changed, 1966 insertions(+), 3 deletions(-) create mode 100644 harbour/include/rptdef.ch create mode 100644 harbour/source/rtl/tlabel.prg create mode 100644 harbour/source/rtl/treport.prg create mode 100644 harbour/tests/ee.frm create mode 100644 harbour/tests/ee.lbl create mode 100644 harbour/tests/testlbl.prg create mode 100644 harbour/tests/testrpt.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index d67cc8ca5c..fe53851d5c 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,21 @@ +20000213-15:50 GMT-3 Luiz Rafael Culik + *makefile.bc + *added the treport and tlabel to the makefile + *doc/funclist.txt + *update status of __reportform() and __labelform() functions + *include/rptdef.ch + *include file for TLabelForm and TReportForm + *source/rtl/tlabel.prg + +__labelform() function + *source/rtl/treport.prg + +__reportform() function + +tests/testlbl.prg + *test file for __labelform() function + +tests/testrpt.prg + *test file for __reportform() function + +tests/ee.frm + +tests/ee.lbl + *report and label files for the examples 20000213-16:15 GMT+1 Ryszard Glab *source/compiler/harbour.y diff --git a/harbour/doc/funclist.txt b/harbour/doc/funclist.txt index d532569961..08843e43c3 100644 --- a/harbour/doc/funclist.txt +++ b/harbour/doc/funclist.txt @@ -299,7 +299,7 @@ __dbZap ;R; __Dir ;R; __Eject ;R; __Keyboard ;R; -__LabelForm ;N; +__LabelForm ;R; __MClear ;R; __MenuTo ;R; __MRelease ;R; @@ -307,7 +307,7 @@ __MRestore ;R; __MSave ;R; __MXRelease ;R; __Quit ;R; -__ReportForm ;N; +__ReportForm ;R; __Run ;R; __SetCentury ;R; __SetFormat ;N; diff --git a/harbour/include/rptdef.ch b/harbour/include/rptdef.ch new file mode 100644 index 0000000000..eccdee1aa6 --- /dev/null +++ b/harbour/include/rptdef.ch @@ -0,0 +1,172 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Header file for TLabelForm and TReportForm Classes + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#ifndef __RPTDEF_CH__ + +#define _RFRM_PAGENO 3 // "Page No." +#define _RFRM_SUBTOTAL 4 // "** Subtotal **" +#define _RFRM_SUBSUBTOTAL 5 // "* Subsubtotal *" +#define _RFRM_TOTAL 6 // "*** Total ***" + +#define RPT_HEADER 1 // Array of header strings +#define RPT_WIDTH 2 // Numeric, report page width +#define RPT_LMARGIN 3 // Numeric, report page offset +#define RPT_RMARGIN 4 // NIL, Not used +#define RPT_LINES 5 // Numeric, number of lines per page +#define RPT_SPACING 6 // Numeric, single=1, double=2 +#define RPT_BEJECT 7 // Logical, eject before 1st page, .T.=Yes .F.=No +#define RPT_AEJECT 8 // Logical, eject after last page, .T.=Yes .F.=No +#define RPT_PLAIN 9 // Logical, plain report, .T.=Yes .F.=No +#define RPT_SUMMARY 10 // Logical, no detail lines, .T.=Yes .F.=No +#define RPT_COLUMNS 11 // Array of Column arrays +#define RPT_GROUPS 12 // Array of Group arrays +#define RPT_HEADING 13 // Character, heading for the report + +#define RPT_COUNT 13 // Number of elements in the Report array + + +// Column array definitions ( one array per column definition ) +#define RCT_EXP 1 // Block, contains compiled column expression +#define RCT_TEXT 2 // Character, contains text column expression +#define RCT_TYPE 3 // Character, type of expression +#define RCT_HEADER 4 // Array of column heading strings +#define RCT_WIDTH 5 // Numeric, column width including decimals and + // decimal point +#define RCT_DECIMALS 6 // Numeric, number of decimal places +#define RCT_TOTAL 7 // Logical, total this column, .T.=Yes .F.=No +#define RCT_PICT 8 // Character, picture string + +#define RCT_COUNT 8 // Number of elements in the Column array + + +// Group array definitions ( one array per group definition ) +#define RGT_EXP 1 // Block, contains compiled group expression +#define RGT_TEXT 2 // Character, contains text group expression +#define RGT_TYPE 3 // Character, type of expression +#define RGT_HEADER 4 // Character, column heading string +#define RGT_AEJECT 5 // Logical, eject after group, .T.=Yes .F.=No + +#define RGT_COUNT 5 // Number of elements in the Group array + +#define SIZE_FILE_BUFF 1990 // Size of report file +#define SIZE_LENGTHS_BUFF 110 +#define SIZE_OFFSETS_BUFF 110 +#define SIZE_EXPR_BUFF 1440 +#define SIZE_FIELDS_BUFF 300 +#define SIZE_PARAMS_BUFF 24 + +// Definitions for offsets into the FILE_BUFF string +#define LENGTHS_OFFSET 5 // Start of expression length array +#define OFFSETS_OFFSET 115 // Start of expression position array +#define EXPR_OFFSET 225 // Start of expression data area +#define FIELDS_OFFSET 1665 // Start of report columns (fields) +#define PARAMS_OFFSET 1965 // Start of report parameters block + +// These are offsets into the FIELDS_BUFF string to actual values +// Values are added to a block offset FLD_OFFSET that is moved in +// increments of 12 +#define FIELD_WIDTH_OFFSET 1 +#define FIELD_TOTALS_OFFSET 6 +#define FIELD_DECIMALS_OFFSET 7 + +// These are offsets into FIELDS_BUFF which are used to 'point' into +// the EXPR_BUFF string which contains the textual data +#define FIELD_CONTENT_EXPR_OFFSET 9 +#define FIELD_HEADER_EXPR_OFFSET 11 + +// These are actual offsets into the PARAMS_BUFF string which +// are used to 'point' into the EXPR_BUFF string +#define PAGE_HDR_OFFSET 1 +#define GRP_EXPR_OFFSET 3 +#define SUB_EXPR_OFFSET 5 +#define GRP_HDR_OFFSET 7 +#define SUB_HDR_OFFSET 9 + +// These are actual offsets into the PARAMS_BUFF string to actual values +#define PAGE_WIDTH_OFFSET 11 +#define LNS_PER_PAGE_OFFSET 13 +#define LEFT_MRGN_OFFSET 15 +#define RIGHT_MGRN_OFFSET 17 +#define COL_COUNT_OFFSET 19 +#define DBL_SPACE_OFFSET 21 +#define SUMMARY_RPT_OFFSET 22 +#define PE_OFFSET 23 +#define OPTION_OFFSET 24 + +// File error definitions +#define F_OK 0 // No error +#define F_EMPTY -3 // File is empty +#define F_ERROR -1 // Some kind of error +#define F_NOEXIST 2 // File does not exist + +#define LBL_REMARK 1 // Character, remark from label file +#define LBL_HEIGHT 2 // Numeric, label height +#define LBL_WIDTH 3 // Numeric, label width +#define LBL_LMARGIN 4 // Numeric, left margin +#define LBL_LINES 5 // Numeric, lines between labels +#define LBL_SPACES 6 // Numeric, spaces between labels +#define LBL_ACROSS 7 // Numeric, number of labels across +#define LBL_FIELDS 8 // Array of Field arrays + +#define LBL_COUNT 8 // Numeric, number of label fields + +// Field array definitions ( one array per field ) +#define LF_EXP 1 // Block, field expression +#define LF_TEXT 2 // Character, text of field expression +#define LF_BLANK 3 // Logical, compress blank fields, .T.=Yes .F.=No + + +#define LF_COUNT 3 // Numeric, number of elements in field array + +#define BUFFSIZE 1034 // Size of label file +#define FILEOFFSET 74 // Start of label content descriptions +#define FIELDSIZE 60 +#define REMARKOFFSET 2 +#define REMARKSIZE 60 +#define HEIGHTOFFSET 62 +#define HEIGHTSIZE 2 +#define WIDTHOFFSET 64 +#define WIDTHSIZE 2 +#define LMARGINOFFSET 66 +#define LMARGINSIZE 2 +#define LINESOFFSET 68 +#define LINESSIZE 2 +#define SPACESOFFSET 70 +#define SPACESSIZE 2 +#define ACROSSOFFSET 72 +#define ACROSSSIZE 2 + +#define __RPTDEF_CH__ +#endif diff --git a/harbour/makefile.bc b/harbour/makefile.bc index f87eef16cc..e4563a1bed 100644 --- a/harbour/makefile.bc +++ b/harbour/makefile.bc @@ -178,8 +178,10 @@ HARBOUR_LIB_OBJS = $(OBJ_DIR)\achoice.obj \ $(OBJ_DIR)\text.obj \ $(OBJ_DIR)\tget.obj \ $(OBJ_DIR)\tgetlist.obj \ + $(OBJ_DIR)\tlabel.obj \ $(OBJ_DIR)\tone.obj \ $(OBJ_DIR)\transfrm.obj \ + $(OBJ_DIR)\treport.obj \ $(OBJ_DIR)\type.obj \ $(OBJ_DIR)\valtype.obj \ $(OBJ_DIR)\wait.obj \ @@ -846,6 +848,12 @@ $(OBJ_DIR)\tgetlist.c : $(RTL_DIR)\tgetlist.prg $(OBJ_DIR)\tgetlist.obj : $(OBJ_DIR)\tgetlist.c $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** tlib $(HARBOUR_LIB) -+$@,, +$(OBJ_DIR)\tlabel.c : $(RTL_DIR)\tlabel.prg + $(HARBOUR_EXE) $** -i$(INCLUDE_DIR) -n $(HARBOUR_OPT) -o$@ + +$(OBJ_DIR)\tlabel.obj : $(OBJ_DIR)\tlabel.c + $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** + tlib $(HARBOUR_LIB) -+$@,, $(OBJ_DIR)\tone.obj : $(RTL_DIR)\tone.c $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** @@ -855,6 +863,13 @@ $(OBJ_DIR)\transfrm.obj : $(RTL_DIR)\transfrm.c $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** tlib $(HARBOUR_LIB) -+$@,, +$(OBJ_DIR)\treport.c : $(RTL_DIR)\treport.prg + $(HARBOUR_EXE) $** -i$(INCLUDE_DIR) -n $(HARBOUR_OPT) -o$@ + +$(OBJ_DIR)\treport.obj : $(OBJ_DIR)\treport.c + $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** + tlib $(HARBOUR_LIB) -+$@,, + $(OBJ_DIR)\type.obj : $(RTL_DIR)\type.c $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** tlib $(HARBOUR_LIB) -+$@,, @@ -1418,4 +1433,3 @@ $(OBJ_DIR)\gentrf.c : $(HBDOC_DIR)\gentrf.prg $(OBJ_DIR)\gentrf.obj : $(OBJ_DIR)\gentrf.c $(BCC_EXE) $(BCC_OPT) -c -I$(INCLUDE_DIR) -o$@ $** - diff --git a/harbour/source/rtl/tlabel.prg b/harbour/source/rtl/tlabel.prg new file mode 100644 index 0000000000..635060292a --- /dev/null +++ b/harbour/source/rtl/tlabel.prg @@ -0,0 +1,456 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * TLabelForm class and __LabelForm() + * + * Copyright 2000 Luiz Rafael Culik + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include 'hbclass.ch' +#include 'inkey.ch' +#include 'rptdef.ch' +#define _LF_SAMPLES 2 // "Do you want more samples?" +#define _LF_YN 12 // "Y/N" + + +CLASS TLabelForm + +DATA aLabelData AS {} +DATA aBandToPrint +DATA cBlank AS "" +DATA lOneMoreBand AS .T. +DATA nCurrentCol // The current column in the band +METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ; + bWhile, nNext, nRecord, lRest, lSample ) +METHOD ExecuteLabel() +METHOD SampleLabels() +METHOD LoadLabel(cLblFile) +ENDCLASS +METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ; + bWhile, nNext, nRecord, lRest, lSample ) CLASS TLabelForm + + LOCAL lPrintOn := .F. // PRINTER status + LOCAL lConsoleOn // CONSOLE status + LOCAL cExtraFile, lExtraState // EXTRA file status + LOCAL xBreakVal, lBroke := .F. + LOCAL err + Local OldMargin + LOCAL nLen + ::aBandToPrint:={} // ARRAY(5) + ::nCurrentCol := 1 + // Resolve parameters + IF cLBLName == NIL + err := ErrorNew() + err:severity := ES_ERROR + err:genCode := EG_ARG + err:subSystem := "FRMLBL" + Eval(ErrorBlock(), err) + + ELSE + IF AT( ".", cLBLName ) == 0 + cLBLName := TRIM( cLBLName ) + ".LBL" + ENDIF + + ENDIF + + IF lPrinter == NIL + lPrinter := .F. + ENDIF + + IF lSample == NIL + lSample := .F. + ENDIF + + // Set output devices + IF lPrinter // To the printer + lPrintOn := SET( _SET_PRINTER, lPrinter ) + ENDIF + + lConsoleOn := SET( _SET_CONSOLE ) + SET( _SET_CONSOLE, ! ( lNoConsole .OR. !lConsoleOn ) ) + + IF (!Empty(cAltFile)) // To file + lExtraState := SET( _SET_EXTRA, .T. ) + cExtraFile := SET( _SET_EXTRAFILE, cAltFile ) + ENDIF + + OldMargin := SET( _SET_MARGIN, 0) + + BEGIN SEQUENCE + + ::aLabelData := ::LoadLabel( cLBLName ) // Load the (.lbl) into an array + + // Add to the left margin if a SET MARGIN has been defined + ::aLabelData[ LBL_LMARGIN ] := ::aLabelData[ LBL_LMARGIN ] + OldMargin + + // Size the ::aBandToPrint array to the number of fields +// nLen := LEN( ::aLabelData[ LBL_FIELDS ] ) + + ASIZE( ::aBandToPrint, LEN( ::aLabelData[ LBL_FIELDS ])) + AFILL( ::aBandToPrint, SPACE( ::aLabelData[ LBL_LMARGIN ] ) ) + + // Create enough space for a blank record + ::cBlank := SPACE( ::aLabelData[ LBL_WIDTH ] + ::aLabelData[ LBL_SPACES ] ) + + // Handle sample labels + IF lSample + ::SampleLabels() + ENDIF + + // Execute the actual label run based on matching records + DBEval( { || ::ExecuteLabel() }, bFor, bWhile, nNext, nRecord, lRest ) + + // Print the last band if there is one + IF ::lOneMoreBand + // Print the band + AEVAL( ::aBandToPrint, { | BandLine | PrintIt( BandLine ) } ) + + ENDIF + + + RECOVER USING xBreakVal + + lBroke := .T. + + END SEQUENCE + + // Clean up and leave + ::aLabelData := {} // Recover the space + ::aBandToPrint := {} + ::nCurrentCol := 1 + ::cBlank := "" + ::lOneMoreBand :=.T. + + // clean up + SET( _SET_PRINTER, lPrintOn ) // Set the printer back to prior state + SET( _SET_CONSOLE, lConsoleOn ) // Set the console back to prior state + + IF (!Empty(cAltFile)) // Set extrafile back + SET( _SET_EXTRAFILE, cExtraFile ) + SET( _SET_EXTRA, lExtraState ) + ENDIF + + IF lBroke + BREAK xBreakVal // continue breaking + ENDIF + + SET( _SET_MARGIN, OldMargin) + + RETURN Self + +METHOD ExecuteLabel() CLASS TLabelForm + LOCAL nField, nMoreLines, aBuffer := {}, cBuffer + LOCAL v + + // Load the current record into aBuffer + FOR nField := 1 TO LEN( ::aLabelData[ LBL_FIELDS ] ) + + if ( ::aLabelData[ LBL_FIELDS, nField ] <> NIL ) + + v := Eval( ::aLabelData[ LBL_FIELDS, nField, LF_EXP ] ) + + cBuffer := PadR( v, ::aLabelData[ LBL_WIDTH ] ) + cBuffer := cBuffer + Space( ::aLabelData[ LBL_SPACES ] ) + + if ( ::aLabelData[ LBL_FIELDS, nField, LF_BLANK ] ) + if ( !Empty( cBuffer ) ) + AADD( aBuffer, cBuffer ) + end + else + AADD( aBuffer, cBuffer ) + endif + + else + + AADD( aBuffer, NIL ) + + end + + NEXT + + ASIZE( aBuffer, LEN( ::aLabelData[ LBL_FIELDS ] ) ) + + // Add aBuffer to ::aBandToPrint + FOR nField := 1 TO LEN( ::aLabelData[ LBL_FIELDS ] ) + IF aBuffer[ nField ] == NIL + ::aBandToPrint[ nField ] := ::aBandToPrint[ nField ] + ::cBlank + ELSE + ::aBandToPrint[ nField ] := ::aBandToPrint[ nField ] + aBuffer[ nField ] + ENDIF + NEXT + + IF ::nCurrentCol == ::aLabelData[ LBL_ACROSS ] + + // trim + FOR nField := 1 TO LEN( ::aBandToPrint ) + ::aBandToPrint[ nField ] := Trim( ::aBandToPrint[ nField ] ) + NEXT + + + ::lOneMoreBand := .F. + ::nCurrentCol := 1 + + // Print the band + AEVAL( ::aBandToPrint, { | BandLine | PrintIt( BandLine ) } ) + + nMoreLines := ::aLabelData[ LBL_HEIGHT ] - LEN( ::aBandToPrint ) + IF nMoreLines > 0 + FOR nField := 1 TO nMoreLines + PrintIt() + NEXT + ENDIF + IF ::aLabelData[ LBL_LINES ] > 0 + + // Add the spaces between the label lines + FOR nField := 1 TO ::aLabelData[ LBL_LINES ] + PrintIt() + NEXT + + ENDIF + + // Clear out the band + AFILL( ::aBandToPrint, SPACE( ::aLabelData[ LBL_LMARGIN ] ) ) + ELSE + ::lOneMoreBand := .T. + ::nCurrentCol := ::nCurrentCol + 1 + ENDIF + + RETURN Self + +METHOD SampleLabels() CLASS TLabelForm + LOCAL nGetKey, lMoreSamples := .T., nField + LOCAL aBand := {} + + // Create the sample label row + ASIZE( aBand, ::aLabelData[ LBL_HEIGHT ] ) + AFILL( aBand, SPACE( ::aLabelData[ LBL_LMARGIN ] ) +; + REPLICATE( REPLICATE( "*", ; + ::aLabelData[ LBL_WIDTH ] ) + ; + SPACE( ::aLabelData[ LBL_SPACES ] ), ; + ::aLabelData[ LBL_ACROSS ] ) ) + + // Prints sample labels + DO WHILE lMoreSamples + + // Print the samples + AEVAL( aBand, { | BandLine | PrintIt( BandLine ) } ) + + IF ::aLabelData[ LBL_LINES ] > 0 + // Add the spaces between the label lines + FOR nField := 1 TO ::aLabelData[ LBL_LINES ] + PrintIt() + NEXT nField + ENDIF + + // Prompt for more + @ ROW(), 0 SAY NationMsg(_LF_SAMPLES)+" ("+Nationmsg(_LF_YN)+")" + nGetKey := INKEY(0) + @ ROW(), COL() SAY CHR(nGetKey) + IF ROW() == MAXROW() + SCROLL( 0, 0, MAXROW(), MAXCOL(), 1 ) + @ MAXROW(), 0 SAY "" + ELSE + @ ROW()+1, 0 SAY "" + ENDIF + IF IsNegative(CHR(nGetKey)) // Don't give sample labels + lMoreSamples := .F. + ENDIF + ENDDO + RETURN Self + + +METHOD LoadLabel( cLblFile ) CLASS TLabelForm + LOCAL i, j := 0 // Counters + LOCAL cBuff := SPACE(BUFFSIZE) // File buffer + LOCAL nHandle := 0 // File handle + LOCAL nReadCount := 0 // Bytes read from file + LOCAL lStatus := .F. // Status + LOCAL nOffset := FILEOFFSET // Offset into file + LOCAL nFileError := F_OK // File error + LOCAL cFieldText := "" // Text expression container + LOCAL err // error object + + LOCAL cDefPath // contents of SET DEFAULT string + LOCAL aPaths // array of paths + LOCAL nPathIndex := 0 // iteration counter + + // Create and initialize default label array + LOCAL aLabel[ LBL_COUNT ] + aLabel[ LBL_REMARK ] := SPACE(60) // Label remark + aLabel[ LBL_HEIGHT ] := 5 // Label height + aLabel[ LBL_WIDTH ] := 35 // Label width + aLabel[ LBL_LMARGIN ] := 0 // Left margin + aLabel[ LBL_LINES ] := 1 // Lines between labels + aLabel[ LBL_SPACES ] := 0 // Spaces between labels + aLabel[ LBL_ACROSS ] := 1 // Number of labels across + aLabel[ LBL_FIELDS ] := {} // Array of label fields + + // Open the label file + nHandle := FOPEN( cLblFile ) + + IF ( ! EMPTY( nFileError := FERROR() ) ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile ) + + // Search through default path; attempt to open label file + cDefPath := SET( _SET_DEFAULT ) + cDefPath := STRTRAN( cDefPath, ",", ";" ) + aPaths := ListAsArray( cDefPath, ";" ) + + FOR nPathIndex := 1 TO LEN( aPaths ) + nHandle := FOPEN( aPaths[ nPathIndex ] + "\" + cLblFile ) + // if no error is reported, we have our label file + IF EMPTY( nFileError := FERROR() ) + EXIT + + ENDIF + + NEXT nPathIndex + + ENDIF + + // File error + IF nFileError != F_OK + err := ErrorNew() + err:severity := ES_ERROR + err:genCode := EG_OPEN + err:subSystem := "FRMLBL" + err:osCode := nFileError + err:filename := cLblFile + Eval(ErrorBlock(), err) + ENDIF + + // If we got this far, assume the label file is open and ready to go + // and so go ahead and read it + nReadCount := FREAD( nHandle, @cBuff, BUFFSIZE ) + + // READ ok? + IF nReadCount == 0 + nFileError := F_EMPTY // File is empty + ELSE + nFileError := FERROR() // Check for DOS errors + ENDIF + + IF nFileError == 0 + + // Load label dimension into aLabel + aLabel[ LBL_REMARK ] := SUBSTR(cBuff, REMARKOFFSET, REMARKSIZE) + aLabel[ LBL_HEIGHT ] := BIN2W(SUBSTR(cBuff, HEIGHTOFFSET, HEIGHTSIZE)) + aLabel[ LBL_WIDTH ] := BIN2W(SUBSTR(cBuff, WIDTHOFFSET, WIDTHSIZE)) + aLabel[ LBL_LMARGIN] := BIN2W(SUBSTR(cBuff, LMARGINOFFSET, LMARGINSIZE)) + aLabel[ LBL_LINES ] := BIN2W(SUBSTR(cBuff, LINESOFFSET, LINESSIZE)) + aLabel[ LBL_SPACES ] := BIN2W(SUBSTR(cBuff, SPACESOFFSET, SPACESSIZE)) + aLabel[ LBL_ACROSS ] := BIN2W(SUBSTR(cBuff, ACROSSOFFSET, ACROSSSIZE)) + + FOR i := 1 TO aLabel[ LBL_HEIGHT ] + + // Get the text of the expression + cFieldText := TRIM( SUBSTR( cBuff, nOffset, FIELDSIZE ) ) + nOffset :=nOffSet + 60 + + IF !EMPTY( cFieldText ) + + AADD( aLabel[ LBL_FIELDS ], {} ) + + // Field expression + AADD( aLabel[ LBL_FIELDS, i ], &( "{ || " + cFieldText + "}" ) ) + + // Text of field + AADD( aLabel[ LBL_FIELDS, i ], cFieldText ) + + // Compression option + AADD( aLabel[ LBL_FIELDS, i ], .T. ) + + ELSE + + AADD( aLabel[ LBL_FIELDS ], NIL ) + + ENDIF + + NEXT + + // Close file + FCLOSE( nHandle ) + nFileError = FERROR() + + ENDIF + RETURN( aLabel ) + + + +FUNCTION __LabelForm( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ; + bWhile, nNext, nRecord, lRest, lSample ) + +RETURN TLabelForm():New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ; + bWhile, nNext, nRecord, lRest, lSample ) + +STATIC PROCEDURE PrintIt( cString ) + + IF cString == NIL + cString := "" + ENDIF + QQOUT( cString ) + QOUT() + + RETURN + +STATIC FUNCTION ListAsArray( cList, cDelimiter ) + + LOCAL nPos + LOCAL aList := {} // Define an empty array + LOCAL lDelimLast := .F. + + IF cDelimiter == NIL + cDelimiter := "," + ENDIF + + DO WHILE ( LEN(cList) <> 0 ) + + nPos := AT(cDelimiter, cList) + + IF ( nPos == 0 ) + nPos := LEN(cList) + ENDIF + + IF ( SUBSTR( cList, nPos, 1 ) == cDelimiter ) + lDelimLast := .T. + AADD(aList, SUBSTR(cList, 1, nPos - 1)) // Add a new element + ELSE + lDelimLast := .F. + AADD(aList, SUBSTR(cList, 1, nPos)) // Add a new element + ENDIF + + cList := SUBSTR(cList, nPos + 1) + + ENDDO + + IF ( lDelimLast ) + AADD(aList, "") + ENDIF + + RETURN aList // Return the array diff --git a/harbour/source/rtl/treport.prg b/harbour/source/rtl/treport.prg new file mode 100644 index 0000000000..3639200129 --- /dev/null +++ b/harbour/source/rtl/treport.prg @@ -0,0 +1,1284 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * TreportForm class and __ReportForm() + * + * Copyright 2000 Luiz Rafael Culik + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + + +#include 'hbclass.ch' +#include 'inkey.ch' +#include 'rptdef.ch' + +CLASS TReportForm +DATA aReportData AS {} +DATA aReportTotals AS {} +DATA aGroupTotals AS {} +DATA nPageNumber +DATA nLinesLeft +DATA lFirstPass +DATA lFormFeeds +DATA nMaxLinesAvail +DATA cExprBuff +DATA cOffsetsBuff +DATA cLengthsBuff + +METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,; + lRest,lPlain,cHeading,lBEject,lSummary) +METHOD ExecuteReport() +METHOD ReportHeader() +METHOD EjectPage() +METHOD PrintIt(cString) +METHOD LoadReportFile(cFile) +METHOD GetExpr( nPointer ) +METHOD GetColumn( cFieldsBuffer, nOffset ) +ENDCLASS + +METHOD NEW(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,; + lRest,lPlain,cHeading,lBEject,lSummary) CLASS TReportForm + LOCAL lPrintOn, lConsoleOn // Status of PRINTER and CONSOLE + LOCAL cExtraFile, lExtraState // Status of EXTRA + LOCAL nCol, nGroup + LOCAL xBreakVal, lBroke := .F. + LOCAL err + + LOCAL lAnyTotals + LOCAL lAnySubTotals + + // Resolve parameters + IF cFRMName == NIL + err := ErrorNew() + err:severity := ES_ERROR + err:genCode := EG_ARG + err:subSystem := "FRMLBL" + Eval(ErrorBlock(), err) + ELSE + IF AT( ".", cFRMName ) == 0 + cFRMName := TRIM( cFRMName ) + ".FRM" + ENDIF + ENDIF + +#ifdef OLDCODE + IF lPrinter == NIL + lPrinter := .F. + ENDIF +#endif + + IF cHeading == NIL + cHeading := "" + ENDIF + + // Set output devices + + lPrintOn := IF( lPrinter, SET( _SET_PRINTER, lPrinter ), ; + SET( _SET_PRINTER ) ) + + lConsoleOn := IF( lNoConsole, SET( _SET_CONSOLE, .F.), ; + SET( _SET_CONSOLE) ) + + IF lPrinter // To the printer + ::lFormFeeds := .T. + ELSE + ::lFormFeeds := .F. + ENDIF + + IF (!Empty(cAltFile)) // To file + lExtraState := SET( _SET_EXTRA, .T. ) + cExtraFile := SET( _SET_EXTRAFILE, cAltFile ) + ENDIF + + + BEGIN SEQUENCE + + ::aReportData := ::LoadReportFile( cFRMName ) // Load the frm into an array + ::nMaxLinesAvail := ::aReportData[RPT_LINES] + + // Modify ::aReportData based on the report parameters + IF lSummary == .T. // Set the summary only flag + ::aReportData[ RPT_SUMMARY ] := lSummary + ENDIF + IF lBEject != NIL .AND. lBEject + ::aReportData[ RPT_BEJECT ] := .F. + ENDIF + IF lPlain // Set plain report flag + ::aReportData[ RPT_PLAIN ] := .T. + cHeading := "" + ::lFormFeeds := .F. + ENDIF + ::aReportData[ RPT_HEADING ] := cHeading + + // Add to the left margin if a SET MARGIN has been defined + // NOTE: uncommenting this line will cause REPORT FORM to respect + // SET MARGIN to screen/to file, but double the margin TO PRINT + // ::aReportData[ RPT_LMARGIN ] += SET( _SET_MARGIN ) + + ::nPageNumber := 1 // Set the initial page number + ::lFirstPass := .T. // Set the first pass flag + + ::nLinesLeft := ::aReportData[ RPT_LINES ] + + + // Check to see if a "before report" eject, or TO FILE has been specified + IF ::aReportData[ RPT_BEJECT ] + ::EjectPage() + + ENDIF + + // Generate the initial report header manually (in case there are no + // records that match the report scope) + ::ReportHeader() + + // Initialize ::aReportTotals to track both group and report totals, then + // set the column total elements to 0 if they are to be totaled, otherwise + // leave them NIL + ::aReportTotals := ARRAY( LEN(::aReportData[RPT_GROUPS]) + 1, ; + LEN(::aReportData[RPT_COLUMNS]) ) + + // Column total elements + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + FOR nGroup := 1 TO LEN(::aReportTotals) + ::aReportTotals[nGroup,nCol] := 0 + NEXT + ENDIF + NEXT + + // Initialize ::aGroupTotals as an array + ::aGroupTotals := ARRAY( LEN(::aReportData[RPT_GROUPS]) ) + + // Execute the actual report based on matching records + DBEval( { || ::ExecuteReport() }, bFor, bWhile, nNext, nRecord, lRest ) + + // Generate any totals that may have been identified + // Make a pass through all the groups + FOR nGroup := LEN(::aReportData[RPT_GROUPS]) TO 1 STEP -1 + + + // make sure group has subtotals + lAnySubTotals := .F. + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + lAnySubTotals := .T. + EXIT // NOTE + ENDIF + NEXT + + IF !lAnySubTotals + LOOP // NOTE + ENDIF + + + // Check to see if we need to eject the page + IF ::nLinesLeft < 2 + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + ENDIF + + // Print the first line + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + ; + IF(nGroup==1,NationMsg(_RFRM_SUBTOTAL),; + NationMsg(_RFRM_SUBSUBTOTAL) ) ) + + // Print the second line + QQOUT( SPACE(::aReportData[RPT_LMARGIN]) ) + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF nCol > 1 + QQOUT( " " ) + ENDIF + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + QQOUT( TRANSFORM(::aReportTotals[nGroup+1,nCol], ; + ::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) ) + ELSE + QQOUT( SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) ) + ENDIF + NEXT + + // Send a cr/lf for the last line + QOUT() + + NEXT + + // Any report totals? + lAnyTotals := .F. + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + lAnyTotals := .T. + EXIT + ENDIF + NEXT nCol + + + IF lAnyTotals + + // Check to see if we need to eject the page + IF ::nLinesLeft < 2 + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + ENDIF + + // Print the first line + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + NationMsg(_RFRM_TOTAL ) ) + + // Print the second line + QQOUT( SPACE(::aReportData[RPT_LMARGIN]) ) + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF nCol > 1 + QQOUT( " " ) + ENDIF + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + QQOUT( TRANSFORM(::aReportTotals[1,nCol], ; + ::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) ) + ELSE + QQOUT( SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) ) + ENDIF + NEXT nCol + + // Send a cr/lf for the last line + QOUT() + + ENDIF + + // Check to see if an "after report" eject, or TO FILE has been specified + IF ::aReportData[ RPT_AEJECT ] + ::EjectPage() + ENDIF + + + RECOVER USING xBreakVal + + lBroke := .T. + + END SEQUENCE + + + // Clean up and leave + ::aReportData := NIL // Recover the space + ::aReportTotals := NIL + ::aGroupTotals := NIL + ::nPageNumber := NIL + ::lFirstPass := NIL + ::nLinesLeft := NIL + ::lFormFeeds := NIL + ::nMaxLinesAvail := NIL + + // clean up + SET( _SET_PRINTER, lPrintOn ) // Set the printer back to prior state + SET( _SET_CONSOLE, lConsoleOn ) // Set the console back to prior state + + IF (!Empty(cAltFile)) // Set extrafile back + SET( _SET_EXTRAFILE, cExtraFile ) + SET( _SET_EXTRA, lExtraState ) + ENDIF + + IF lBroke + // keep the break value going + BREAK xBreakVal + END + + RETURN + +METHOD PrintIt(cString) CLASS TReportForm + + IF cString == NIL + cString := "" + ENDIF + + QQOUT(cString) + QOUT() +RETURN Self + +METHOD EjectPage() CLASS TReportForm + + IF ::lFormFeeds + EJECT + ENDIF + +RETURN Self + +METHOD ReportHeader() CLASS TReportForm + + LOCAL nLinesInHeader := 0 + LOCAL aPageHeader := {} + LOCAL nHeadingLength := ::aReportData[RPT_WIDTH] - ::aReportData[RPT_LMARGIN] -30 + LOCAL nCol,nLine,nMaxColLength,nGroup,cHeader + LOCAL nHeadline + LOCAL nRPageSize + LOCAL aTempPgHeader + LOCAL nHeadSize + + nRPageSize := ::aReportData[RPT_WIDTH] - ::aReportData[RPT_RMARGIN] + + IF !::aReportData[RPT_PLAIN] + IF ::aReportData[RPT_HEADING] == "" + AADD( aPageHeader,NationMsg(_RFRM_PAGENO) + STR(::nPageNumber,6)) + + ELSE + aTempPgHeader:=ParseHeader( ::aReportData[RPT_HEADING],; + Occurs(";",::aReportData[RPT_HEADING]) +1 ) + + FOR nLine := 1 to LEN( aTempPgHeader) + nLinesInHeader:=MAX( XMLCOUNT( LTRIM( aTempPgHeader[ nLine ] ) , ; + nHeadingLength),1) + + FOR nHeadLine := 1 to nLinesInHeader + AADD( aPageHeader, SPACE( 15 ) + ; + PADC( TRIM( XMEMOLINE( LTRIM( aTempPgHeader[ nLine ]),; + nHeadingLength,nHeadLine)), nHeadingLength)) + + NEXT nHeadLine + NEXT nLine + aPageHeader[ 1 ] := STUFF(aPageHeader[ 1 ], 1, 14, ; + NationMsg(_RFRM_PAGENO)+STR(::nPageNumber,6)) + + ENDIF + AADD( aPageHeader, DTOC(DATE()) ) + + ENDIF + FOR nLine := 1 TO LEN( ::aReportData[ RPT_HEADER]) + nLinesInHeader := MAX( XMLCOUNT(LTRIM( ::aReportData[RPT_HEADER,; + nLine ] ), nHeadSize),1 ) + + FOR nHeadLine := 1 to nLinesInHeader + + cHeader:=TRIM( XMEMOLINE( LTRIM( ::aReportData[RPT_HEADER, nLine ]),; + nHeadSize,nHeadLine)) + AADD( aPageHeader, SPACE((nRPageSize - ::aReportData[ RPT_LMARGIN ] -; + LEN( cHeader ) ) / 2 ) + cHeader ) + + NEXT nHeadLine + + NEXT nLine + + nLineInHeader := LEN( aPageHeader) + nMaxColLength :=0 + FOR nCol := 1 TO LEN( ::aReportData[RPT_COLUMNS] ) + nMaxColLength := MAX(LEN(::aReportData[RPT_COLUMNS,nCol,RCT_HEADER]), ; + nMaxColLength) + NEXT + FOR nCol := 1 to LEN( ::aReportData[RPT_COLUMNS] ) + ASIZE( ::aReportData[RPT_COLUMNS,nCol,RCT_HEADER] ,nMaxColLength) + NEXT + FOR nLine:=1 TO nMaxColLength + AADD( aPageHeader, "") + NEXT + + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) // Cycle through the columns + FOR nLine := 1 TO nMaxColLength + IF nCol > 1 + aPageHeader[ nLinesInHeader + nLine ] += " " + ENDIF + IF ::aReportData[RPT_COLUMNS,nCol,RCT_HEADER,nLine] == NIL + aPageHeader[ nLinesInHeader + nLine ] += ; + SPACE( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] ) + ELSE + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] == "N" + aPageHeader[ nLinesInHeader + nLine ] += ; + PADL(::aReportData[RPT_COLUMNS,nCol,RCT_HEADER,nLine],; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) + ELSE + aPageHeader[ nLinesInHeader + nLine ] += ; + PADR(::aReportData[RPT_COLUMNS,nCol,RCT_HEADER,nLine],; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) + ENDIF + ENDIF + NEXT + NEXT + + // Insert the two blank lines between the heading and the actual data + AADD( aPageHeader, "" ) + AADD( aPageHeader, "" ) + AEVAL( aPageHeader, { | HeaderLine | ; + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ HeaderLine ) } ) + + // Set the page number and number of available lines + ::nPageNumber++ + + // adjust the line count to account for Summer '87 behavior + ::nLinesLeft := ::aReportData[RPT_LINES] - LEN( aPageHeader ) + ::nMaxLinesAvail := ::aReportData[RPT_LINES] - LEN( aPageHeader ) + + RETURN SELF +METHOD ExecuteReport() CLASS TReportForm + + LOCAL aRecordHeader := {} // Header for the current record + LOCAL aRecordToPrint := {} // Current record to print + LOCAL nCol // Counter for the column work + LOCAL nGroup // Counter for the group work + LOCAL lGroupChanged := .F. // Has any group changed? + LOCAL lEjectGrp := .F. // Group eject indicator + LOCAL nMaxLines // Number of lines needed by record + LOCAL nLine // Counter for each record line + LOCAL cLine // Current line of text for parsing + LOCAL nLastElement // Last element pointer if record is + + LOCAL lAnySubTotals + + // Add to the main column totals + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + // If this column should be totaled, do it + ::aReportTotals[ 1 ,nCol] += ; + EVAL( ::aReportData[RPT_COLUMNS,nCol,RCT_EXP] ) + ENDIF + NEXT + + // Determine if any of the groups have changed. If so, add the appropriate + // line to aRecordHeader for totaling out the previous records + IF !::lFirstPass // Don't bother first time through + + // Make a pass through all the groups + FOR nGroup := LEN(::aReportData[RPT_GROUPS]) TO 1 STEP -1 + + + // make sure group has subtotals + lAnySubTotals := .F. + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + lAnySubTotals := .T. + EXIT // NOTE + ENDIF + NEXT + + // retrieve group eject state from report form + IF ( nGroup == 1 ) + lEjectGrp := ::aReportData[ RPT_GROUPS, nGroup, RGT_AEJECT ] + ENDIF + + IF !lAnySubTotals + LOOP // NOTE + ENDIF + + // For subgroup processing: check if group has been changed + IF MakeAStr(EVAL(::aReportData[RPT_GROUPS, 1, RGT_EXP]),; + ::aReportData[RPT_GROUPS, 1, RGT_TYPE]) != ::aGroupTotals[1] + lGroupChanged := .T. + ENDIF + + // If this (sub)group has changed since the last record + IF lGroupChanged .OR. MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),; + ::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) != ::aGroupTotals[nGroup] + + AADD( aRecordHeader, IF(nGroup==1,NationMsg(_RFRM_SUBTOTAL),; + NationMsg(_RFRM_SUBSUBTOTAL)) ) + AADD( aRecordHeader, "" ) + + + // Cycle through the columns, adding either the group + // amount from ::aReportTotals or spaces wide enough for + // the non-totaled columns + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + aRecordHeader[ LEN(aRecordHeader) ] += ; + TRANSFORM(::aReportTotals[nGroup+1,nCol], ; + ::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) + // Zero out the group totals column from aReportTotals + ::aReportTotals[nGroup+1,nCol] := 0 + ELSE + aRecordHeader[ LEN(aRecordHeader) ] += ; + SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) + ENDIF + aRecordHeader[ LEN(aRecordHeader) ] += " " + NEXT + // Get rid of the extra space from the last column + aRecordHeader[LEN(aRecordHeader)] := ; + LEFT( aRecordHeader[LEN(aRecordHeader)], ; + LEN(aRecordHeader[LEN(aRecordHeader)]) - 1 ) + ENDIF + NEXT + + ENDIF + + + IF ( LEN( aRecordHeader ) > 0 ) .AND. lEjectGrp .AND. lGroupChanged + IF LEN( aRecordHeader ) > ::nLinesLeft + ::EjectPage() + + IF ( ::aReportData[ RPT_PLAIN ] ) + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + + ENDIF + + AEVAL( aRecordHeader, { | HeaderLine | ; + ::PrintIt( SPACE( ::aReportData[ RPT_LMARGIN ] ) + HeaderLine ) } ) + + aRecordHeader := {} + + ::EjectPage() + + IF ( ::aReportData[ RPT_PLAIN ] ) + ::nLinesLeft := 1000 + + ELSE + ::ReportHeader() + + ENDIF + + ENDIF + + // Add to aRecordHeader in the event that the group has changed and + // new group headers need to be generated + + // Cycle through the groups + FOR nGroup := 1 TO LEN(::aReportData[RPT_GROUPS]) + // If the group has changed + IF MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),; + ::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) == ::aGroupTotals[nGroup] + ELSE + AADD( aRecordHeader, "" ) // The blank line + +// page eject after group + + // put CRFF after group + IF nGroup == 1 .AND. !::lFirstPass .AND. !lAnySubTotals + IF lEjectGrp := ::aReportData[ RPT_GROUPS, nGroup, RGT_AEJECT ] + ::nLinesLeft := 0 + ENDIF + ENDIF + + + AADD( aRecordHeader, IF(nGroup==1,"** ","* ") +; + ::aReportData[RPT_GROUPS,nGroup,RGT_HEADER] + " " +; + MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]), ; + ::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) ) + ENDIF + NEXT + + ::lFirstPass := .F. + + // Is there anything in the record header? + IF LEN( aRecordHeader ) > 0 + // Determine if aRecordHeader will fit on the current page. If not, + // start a new header + IF LEN( aRecordHeader ) > ::nLinesLeft + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + ENDIF + + // Send aRecordHeader to the output device, resetting nLinesLeft + AEVAL( aRecordHeader, { | HeaderLine | ; + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ HeaderLine ) } ) + + ::nLinesLeft -= LEN( aRecordHeader ) + + // Make sure it didn't hit the bottom margin + IF ::nLinesLeft == 0 + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + ENDIF + ENDIF + + // Add to the group totals + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + // If this column should be totaled, do it + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL] + // Cycle through the groups + FOR nGroup := 1 TO LEN( ::aReportTotals ) - 1 + ::aReportTotals[nGroup+1,nCol] += ; + EVAL( ::aReportData[RPT_COLUMNS,nCol,RCT_EXP] ) + NEXT + ENDIF + NEXT + + // Reset the group expressions in aGroupTotals + FOR nGroup := 1 TO LEN(::aReportData[RPT_GROUPS]) + ::aGroupTotals[nGroup] := MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),; + ::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) + NEXT + + // Only run through the record detail if this is NOT a summary report + IF !::aReportData[ RPT_SUMMARY ] + // Determine the max number of lines needed by each expression + nMaxLines := 1 + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "M" + nMaxLines := MAX(XMLCOUNT(EVAL(::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]), nMaxLines) + ELSEIF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "C" + nMaxLines := MAX( XMLCOUNT( STRTRAN( EVAL( ::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),; + ";", CHR(13)+CHR(10)),; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]), nMaxLines) + ENDIF + NEXT + + // Size aRecordToPrint to the maximum number of lines it will need, then + // fill it with nulls + ASIZE( aRecordToPrint, nMaxLines ) + AFILL( aRecordToPrint, "" ) + + // Load the current record into aRecordToPrint + FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) + FOR nLine := 1 TO nMaxLines + // Check to see if it's a memo or character + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "CM" + // Load the current line of the current column into cLine + // with multi-lines per record ";"- method + IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "C" + cLine := XMEMOLINE( TRIM( STRTRAN( EVAL(::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),; + ";", CHR(13)+CHR(10)) ),; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH], nLine ) + ELSE + cLine := XMEMOLINE(TRIM(EVAL(::aReportData[RPT_COLUMNS,nCol,RCT_EXP])),; + ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH], nLine ) + ENDIF + cLine := PADR( cLine, ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] ) + ELSE + IF nLine == 1 + cLine := TRANSFORM(EVAL(::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),; + ::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) + cLine := PADR( cLine, ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] ) + ELSE + cLine := SPACE( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) + ENDIF + ENDIF + // Add it to the existing report line + IF nCol > 1 + aRecordToPrint[ nLine ] += " " + ENDIF + aRecordToPrint[ nLine ] += cLine + NEXT + NEXT + + // Determine if aRecordToPrint will fit on the current page + IF LEN( aRecordToPrint ) > ::nLinesLeft + // The record will not fit on the current page - will it fit on + // a full page? If not, break it up and print it. + IF LEN( aRecordToPrint ) > ::nMaxLinesAvail + // This record is HUGE! Break it up... + nLine := 1 + DO WHILE nLine < LEN( aRecordToPrint ) + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + aRecordToPrint[nLine] ) + nLine++ + ::nLinesLeft-- + IF ::nLinesLeft == 0 + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + ENDIF + ENDDO + ELSE + ::EjectPage() + IF ::aReportData[ RPT_PLAIN ] + ::nLinesLeft := 1000 + ELSE + ::ReportHeader() + ENDIF + AEVAL( aRecordToPrint, ; + { | RecordLine | ; + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ RecordLine ) ; + } ; + ) + ::nLinesLeft -= LEN( aRecordToPrint ) + ENDIF + ELSE + // Send aRecordToPrint to the output device, resetting ::nLinesLeft + AEVAL( aRecordToPrint, ; + { | RecordLine | ; + ::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ RecordLine ) ; + } ; + ) + ::nLinesLeft -= LEN( aRecordToPrint ) + ENDIF + + + // Tack on the spacing for double/triple/etc. + IF ::aReportData[ RPT_SPACING ] > 1 + +/* Double space problem in REPORT FORM at the bottom of the page */ + IF ::nLinesLeft >= ::aReportData[ RPT_SPACING ] - 1 + + FOR nLine := 2 TO ::aReportData[ RPT_SPACING ] + ::PrintIt() + ::nLinesLeft-- + NEXT + ENDIF + ENDIF + + ENDIF // Was this a summary report? + + RETURN + + +METHOD LoadReportFile(cFrmFile) CLASS TReportForm + LOCAL cFieldsBuff + LOCAL cParamsBuff + LOCAL nFieldOffset := 0 + LOCAL cFileBuff := SPACE(SIZE_FILE_BUFF) + LOCAL cGroupExp := SPACE(200) + LOCAL cSubGroupExp := SPACE(200) + LOCAL nColCount := 0 // Number of columns in report + LOCAL nCount + LOCAL nFrmHandle // (.FRM) file handle + LOCAL nBytesRead // Read/write and content record counter + LOCAL nPointer := 0 // Points to an offset into EXPR_BUFF string + LOCAL nFileError // Contains current file error + LOCAL cOptionByte // Contains option byte + + LOCAL aReport[ RPT_COUNT ] // Create report array + LOCAL err // error object + + LOCAL cDefPath // contents of SET DEFAULT string + LOCAL aPaths // array of paths + LOCAL nPathIndex := 0 // iteration counter + + LOCAL s, paths + LOCAL i + LOCAL aHeader // temporary storage for report form headings + LOCAL nHeaderIndex // index into temporary header array + + // Initialize STATIC buffer values + ::cLengthsBuff := "" + ::cOffSetsBuff := "" + ::cExprBuff := "" + + // Default report values + aReport[ RPT_HEADER ] := {} + aReport[ RPT_WIDTH ] := 80 + aReport[ RPT_LMARGIN ] := 8 + aReport[ RPT_RMARGIN ] := 0 + aReport[ RPT_LINES ] := 58 + aReport[ RPT_SPACING ] := 1 + aReport[ RPT_BEJECT ] := .T. + aReport[ RPT_AEJECT ] := .F. + aReport[ RPT_PLAIN ] := .F. + aReport[ RPT_SUMMARY ] := .F. + aReport[ RPT_COLUMNS ] := {} + aReport[ RPT_GROUPS ] := {} + aReport[ RPT_HEADING ] := "" + + // Open the report file + nFrmHandle := FOPEN( cFrmFile ) + + IF ( !EMPTY( nFileError := FERROR() ) ) .AND. !( "\" $ cFrmFile .OR. ":" $ cFrmFile ) + + // Search through default path; attempt to open report file + cDefPath := SET( _SET_DEFAULT ) + ";" + SET( _SET_PATH ) + cDefPath := STRTRAN( cDefPath, ",", ";" ) + aPaths := ListAsArray( cDefPath, ";" ) + + FOR nPathIndex := 1 TO LEN( aPaths ) + nFrmHandle := FOPEN( aPaths[ nPathIndex ] + "\" + cFrmFile ) + // if no error is reported, we have our report file + IF EMPTY( nFileError := FERROR() ) + EXIT + + ENDIF + + NEXT nPathIndex + + ENDIF + + // File error + IF nFileError != F_OK + err := ErrorNew() + err:severity := ES_ERROR + err:genCode := EG_OPEN + err:subSystem := "FRMLBL" + err:osCode := nFileError + err:filename := cFrmFile + Eval(ErrorBlock(), err) + ENDIF + + // OPEN ok? + IF nFileError = F_OK + + // Go to START of report file + FSEEK(nFrmHandle, 0) + + // SEEK ok? + nFileError = FERROR() + IF nFileError = F_OK + + // Read entire file into process buffer + nBytesRead = FREAD(nFrmHandle, @cFileBuff, SIZE_FILE_BUFF) + + // READ ok? + IF nBytesRead = 0 + nFileError = F_EMPTY // file is empty + ELSE + nFileError = FERROR() // check for DOS errors + ENDIF + + IF nFileError = F_OK + + // Is this a .FRM type file (2 at start and end of file) + IF BIN2W(SUBSTR(cFileBuff, 1, 2)) = 2 .AND.; + BIN2W(SUBSTR(cFileBuff, SIZE_FILE_BUFF - 1, 2)) = 2 + + nFileError = F_OK + ELSE + nFileError = F_ERROR + ENDIF + + ENDIF + + ENDIF + + // Close file + IF !FCLOSE(nFrmHandle) + nFileError = FERROR() + ENDIF + + ENDIF + +// File existed, was opened and read ok and is a .FRM file +IF nFileError = F_OK + + // Fill processing buffers + ::cLengthsBuff = SUBSTR(cFileBuff, LENGTHS_OFFSET, SIZE_LENGTHS_BUFF) + ::cOffSetsBuff = SUBSTR(cFileBuff, OFFSETS_OFFSET, SIZE_OFFSETS_BUFF) + ::cExprBuff = SUBSTR(cFileBuff, EXPR_OFFSET, SIZE_EXPR_BUFF) + cFieldsBuff = SUBSTR(cFileBuff, FIELDS_OFFSET, SIZE_FIELDS_BUFF) + cParamsBuff = SUBSTR(cFileBuff, PARAMS_OFFSET, SIZE_PARAMS_BUFF) + + + // Process report attributes + // Report width + aReport[ RPT_WIDTH ] := BIN2W(SUBSTR(cParamsBuff, PAGE_WIDTH_OFFSET, 2)) + + // Lines per page + aReport[ RPT_LINES ] := BIN2W(SUBSTR(cParamsBuff, LNS_PER_PAGE_OFFSET, 2)) + + // Page offset (left margin) + aReport[ RPT_LMARGIN ] := BIN2W(SUBSTR(cParamsBuff, LEFT_MRGN_OFFSET, 2)) + + // Page right margin (not used) + aReport[ RPT_RMARGIN ] := BIN2W(SUBSTR(cParamsBuff, RIGHT_MGRN_OFFSET, 2)) + + nColCount = BIN2W(SUBSTR(cParamsBuff, COL_COUNT_OFFSET, 2)) + + // Line spacing + // Spacing is 1, 2, or 3 + aReport[ RPT_SPACING ] := IF(SUBSTR(cParamsBuff, ; + DBL_SPACE_OFFSET, 1) $ "YyTt", 2, 1) + + // Summary report flag + aReport[ RPT_SUMMARY ] := IF(SUBSTR(cParamsBuff, ; + SUMMARY_RPT_OFFSET, 1) $ "YyTt", .T., .F.) + + // Process report eject and plain attributes option byte + cOptionByte = ASC(SUBSTR(cParamsBuff, OPTION_OFFSET, 1)) + + IF INT(cOptionByte / 4) = 1 + aReport[ RPT_PLAIN ] := .T. // Plain page + cOptionByte -= 4 + ENDIF + + IF INT(cOptionByte / 2) = 1 + aReport[ RPT_AEJECT ] := .T. // Page eject after report + cOptionByte -= 2 + ENDIF + + IF INT(cOptionByte / 1) = 1 + aReport[ RPT_BEJECT ] := .F. // Page eject before report + cOptionByte -= 1 + ENDIF + + // Page heading, report title + nPointer = BIN2W(SUBSTR(cParamsBuff, PAGE_HDR_OFFSET, 2)) + + // Retrieve the header stored in the .FRM file + nHeaderIndex := 4 + aHeader := ParseHeader( ::GetExpr( nPointer ), nHeaderIndex ) + + // certain that we have retrieved all heading entries from the .FRM file, we + // now retract the empty headings + DO WHILE ( nHeaderIndex > 0 ) + IF ! EMPTY( aHeader[ nHeaderIndex ] ) + EXIT + ENDIF + nHeaderIndex-- + ENDDO + + aReport[ RPT_HEADER ] := IIF( EMPTY( nHeaderIndex ) , {}, ; + ASIZE( aHeader, nHeaderIndex ) ) + + // Process Groups + // Group + nPointer = BIN2W(SUBSTR(cParamsBuff, GRP_EXPR_OFFSET, 2)) + + IF !EMPTY(cGroupExp := ::GetExpr( nPointer )) + + // Add a new group array + AADD( aReport[ RPT_GROUPS ], ARRAY( RG_COUNT )) + + // Group expression + aReport[ RPT_GROUPS ][1][ RG_TEXT ] := cGroupExp + aReport[ RPT_GROUPS ][1][ RG_EXP ] := &( "{ || " + cGroupExp + "}" ) + IF USED() + aReport[ RPT_GROUPS ][1][ RG_TYPE ] := ; + VALTYPE( EVAL( aReport[ RPT_GROUPS ][1][ RG_EXP ] ) ) + ENDIF + + // Group header + nPointer = BIN2W(SUBSTR(cParamsBuff, GRP_HDR_OFFSET, 2)) + aReport[ RPT_GROUPS ][1][ RG_HEADER ] := ::GetExpr( nPointer ) + + // Page eject after group + aReport[ RPT_GROUPS ][1][ RG_AEJECT ] := IF(SUBSTR(cParamsBuff, ; + PE_OFFSET, 1) $ "YyTt", .T., .F.) + + ENDIF + + // Subgroup + nPointer = BIN2W(SUBSTR(cParamsBuff, SUB_EXPR_OFFSET, 2)) + + IF !EMPTY(cSubGroupExp := ::GetExpr( nPointer )) + + // Add new group array + AADD( aReport[ RPT_GROUPS ], ARRAY( RG_COUNT )) + + // Subgroup expression + aReport[ RPT_GROUPS ][2][ RG_TEXT ] := cSubGroupExp + aReport[ RPT_GROUPS ][2][ RG_EXP ] := &( "{ || " + cSubGroupExp + "}" ) + IF USED() + aReport[ RPT_GROUPS ][2][ RG_TYPE ] := ; + VALTYPE( EVAL( aReport[ RPT_GROUPS ][2][ RG_EXP ] ) ) + ENDIF + + // Subgroup header + nPointer = BIN2W(SUBSTR(cParamsBuff, SUB_HDR_OFFSET, 2)) + aReport[ RPT_GROUPS ][2][ RG_HEADER ] := ::GetExpr( nPointer ) + + // Page eject after subgroup + aReport[ RPT_GROUPS ][2][ RG_AEJECT ] := .F. + + ENDIF + + // Process columns + nFieldOffset := 12 // dBASE skips first 12 byte fields block. + FOR nCount := 1 to nColCount + + AADD( aReport[ RPT_COLUMNS ], ::GetColumn( cFieldsBuff, @nFieldOffset ) ) + + NEXT nCount + +ENDIF + +RETURN aReport + +METHOD GetExpr( nPointer ) CLASS TReportForm + LOCAL nExprOffset := 0 + LOCAL nExprLength := 0 + LOCAL nOffsetOffset := 0 + LOCAL cString := "" + + // Stuff for dBASE compatability. + IF nPointer != 65535 + + // Convert DOS FILE offset to CLIPPER string offset + nPointer++ + + // Calculate offset into OFFSETS_BUFF + IF nPointer > 1 + nOffsetOffset = (nPointer * 2) - 1 + ENDIF + + nExprOffset = BIN2W(SUBSTR(::cOffsetsBuff, nOffsetOffset, 2)) + nExprLength = BIN2W(SUBSTR(::cLengthsBuff, nOffsetOffset, 2)) + + // EXPR_OFFSET points to a NULL, so add one (+1) to get the string + // and subtract one (-1) from EXPR_LENGTH for correct length + + nExprOffset++ + nExprLength-- + + // Extract string + cString = SUBSTR(::cExprBuff, nExprOffset, nExprLength) + + // dBASE does this so we must do it too + // Character following character pointed to by pointer is NULL + IF CHR(0) == SUBSTR(cString, 1, 1) .AND. LEN(SUBSTR(cString,1,1)) = 1 + cString = "" + ENDIF + ENDIF + + RETURN (cString) + + +STATIC FUNCTION Occurs( cSearch, cTarget ) + LOCAL nPos, nCount := 0 + DO WHILE !EMPTY( cTarget ) + IF (nPos := AT( cSearch, cTarget )) != 0 + nCount++ + cTarget := SUBSTR( cTarget, nPos + 1 ) + ELSE + // End of string + cTarget := "" + ENDIF + ENDDO + RETURN nCount + + + +STATIC FUNCTION XMLCOUNT( cString, nLineLength, nTabSize, lWrap ) + // Set defaults if none specified + nLineLength := IF( nLineLength == NIL, 79, nLineLength ) + nTabSize := IF( nTabSize == NIL, 4, nTabSize ) + lWrap := IF( lWrap == NIL, .T., .F. ) + + IF nTabSize >= nLineLength + nTabSize := nLineLength - 1 + ENDIF + RETURN( MLCOUNT( TRIM(cString), nLineLength, nTabSize, lWrap ) ) + + +/*** +* +* XMEMOLINE( , [], [], +* [], [] ) --> cLine +* +*/ +STATIC FUNCTION XMEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap ) + + // Set defaults if none specified + nLineLength := IF( nLineLength == NIL, 79, nLineLength ) + nLineNumber := IF( nLineNumber == NIL, 1, nLineNumber ) + nTabSize := IF( nTabSize == NIL, 4, nTabSize ) + lWrap := IF( lWrap == NIL, .T., lWrap ) + + IF nTabSize >= nLineLength + nTabSize := nLineLength - 1 + ENDIF + + RETURN( MEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap ) ) + +STATIC FUNCTION ParseHeader( cHeaderString, nFields ) + LOCAL cItem + LOCAL nItemCount := 0 + LOCAL aPageHeader := {} + LOCAL nHeaderLen := 254 + LOCAL nPos + + DO WHILE ( ++nItemCount <= nFields ) + + cItem := SUBSTR( cHeaderString, 1, nHeaderLen ) + + // check for explicit delimiter + nPos := AT( ";", cItem ) + + IF ! EMPTY( nPos ) + // delimiter present + AADD( aPageHeader, SUBSTR( cItem, 1, nPos - 1 ) ) + ELSE + IF EMPTY( cItem ) + // empty string for S87 and 5.0 compatibility + AADD( aPageHeader, "" ) + ELSE + // exception + AADD( aPageHeader, cItem ) + + ENDIF + // empty or not, we jump past the field + nPos := nHeaderLen + ENDIF + + cHeaderString := SUBSTR( cHeaderString, nPos + 1 ) + + ENDDO + + RETURN( aPageHeader ) + +/*** +* GetExpr( nPointer ) --> cString +* +* Reads an expression from EXPR_BUFF via the OFFSETS_BUFF and returns +* a pointer to offset contained in OFFSETS_BUFF that in turn points +* to an expression located in the EXPR_BUFF string. +* +* Notes: +* +* 1. The expression is empty if: +* a. Passed pointer is equal to 65535 +* b. Character following character pointed to by pointer is CHR(0) +* +*/ + + +/*** +* GetColumn( , @ ) --> aColumn +* +* Get a COLUMN element from FIELDS_BUFF string using nOffset to point to +* the current FIELDS_OFFSET block. +* +* Notes: +* 1. The Header or Contents expressions are empty if: +* a. Passed pointer is equal to 65535 +* b. Character following character pointed to by pointer is CHR(0) +* +*/ +METHOD GetColumn( cFieldsBuffer, nOffset ) CLASS TReportForm + LOCAL nPointer := 0, nNumber := 0, aColumn[ RCT_COUNT ], cType,cExpr + + // Column width + aColumn[ RCT_WIDTH ] := BIN2W(SUBSTR(cFieldsBuffer, nOffset + ; + FIELD_WIDTH_OFFSET, 2)) + + // Total column? + aColumn[ RCT_TOTAL ] := IF(SUBSTR(cFieldsBuffer, nOffset + ; + FIELD_TOTALS_OFFSET, 1) $ "YyTt", .T., .F.) + + // Decimals width + aColumn[ RCT_DECIMALS ] := BIN2W(SUBSTR(cFieldsBuffer, nOffset + ; + FIELD_DECIMALS_OFFSET, 2)) + + // Offset (relative to FIELDS_OFFSET), 'point' to + // expression area via array OFFSETS[] + + // Content expression + nPointer = BIN2W(SUBSTR(cFieldsBuffer, nOffset +; + FIELD_CONTENT_EXPR_OFFSET, 2)) + aColumn[ RCT_TEXT ] := ::GetExpr( nPointer ) + cExpr := aColumn[ RCT_TEXT ] + aColumn[ RCT_EXP ] := &( "{ || " + cExpr + "}" ) + + // Header expression + nPointer = BIN2W(SUBSTR(cFieldsBuffer, nOffset +; + FIELD_HEADER_EXPR_OFFSET, 2)) + + aColumn[ RCT_HEADER ] := ListAsArray(::GetExpr( nPointer ), ";") + + // Column picture + // Setup picture only if a database file is open + IF USED() + cType := VALTYPE( EVAL(aColumn[ RCT_EXP ]) ) + aColumn[ RCT_TYPE ] := cType + DO CASE + CASE cType = "C" .OR. cType = "M" + aColumn[ RCT_PICT ] := REPLICATE("X", aColumn[ RCT_WIDTH ]) + CASE cType = "D" + aColumn[ RCT_PICT ] := "@D" + CASE cType = "N" + IF aColumn[ RCT_DECIMALS ] != 0 + aColumn[ RCT_PICT ] := REPLICATE("9", aColumn[ RCT_WIDTH ] - aColumn[ RCT_DECIMALS ] -1) + "." + ; + REPLICATE("9", aColumn[ RCT_DECIMALS ]) + ELSE + aColumn[ RCT_PICT ] := REPLICATE("9", aColumn[ RCT_WIDTH ]) + ENDIF + CASE cType = "L" + aColumn[ RCT_PICT ] := "@L" + REPLICATE("X",aColumn[ RCT_WIDTH ]-1) + ENDCASE + ENDIF + + // Update offset into ?_buffer + nOffset += 12 + + RETURN ( aColumn ) + +/*** +* +* ListAsArray( , ) --> aList +* Convert a delimited string to an array +* +*/ +STATIC FUNCTION ListAsArray( cList, cDelimiter ) + + LOCAL nPos + LOCAL aList := {} // Define an empty array + LOCAL lDelimLast := .F. + + IF cDelimiter == NIL + cDelimiter := "," + ENDIF + + DO WHILE ( LEN(cList) <> 0 ) + + nPos := AT(cDelimiter, cList) + + IF ( nPos == 0 ) + nPos := LEN(cList) + ENDIF + + IF ( SUBSTR( cList, nPos, 1 ) == cDelimiter ) + lDelimLast := .T. + AADD(aList, SUBSTR(cList, 1, nPos - 1)) // Add a new element + ELSE + lDelimLast := .F. + AADD(aList, SUBSTR(cList, 1, nPos)) // Add a new element + ENDIF + + cList := SUBSTR(cList, nPos + 1) + + ENDDO + + IF ( lDelimLast ) + AADD(aList, "") + ENDIF + + RETURN aList // Return the array + +STATIC FUNCTION MakeAStr( uVar, cType ) + LOCAL cString + DO CASE + CASE UPPER(cType) == "D" + cString := DTOC( uVar ) + + CASE UPPER(cType) == "L" + cString := IF( uVar, "T", "F" ) + + CASE UPPER(cType) == "N" + cString := STR( uVar ) + + CASE UPPER(cType) == "C" + cString := uVar + + OTHERWISE + cString := "INVALID EXPRESSION" + ENDCASE + RETURN( cString ) + +FUNCTION __ReportForm( cFRMName, lPrinter, cAltFile, lNoConsole, bFor, ; + bWhile, nNext, nRecord, lRest, lPlain, cHeading, ; + lBEject, lSummary ) +Return ( TReportForm():New(cFrmName,lPrinter,cAltFile,lNoConsole,bFor,bWhile,nNext,nRecord,; + lRest,lPlain,cHeading,lBEject,lSummary) ) diff --git a/harbour/tests/ee.frm b/harbour/tests/ee.frm new file mode 100644 index 0000000000000000000000000000000000000000..32b4fc5fd5ff1048a3cc5310204ff9cc5f6e8b13 GIT binary patch literal 1990 zcmZQ#aAsg+;9=kfLM|ZWWS~7@1ll9Ppv<7lU`2b&LQ;!MbnV