/* * $Id$ */ /* * Harbour Project source code: * HBreportForm 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, or (at your option) * any later version. * * 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 software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). * * As a special exception, the Harbour Project gives permission for * additional uses of the text contained in its release of Harbour. * * The exception is that, if you link the Harbour libraries 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 Harbour library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the Harbour * Project under the name Harbour. If you copy code from other * Harbour Project or Free Software Foundation releases into a copy of * Harbour, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for Harbour, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. * */ #include "hbclass.ch" #include "common.ch" #include "error.ch" #include "fileio.ch" #include "inkey.ch" #define F_OK 0 // No error #define F_EMPTY -3 // File is empty #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 CREATE CLASS HBReportForm VAR aReportData INIT {} VAR aReportTotals INIT {} VAR aGroupTotals INIT {} VAR nPageNumber VAR nLinesLeft VAR lFirstPass VAR lFormFeeds VAR nMaxLinesAvail VAR cExprBuff AS STRING VAR cOffsetsBuff AS STRING VAR cLengthsBuff AS STRING METHOD New( cFrmName AS STRING,; lPrinter AS LOGICAL,; cAltFile AS STRING,; lNoConsole AS LOGICAL,; bFor AS CODEBLOCK,; bWhile AS CODEBLOCK,; nNext AS NUMERIC,; nRecord AS NUMERIC,; lRest AS LOGICAL,; lPlain AS LOGICAL,; cHeading AS STRING,; lBEject AS LOGICAL,; lSummary AS LOGICAL ) METHOD ExecuteReport() METHOD ReportHeader() METHOD EjectPage() METHOD PrintIt( cString AS STRING ) METHOD LoadReportFile( cFile AS STRING ) METHOD GetExpr( nPointer AS NUMERIC ) METHOD GetColumn( cFieldsBuffer AS STRING, nOffset AS NUMERIC ) ENDCLASS METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nRecord,; lRest, lPlain, cHeading, lBEject, lSummary ) CLASS HBReportForm LOCAL lPrintOn, lConsoleOn // Status of PRINTER and CONSOLE LOCAL cExtraFile, lExtraState // Status of EXTRA LOCAL nCol, nGroup LOCAL xBreakVal, lBroke := .F. LOCAL err LOCAL cExt 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 /* NOTE: CA-Cl*pper does an RTrim() on the filename here, but in Harbour we're using _SET_TRIMFILENAME. */ IF Set( _SET_DEFEXTENSIONS ) hb_FNameSplit( cFRMName, NIL, NIL, @cExt ) IF Empty( cExt ) cFRMName += ".frm" ENDIF ENDIF ENDIF DEFAULT cHeading TO "" // Set output devices lPrintOn := iif( lPrinter, Set( _SET_PRINTER, lPrinter ), Set( _SET_PRINTER ) ) lConsoleOn := iif( 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 // 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 ] QOUT() // output additional line on first page (S87 compatibility) ::nLinesLeft-- // 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] ) + ; iif( nGroup == 1, __NatMsg( _RFRM_SUBTOTAL ),; __NatMsg( _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]) + __NatMsg(_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 ENDIF RETURN NIL METHOD PrintIt( cString ) CLASS HBReportForm DEFAULT cString TO "" QQOut( cString ) QOut() RETURN Self METHOD EjectPage() CLASS HBReportForm IF ::lFormFeeds EJECT ENDIF RETURN Self METHOD ReportHeader() CLASS HBReportForm LOCAL nLinesInHeader LOCAL aPageHeader := {} LOCAL nHeadingLength := ::aReportData[RPT_WIDTH] - ::aReportData[RPT_LMARGIN] -30 LOCAL nCol, nLine, nMaxColLength, cHeader LOCAL nHeadline LOCAL nRPageSize LOCAL aTempPgHeader nRPageSize := ::aReportData[RPT_WIDTH] - ::aReportData[RPT_RMARGIN] IF !::aReportData[RPT_PLAIN] IF ::aReportData[RPT_HEADING] == "" AAdd( aPageHeader,__NatMsg(_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( RTrim( XMEMOLINE( LTrim( aTempPgHeader[ nLine ]),; nHeadingLength,nHeadLine)), nHeadingLength)) NEXT nHeadLine NEXT nLine aPageHeader[ 1 ] := Stuff(aPageHeader[ 1 ], 1, 14, ; __NatMsg(_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 ] )),1 ) FOR nHeadLine := 1 to nLinesInHeader cHeader := RTrim( XMEMOLINE( LTrim( ::aReportData[RPT_HEADER, nLine ]),,; nHeadLine)) AAdd( aPageHeader, Space((nRPageSize - ::aReportData[ RPT_LMARGIN ] -; Len( cHeader ) ) / 2 ) + cHeader ) NEXT nHeadLine NEXT nLine AADD( aPageHeader, "" ) // S87 compat. nLinesInHeader := 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 HBReportForm 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 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, iif( nGroup == 1, __NatMsg( _RFRM_SUBTOTAL ),; __NatMsg( _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 ::aReportData[ RPT_GROUPS, nGroup, RGT_AEJECT ] ::nLinesLeft := 0 ENDIF ENDIF AAdd( aRecordHeader, iif( 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]),; ";", hb_osNewLine() ),; ::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( RTrim( StrTran( Eval(::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),; ";", hb_osNewLine() ) ),; ::aReportData[ RPT_COLUMNS, nCol, RCT_WIDTH ], nLine ) ELSE cLine := XMEMOLINE( RTrim( 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 NIL METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm LOCAL cFieldsBuff LOCAL cParamsBuff LOCAL nFieldOffset := 0 LOCAL cFileBuff := Space( SIZE_FILE_BUFF ) LOCAL cGroupExp LOCAL cSubGroupExp LOCAL nColCount // Number of columns in report LOCAL nCount LOCAL nFrmHandle // (.frm) file handle LOCAL nBytesRead // Read/write and content record counter LOCAL nPointer // 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 // iteration counter 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 ] := iif( SubStr( cParamsBuff, ; DBL_SPACE_OFFSET, 1 ) $ "YyTt", 2, 1 ) // Summary report flag aReport[ RPT_SUMMARY ] := iif( 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( RGT_COUNT ) ) // Group expression aReport[ RPT_GROUPS ][ 1 ][ RGT_TEXT ] := cGroupExp aReport[ RPT_GROUPS ][ 1 ][ RGT_EXP ] := hb_macroBlock( cGroupExp ) IF Used() aReport[ RPT_GROUPS ][ 1 ][ RGT_TYPE ] := ; ValType( Eval( aReport[ RPT_GROUPS ][ 1 ][ RGT_EXP ] ) ) ENDIF // Group header nPointer := BIN2W( SubStr( cParamsBuff, GRP_HDR_OFFSET, 2 ) ) aReport[ RPT_GROUPS ][ 1 ][ RGT_HEADER ] := ::GetExpr( nPointer ) // Page eject after group aReport[ RPT_GROUPS ][ 1 ][ RGT_AEJECT ] := iif( 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( RGT_COUNT ) ) // Subgroup expression aReport[ RPT_GROUPS ][ 2 ][ RGT_TEXT ] := cSubGroupExp aReport[ RPT_GROUPS ][ 2 ][ RGT_EXP ] := hb_macroBlock( cSubGroupExp ) IF Used() aReport[ RPT_GROUPS ][ 2 ][ RGT_TYPE ] := ; ValType( Eval( aReport[ RPT_GROUPS ][ 2 ][ RGT_EXP ] ) ) ENDIF // Subgroup header nPointer := BIN2W( SubStr( cParamsBuff, SUB_HDR_OFFSET, 2 ) ) aReport[ RPT_GROUPS ][ 2 ][ RGT_HEADER ] := ::GetExpr( nPointer ) // Page eject after subgroup aReport[ RPT_GROUPS ][ 2 ][ RGT_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 /*** * 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) * */ METHOD GetExpr( nPointer ) CLASS HBReportForm LOCAL nExprOffset LOCAL nExprLength 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 ) DEFAULT nLineLength TO 79 DEFAULT nTabSize TO 4 DEFAULT lWrap TO .T. IF nTabSize >= nLineLength nTabSize := nLineLength - 1 ENDIF RETURN MLCount( RTrim( cString ), nLineLength, nTabSize, lWrap ) /*** * * XMEMOLINE( , [], [], * [], [] ) --> cLine * */ STATIC FUNCTION XMEMOLINE( cString, nLineLength, nLineNumber, nTabSize, lWrap ) DEFAULT nLineLength TO 79 DEFAULT nLineNumber TO 1 DEFAULT nTabSize TO 4 DEFAULT lWrap TO .T. 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 /*** * 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 HBReportForm LOCAL nPointer, aColumn[ RCT_COUNT ], cType, cExpr // Column width aColumn[ RCT_WIDTH ] := BIN2W(SubStr(cFieldsBuffer, nOffset + ; FIELD_WIDTH_OFFSET, 2)) // Total column? aColumn[ RCT_TOTAL ] := iif(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 ] := hb_macroBlock( 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 == "T" aColumn[ RCT_PICT ] := "@T" 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. DEFAULT cDelimiter TO "," 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 ) == "T" cString := hb_TToC( uVar ) CASE Upper( cType ) == "L" cString := iif( 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 HBReportForm():New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nRecord,; lRest, lPlain, cHeading, lBEject, lSummary)