{*****************************************} { } { FastReport v2.3 } { Report classes } { } { Copyright (c) 1998-99 by Tzyganenko A. } { } {*****************************************} unit LR_Class; interface {$I LR_Vers.inc} uses SysUtils, Classes, Controls, FileUtil, Forms, StdCtrls, ComCtrls, Dialogs, Menus, Variants, DB,Graphics,Printers,osPrinters,XMLCfg, LCLType,LCLIntf,TypInfo,LCLProc, SysUtilsAdds, LR_View, LR_Pars, LR_Intrp, LR_DSet, LR_DBSet, LR_DBRel,LR_Const; const // object flags flStretched = 1; flWordWrap = 2; flWordBreak = 4; flAutoSize = 8; flBandNewPageAfter = 2; flBandPrintifSubsetEmpty = 4; flBandPageBreak = 8; flBandOnFirstPage = $10; flBandOnLastPage = $20; flBandRepeatHeader = $40; flPictCenter = 2; flPictRatio = 4; flWantHook = $8000; // object types gtMemo = 0; gtPicture = 1; gtBand = 2; gtSubReport = 3; gtLine = 4; gtAddIn = 10; //format type fmtText = 0; fmtNumber = 1; fmtDate = 2; fmtTime = 3; fmtBoolean = 4; type TfrDrawMode = (drAll, drCalcHeight, drAfterCalcHeight, drPart); TfrBandType = (btReportTitle, btReportSummary, btPageHeader, btPageFooter, btMasterHeader, btMasterData, btMasterFooter, btDetailHeader, btDetailData, btDetailFooter, btSubDetailHeader, btSubDetailData, btSubDetailFooter, btOverlay, btColumnHeader, btColumnFooter, btGroupHeader, btGroupFooter, btCrossHeader, btCrossData, btCrossFooter, btNone); TfrDataSetPosition = (psLocal, psGlobal); TfrValueType = (vtNotAssigned, vtDBField, vtOther, vtFRVar); TfrPageMode = (pmNormal, pmBuildList); TfrBandRecType = (rtShowBand, rtFirst, rtNext); TfrRgnType = (rtNormal, rtExtended); TfrReportType = (rtSimple, rtMultiple); TfrStreamMode = (smDesigning, smPrinting); TfrFrameBorder = (frbLeft, frbTop, frbRight, frbBottom); TfrFrameBorders = set of TfrFrameBorder; TfrFrameStyle = (frsSolid,frsDash, frsDot, frsDashDot, frsDashDotDot,frsDouble); TfrPageType = (ptReport, ptDialog); TfrView = class; TfrBand = class; TfrPage = class; TfrReport = class; TfrExportFilter = class; TDetailEvent = procedure(const ParName: String; var ParValue: Variant) of object; TEnterRectEvent = procedure(Memo: TStringList; View: TfrView) of object; TBeginDocEvent = procedure of object; TEndDocEvent = procedure of object; TBeginPageEvent = procedure(pgNo: Integer) of object; TEndPageEvent = procedure(pgNo: Integer) of object; TBeginBandEvent = procedure(Band: TfrBand) of object; TEndBandEvent = procedure(Band: TfrBand) of object; TfrProgressEvent = procedure(n: Integer) of object; TBeginColumnEvent = procedure(Band: TfrBand) of object; TPrintColumnEvent = procedure(ColNo: Integer; var Width: Integer) of object; TManualBuildEvent = procedure(Page: TfrPage) of object; TfrHighlightAttr = packed record FontStyle: Word; FontColor, FillColor: TColor; end; // print info about page size, margins e.t.c TfrPrnInfo = record PPgw, PPgh, Pgw, Pgh : Integer; // page width/height (printer/screen) POfx, POfy, Ofx, Ofy : Integer; // offset x/y PPw, PPh, Pw, Ph : Integer; // printable width/height end; PfrPageInfo = ^TfrPageInfo; TfrPageInfo = packed record // pages of a preview R : TRect; pgSize : Word; pgWidth : Integer; pgHeight : Integer; pgOr : TPrinterOrientation; pgMargins : Boolean; PrnInfo : TfrPrnInfo; Visible : Boolean; Stream : TMemoryStream; Page : TfrPage; end; PfrBandRec = ^TfrBandRec; TfrBandRec = packed record Band : TfrBand; Action : TfrBandRecType; end; TLayoutOrder = (loColumns, loRows); TfrMemoStrings =Class(TStringList); TfrScriptStrings=Class(TStringList); TfrDialogForm = Class(TForm); { TfrObject } TfrObject = Class(TPersistent) private fMemo : TfrMemoStrings; fName : string; fScript : TfrScriptStrings; fVisible: Boolean; fUpdate : Integer; procedure SetMemo(const AValue: TfrMemoStrings); procedure SetName(const AValue: string); procedure SetScript(const AValue: TfrScriptStrings); protected BaseName : String; function GetSaveProperty(Prop : String; aObj : TPersistent=nil) : string; procedure RestoreProperty(Prop,aValue : String; aObj : TPersistent=nil); public x, y, dx, dy: Integer; constructor Create; virtual; destructor Destroy; override; procedure Assign(From: TfrView); virtual; overload; procedure BeginUpdate; procedure EndUpdate; procedure CreateUniqueName; procedure LoadFromXML(XML: TXMLConfig; Path: String); virtual; procedure SaveToXML(XML: TXMLConfig; Path: String); virtual; property Memo : TfrMemoStrings read fMemo write SetMemo; property Script : TfrScriptStrings read fScript write SetScript; property Left : Integer read x write x; property Top : Integer read y write y; property Width : Integer read dx write dx; property Height : Integer read dy write dy; published property Name : string read fName write SetName; property Visible: Boolean read fVisible write fVisible; end; { TfrView } TfrView = class(TfrObject) private fFillColor : TColor; fCanvas : TCanvas; fFrameColor: TColor; fFrames : TfrFrameBorders; fFrameStyle: TfrFrameStyle; fFrameWidth: Double; fStretched : Boolean; fStreamMode: TfrStreamMode; fFormat : Integer; fFormatStr : string; function GetHeight: Double; function GetLeft: Double; function GetTop: Double; function GetWidth: Double; procedure P1Click(Sender: TObject); procedure SetFillColor(const AValue: TColor); procedure SetFormat(const AValue: Integer); procedure SetFormatStr(const AValue: String); procedure SetFrameColor(const AValue: TColor); procedure SetFrames(const AValue: TfrFrameBorders); procedure SetFrameStyle(const AValue: TfrFrameStyle); procedure SetFrameWidth(const AValue: Double); procedure SetHeight(const AValue: Double); procedure SetLeft(const AValue: Double); procedure SetStretched(const AValue: Boolean); procedure SetTop(const AValue: Double); procedure SetWidth(const AValue: Double); protected SaveX, SaveY, SaveDX, SaveDY: Integer; SaveFW: Double; gapx, gapy: Integer; Memo1: TStringList; FDataSet: TfrTDataSet; FField: String; olddy: Integer; procedure ShowBackGround; virtual; procedure ShowFrame; virtual; procedure BeginDraw(ACanvas: TCanvas); procedure GetBlob(b: TfrTField); virtual; procedure OnHook(View: TfrView); virtual; procedure BeforeChange; procedure AfterChange; public Parent: TfrBand; ID: Integer; Typ: Byte; Selected: Boolean; OriginalRect: TRect; ScaleX, ScaleY: Double; // used for scaling objects in preview OffsX, OffsY: Integer; // IsPrinting: Boolean; Flags: Word; DRect: TRect; constructor Create; override; destructor Destroy; override; procedure Assign(From: TfrView); override; procedure CalcGaps; virtual; procedure RestoreCoord; virtual; procedure Draw(aCanvas: TCanvas); virtual; abstract; procedure Print(Stream: TStream); virtual; procedure ExportData; virtual; procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToStream(Stream: TStream); virtual; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SaveToXML(XML: TXMLConfig; Path: String); override; procedure Resized; virtual; procedure DefinePopupMenu(Popup: TPopupMenu); virtual; function GetClipRgn(rt: TfrRgnType): HRGN; virtual; procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); function PointInView(aX,aY : Integer) : Boolean; virtual; procedure Invalidate; property Canvas : TCanvas read fCanvas write fCanvas; property FillColor : TColor read fFillColor write SetFillColor; property Stretched : Boolean read fStretched write SetStretched; property Frames : TfrFrameBorders read fFrames write SetFrames; property FrameColor : TColor read fFrameColor write SetFrameColor; property FrameStyle : TfrFrameStyle read fFrameStyle write SetFrameStyle; property FrameWidth : Double read fFrameWidth write SetFrameWidth; property Format : Integer read fFormat write SetFormat; property FormatStr : String read fFormatStr write SetFormatStr; property StreamMode: TfrStreamMode read fStreamMode write fStreamMode; published property Left: double read GetLeft write SetLeft; property Top: double read GetTop write SetTop; property Width: double read GetWidth write SetWidth; property Height: double read GetHeight write SetHeight; end; TfrViewClass = Class of TFRView; TfrStretcheable = class(TfrView) protected ActualHeight: Integer; DrawMode: TfrDrawMode; function CalcHeight: Integer; virtual; abstract; function MinHeight: Integer; virtual; abstract; function RemainHeight: Integer; virtual; abstract; published property Stretched; end; { TfrMemoView } TfrMemoView = class(TfrStretcheable) private fAngle : Byte; fFont : TFont; function GetAlignment: TAlignment; function GetAutoSize: Boolean; function GetLayout: TTextLayout; function GetWordWrap: Boolean; procedure P1Click(Sender: TObject); procedure P2Click(Sender: TObject); procedure P3Click(Sender: TObject); procedure P4Click(Sender: TObject); procedure P5Click(Sender: TObject); procedure SetAlignment(const AValue: TAlignment); procedure SetAutoSize(const AValue: Boolean); procedure SetFont(Value: TFont); procedure SetLayout(const AValue: TTextLayout); procedure SetWordWrap(const AValue: Boolean); protected Streaming: Boolean; TextHeight: Integer; CurStrNo: Integer; Exporting: Boolean; procedure ExpandVariables; procedure AssignFont(aCanvas: TCanvas); procedure WrapMemo; procedure ShowMemo; function CalcWidth(aMemo: TStringList): Integer; function CalcHeight: Integer; override; function MinHeight: Integer; override; function RemainHeight: Integer; override; procedure GetBlob(b: TfrTField); override; procedure FontChange(sender: TObject); public Adjust: Integer; // bit format xxxLLRAA: LL=Layout, R=Rotated, AA=Alignment Highlight: TfrHighlightAttr; HighlightStr: String; LineSpacing, CharacterSpacing: Integer; constructor Create; override; destructor Destroy; override; procedure Assign(From: TfrView); override; procedure Draw(aCanvas: TCanvas); override; procedure Print(Stream: TStream); override; procedure ExportData; override; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SaveToStream(Stream: TStream); override; procedure SaveToXML(XML: TXMLConfig; Path: String); override; procedure DefinePopupMenu(Popup: TPopupMenu); override; procedure MonitorFontChanges; published property Font : TFont read fFont write SetFont; property Alignment : TAlignment read GetAlignment write SetAlignment; property Layout : TTextLayout read GetLayout write SetLayout; property Angle : Byte read fAngle write fAngle; property WordWrap : Boolean read GetWordWrap write SetWordWrap; property AutoSize : Boolean read GetAutoSize write SetAutoSize; property FillColor; property Memo; property Script; property Frames; property FrameColor; property FrameStyle; property FrameWidth; property Format; property FormatStr; end; { TfrBandView } TfrBandView = class(TfrView) private fDataSetStr : String; fBandType : TfrBandType; fCondition : String; procedure P1Click(Sender: TObject); procedure P2Click(Sender: TObject); procedure P3Click(Sender: TObject); procedure P4Click(Sender: TObject); procedure P5Click(Sender: TObject); procedure P6Click(Sender: TObject); public constructor Create; override; procedure Assign(From: TfrView); override; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SaveToStream(Stream: TStream); override; procedure SaveToXML(XML: TXMLConfig; Path: String); override; procedure Draw(aCanvas: TCanvas); override; procedure DefinePopupMenu(Popup: TPopupMenu); override; function GetClipRgn(rt: TfrRgnType): HRGN; override; function PointInView(aX,aY : Integer) : Boolean; override; published property DataSet: String read fDataSetStr write fDataSetStr; property GroupCondition: String read fCondition write fCondition; property BandType: TfrBandType read fBandType write fBandType; property Script; end; { TfrSubReportView } TfrSubReportView = class(TfrView) public SubPage: Integer; constructor Create; override; procedure Assign(From: TfrView); override; procedure Draw(aCanvas: TCanvas); override; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SaveToStream(Stream: TStream); override; procedure SaveToXML(XML: TXMLConfig; Path: String); override; procedure DefinePopupMenu(Popup: TPopupMenu); override; end; { TfrPictureView } TfrPictureView = class(TfrView) private fPicture: TPicture; procedure P1Click(Sender: TObject); procedure P2Click(Sender: TObject); function GetPictureType: byte; function PictureTypeToGraphic(b: Byte): TGraphic; procedure SetPicture(const AValue: TPicture); protected procedure GetBlob(b: TfrTField); override; public constructor Create; override; destructor Destroy; override; procedure Assign(From: TfrView); override; procedure Draw(aCanvas: TCanvas); override; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SaveToStream(Stream: TStream); override; procedure SaveToXML(XML: TXMLConfig; Path: String); override; procedure DefinePopupMenu(Popup: TPopupMenu); override; class function GetFilter: string; published property Picture : TPicture read fPicture write SetPicture; property Memo; property Script; property Frames; property FrameColor; property FrameStyle; property FrameWidth; property Stretched; end; TfrLineView = class(TfrView) public constructor Create; override; procedure Draw(aCanvas: TCanvas); override; procedure DefinePopupMenu(Popup: TPopupMenu); override; function GetClipRgn(rt: TfrRgnType): HRGN; override; published property FrameColor; property FrameStyle; property FrameWidth; end; TfrRect = Class(TPersistent) private fBottom: Integer; fLeft: Integer; fRight: Integer; fTop: Integer; function GetRect: TRect; procedure SetRect(const AValue: TRect); public property AsRect : TRect read GetRect write SetRect; published property Left : Integer read fLeft write fLeft; property Top : Integer read fTop write fTop; property Right: Integer read fRight write fRight; property Bottom : Integer read fBottom write fBottom; end; TfrBand = class(TfrObject) private Parent: TfrPage; View: TfrView; Flags: Word; Next, Prev: TfrBand; SubIndex, MaxY: Integer; EOFReached: Boolean; EOFArr: Array[0..31] of Boolean; Positions: Array[TfrDatasetPosition] of Integer; LastGroupValue: Variant; HeaderBand, FooterBand, LastBand: TfrBand; Values: TStringList; Count: Integer; DisableInit: Boolean; CalculatedHeight: Integer; procedure InitDataSet(Desc: String); procedure DoError; function CalcHeight: Integer; procedure StretchObjects(MaxHeight: Integer); procedure UnStretchObjects; procedure DrawObject(t: TfrView); procedure PrepareSubReports; procedure DoSubReports; function DrawObjects: Boolean; procedure DrawCrossCell(Parnt: TfrBand; CurX: Integer); procedure DrawCross; function CheckPageBreak(ay, ady: Integer; PBreak: Boolean): Boolean; function CheckNextColumn: boolean; procedure DrawPageBreak; function HasCross: Boolean; function DoCalcHeight: Integer; procedure DoDraw; function Draw: Boolean; procedure InitValues; procedure DoAggregate; public maxdy: Integer; Typ: TfrBandType; PrintIfSubsetEmpty, NewPageAfter, Stretched, PageBreak: Boolean; Objects: TList; DataSet: TfrDataSet; IsVirtualDS: Boolean; VCDataSet: TfrDataSet; IsVirtualVCDS: Boolean; GroupCondition: String; ForceNewPage, ForceNewColumn: Boolean; constructor Create(ATyp: TfrBandType; AParent: TfrPage); overload; destructor Destroy; override; end; TfrValue = class public Typ : TfrValueType; OtherKind : Integer; // for vtOther - typ, for vtDBField - format DataSet : String; // for vtDBField Field : String; // here is an expression for vtOther DSet : TfrTDataSet; end; { TfrValues } TfrValues = class(TPersistent) private FItems: TStringList; function GetValue(Index: Integer): TfrValue; public constructor Create; virtual; destructor Destroy; override; function AddValue: Integer; function FindVariable(const s: String): TfrValue; procedure ReadBinaryData(Stream: TStream); procedure ReadBinaryDataFromXML(XML: TXMLConfig; Path: String); procedure WriteBinaryData(Stream: TStream); procedure WriteBinaryDataToXML(XML: TXMLConfig; Path: String); procedure Clear; property Items: TStringList read FItems write FItems; property Objects[Index: Integer]: TfrValue read GetValue; end; { TfrPage } TfrPage = class(TfrObject) private Bands : Array[TfrBandType] of TfrBand; fColCount : Integer; fColGap : Integer; fColWidth : Integer; fMargins : TfrRect; fOrientation : TPrinterOrientation; fPrintToPrevPage : Boolean; fUseMargins : Boolean; Skip : Boolean; InitFlag : Boolean; CurColumn : Integer; LastStaticColumnY : Integer; XAdjust : Integer; List : TList; Mode : TfrPageMode; PlayFrom : Integer; LastBand : TfrBand; ColPos : Integer; CurPos : Integer; PageType : TfrPageType; fLayoutOrder : TLayoutOrder; procedure DoAggregate(a: Array of TfrBandType); procedure AddRecord(b: TfrBand; rt: TfrBandRecType); procedure ClearRecList; function PlayRecList: Boolean; procedure DrawPageFooters; function BandExists(b: TfrBand): Boolean; procedure LoadFromStream(Stream: TStream); procedure SaveToStream(Stream: TStream); procedure ShowBand(b: TfrBand); protected procedure InitReport; virtual; procedure DoneReport; virtual; procedure TossObjects; virtual; procedure PrepareObjects; virtual; procedure FormPage; virtual; procedure AfterPrint; virtual; public pgSize : Integer; PrnInfo : TfrPrnInfo; Objects : TList; RTObjects : TList; CurY : Integer; CurBottomY: Integer; constructor Create; override; destructor Destroy; override; constructor Create(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation); constructor CreatePage; virtual; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SavetoXML(XML: TXMLConfig; Path: String); override; function TopMargin: Integer; function BottomMargin: Integer; function LeftMargin: Integer; function RightMargin: Integer; procedure Clear; procedure Delete(Index: Integer); function FindObjectByID(ID: Integer): Integer; function FindObject(aName: String): TfrObject; function FindRTObject(aName: String): TfrObject; procedure ChangePaper(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation); procedure ShowBandByName(s: String); procedure ShowBandByType(bt: TfrBandType); procedure NewPage; procedure NewColumn(Band: TfrBand); procedure NextColumn(Band: TFrBand); function RowsLayout: boolean; property ColCount : Integer read fColCount write fColCount; property ColWidth : Integer read fColWidth write fColWidth; property ColGap : Integer read fColGap write fColGap; property UseMargins : Boolean read fUseMargins write fUseMargins; property Margins : TfrRect read fMargins write fMargins; property PrintToPrevPage : Boolean read fPrintToPrevPage write fPrintToPrevPage; property Orientation : TPrinterOrientation read fOrientation write fOrientation; property LayoutOrder: TLayoutOrder read fLayoutOrder write fLayoutOrder; published property Script; property Height; property Width; end; TFrPageClass = Class of TfrPage; { TfrPageReport } TfrPageReport = Class(TfrPage) public procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SavetoXML(XML: TXMLConfig; Path: String); override; constructor CreatePage; override; published property ColCount; property ColWidth; property ColGap; property UseMargins; property Margins; property PrintToPrevPage; property Orientation; property LayoutOrder; end; { TfrPageDialog } TfrPageDialog = Class(TfrPage) private fHasVisibleControls : Boolean; fForm : TfrDialogForm; fCaption : String; protected procedure PrepareObjects; override; procedure InitReport; override; public constructor Create; override; procedure LoadFromXML(XML: TXMLConfig; Path: String); override; procedure SavetoXML(XML: TXMLConfig; Path: String); override; published property Caption : string read fCaption write fCaption; end; { TfrPages } TfrPages = class(TObject) private FPages: TList; Parent: TfrReport; function GetCount: Integer; function GetPages(Index: Integer): TfrPage; public constructor Create(AParent: TfrReport); destructor Destroy; override; procedure Clear; procedure Add(aClassName : string='TfrPageReport'); procedure Delete(Index: Integer); procedure LoadFromStream(Stream: TStream); procedure LoadFromXML(XML: TXMLConfig; Path: String); procedure SaveToStream(Stream: TStream); procedure SavetoXML(XML: TXMLConfig; Path: String); property Pages[Index: Integer]: TfrPage read GetPages; default; property Count: Integer read GetCount; end; { TfrEMFPages } TfrEMFPages = class(TObject) private FPages: TList; Parent: TfrReport; function GetCount: Integer; function GetPages(Index: Integer): PfrPageInfo; procedure ExportData(Index: Integer); procedure PageToObjects(Index: Integer); procedure ObjectsToPage(Index: Integer); public constructor Create(AParent: TfrReport); destructor Destroy; override; procedure Clear; procedure Draw(Index: Integer; Canvas: TCanvas; DrawRect: TRect); procedure Add(APage: TfrPage); procedure Insert(Index: Integer; APage: TfrPage); procedure Delete(Index: Integer); procedure LoadFromStream(AStream: TStream); procedure LoadFromXML(XML: TXMLConfig; Path: String); procedure SaveToStream(AStream: TStream); procedure SaveToXML(XML: TXMLConfig; Path: String); property Pages[Index: Integer]: PfrPageInfo read GetPages; default; property Count: Integer read GetCount; end; TfrDataType = (dtDataSet,dtDataSource); { TfrReport } TfrReport = class(TComponent) private FDataType: TfrDataType; FPages: TfrPages; FEMFPages: TfrEMFPages; FReportAutor: string; FReportCreateDate: TDateTime; FReportLastChange: TDateTime; FReportVersionBuild: string; FReportVersionMajor: string; FReportVersionMinor: string; FReportVersionRelease: string; FVars: TStrings; FVal: TfrValues; FDataset: TfrDataset; FGrayedButtons: Boolean; FReportType: TfrReportType; FShowProgress: Boolean; FModalPreview: Boolean; FModifyPrepared: Boolean; FStoreInDFM: Boolean; FPreview: TfrPreview; FPreviewButtons: TfrPreviewButtons; FInitialZoom: TfrPreviewZoom; FOnBeginDoc: TBeginDocEvent; FOnEndDoc: TEndDocEvent; FOnBeginPage: TBeginPageEvent; FOnEndPage: TEndPageEvent; FOnBeginBand: TBeginBandEvent; FOnEndBand: TEndBandEvent; FOnGetValue: TDetailEvent; FOnEnterRect: TEnterRectEvent; FOnProgress: TfrProgressEvent; FOnFunction: TFunctionEvent; FOnBeginColumn: TBeginColumnEvent; FOnPrintColumn: TPrintColumnEvent; FOnManualBuild: TManualBuildEvent; FCurrentFilter: TfrExportFilter; FPageNumbers : String; FCopies : Integer; FCurPage : TfrPage; // FDefaultTitle : String; FTitle : String; FSubject : string; FKeyWords : string; FComments : TStringList; function FormatValue(V: Variant; AFormat: Integer; const AFormatStr: String): String; // function GetLRTitle: String; procedure OnGetParsFunction(const aName: String; p1, p2, p3: Variant; var val: Variant); procedure PrepareDataSets; procedure BuildBeforeModal(Sender: TObject); procedure ExportBeforeModal(Sender: TObject); procedure PrintBeforeModal(Sender: TObject); function DoPrepareReport: Boolean; procedure DoBuildReport; virtual; procedure DoPrintReport(PageNumbers: String; Copies: Integer); procedure SetComments(const AValue: TStringList); procedure SetDataset(const AValue: TfrDataset); procedure SetPrinterTo(PrnName: String); procedure SetReportAutor(const AValue: string); procedure SetReportCreateDate(const AValue: TDateTime); procedure SetReportLastChange(const AValue: TDateTime); procedure SetReportVersionBuild(const AValue: string); procedure SetReportVersionMajor(const AValue: string); procedure SetReportVersionMinor(const AValue: string); procedure SetReportVersionRelease(const AValue: string); procedure SetVars(Value: TStrings); procedure ClearAttribs; protected procedure DefineProperties(Filer: TFiler); override; procedure ReadBinaryData(Stream: TStream); procedure WriteBinaryData(Stream: TStream); procedure Notification(AComponent: TComponent; Operation: TOperation); override; public CanRebuild : Boolean; // true, if report can be rebuilded Terminated : Boolean; PrintToDefault, DoublePass: WordBool; FinalPass : Boolean; FileName : String; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; // service methods function FindVariable(Variable: String): Integer; procedure GetVariableValue(const s: String; var aValue: Variant); procedure GetVarList(CatNo: Integer; List: TStrings); procedure GetCategoryList(List: TStrings); function FindObject(aName: String): TfrObject; // internal events used through report building procedure InternalOnEnterRect(Memo: TStringList; View: TfrView); procedure InternalOnExportData(View: TfrView); procedure InternalOnExportText(x, y: Integer; const text: String; View: TfrView); procedure InternalOnGetValue(ParName: String; var ParValue: String); procedure InternalOnProgress(Percent: Integer); procedure InternalOnBeginColumn(Band: TfrBand); procedure InternalOnPrintColumn(ColNo: Integer; var ColWidth: Integer); procedure FillQueryParams; // load/save methods procedure LoadFromStream(Stream: TStream); procedure LoadFromXML(XML: TXMLConfig; Path: String); procedure SaveToStream(Stream: TStream); procedure LoadFromFile(FName: String); procedure LoadFromXMLFile(Fname: String); procedure SaveToFile(FName: String); procedure SavetoXML(XML: TXMLConfig; Path: String); procedure SaveToXMLFile(FName: String); procedure LoadFromDB(Table: TDataSet; DocN: Integer); procedure SaveToDB(Table: TDataSet; DocN: Integer); procedure LoadTemplate(fname: String; comm: TStrings; Bmp: TBitmap; Load: Boolean); procedure SaveTemplate(fname: String; comm: TStrings; Bmp: TBitmap); procedure LoadPreparedReport(FName: String); procedure SavePreparedReport(FName: String); // report manipulation methods procedure DesignReport; function PrepareReport: Boolean; procedure ExportTo(Filter: TClass; aFileName: String); procedure ShowReport; procedure ShowPreparedReport; procedure PrintPreparedReport(PageNumbers: String; Copies: Integer); function ChangePrinter(OldIndex, NewIndex: Integer): Boolean; procedure EditPreparedReport(PageIndex: Integer); // property Subject : string read FSubject write FSubject; property KeyWords : string read FKeyWords write FKeyWords; property Comments : TStringList read FComments write SetComments; property ReportAutor : string read FReportAutor write SetReportAutor; property ReportVersionMajor : string read FReportVersionMajor write SetReportVersionMajor; property ReportVersionMinor : string read FReportVersionMinor write SetReportVersionMinor; property ReportVersionRelease : string read FReportVersionRelease write SetReportVersionRelease; property ReportVersionBuild : string read FReportVersionBuild write SetReportVersionBuild; property ReportCreateDate : TDateTime read FReportCreateDate write SetReportCreateDate; property ReportLastChange : TDateTime read FReportLastChange write SetReportLastChange; // property Pages: TfrPages read FPages; property EMFPages: TfrEMFPages read FEMFPages write FEMFPages; property Variables: TStrings read FVars write SetVars; property Values: TfrValues read FVal write FVal; published property Dataset: TfrDataset read FDataset write SetDataset; property GrayedButtons: Boolean read FGrayedButtons write FGrayedButtons default False; property InitialZoom: TfrPreviewZoom read FInitialZoom write FInitialZoom; property ModalPreview: Boolean read FModalPreview write FModalPreview default True; property ModifyPrepared: Boolean read FModifyPrepared write FModifyPrepared default True; property Preview: TfrPreview read FPreview write FPreview; property PreviewButtons: TfrPreviewButtons read FPreviewButtons write FPreviewButtons; property ReportType: TfrReportType read FReportType write FReportType default rtSimple; property ShowProgress: Boolean read FShowProgress write FShowProgress default True; property StoreInDFM: Boolean read FStoreInDFM write FStoreInDFM default False; property DataType : TfrDataType read FDataType write FDataType; property Title: String read FTitle write FTitle; property OnBeginDoc: TBeginDocEvent read FOnBeginDoc write FOnBeginDoc; property OnEndDoc: TEndDocEvent read FOnEndDoc write FOnEndDoc; property OnBeginPage: TBeginPageEvent read FOnBeginPage write FOnBeginPage; property OnEndPage: TEndPageEvent read FOnEndPage write FOnEndPage; property OnBeginBand: TBeginBandEvent read FOnBeginBand write FOnBeginBand; property OnEndBand: TEndBandEvent read FOnEndBand write FOnEndBand; property OnGetValue: TDetailEvent read FOnGetValue write FOnGetValue; property OnEnterRect: TEnterRectEvent read FOnEnterRect write FOnEnterRect; property OnUserFunction: TFunctionEvent read FOnFunction write FOnFunction; property OnProgress: TfrProgressEvent read FOnProgress write FOnProgress; property OnBeginColumn: TBeginColumnEvent read FOnBeginColumn write FOnBeginColumn; property OnPrintColumn: TPrintColumnEvent read FOnPrintColumn write FOnPrintColumn; property OnManualBuild: TManualBuildEvent read FOnManualBuild write FOnManualBuild; end; TfrCompositeReport = class(TfrReport) private procedure DoBuildReport; override; public Reports: TList; constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; TfrReportDesigner = class(TForm) public Page: TfrPage; Modified: Boolean; procedure RegisterObject(ButtonBmp: TBitmap; const ButtonHint: String; ButtonTag: Integer); virtual; abstract; procedure RegisterTool(MenuCaption: String; ButtonBmp: TBitmap; NotifyOnClick: TNotifyEvent); virtual; abstract; procedure BeforeChange; virtual; abstract; procedure AfterChange; virtual; abstract; procedure RedrawPage; virtual; abstract; // function PointsToUnits(x: Integer): Double; virtual; abstract; function UnitsToPoints(x: Double): Integer; virtual; abstract; procedure MoveObjects(dx, dy: Integer; aResize: Boolean); virtual; abstract; end; TfrDataManager = class(TObject) public procedure Clear; virtual; abstract; procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure LoadFromXML(XML:TXMLConfig; Path: String); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; procedure SaveToXML(XML:TXMLConfig; Path: String); virtual; abstract; procedure BeforePreparing; virtual; abstract; procedure AfterPreparing; virtual; abstract; procedure PrepareDataSet(ds: TfrTDataSet); virtual; abstract; function ShowParamsDialog: Boolean; virtual; abstract; procedure AfterParamsDialog; virtual; abstract; end; TfrObjEditorForm = class(TForm) public procedure ShowEditor(t: TfrView); virtual; end; TfrExportFilter = class(TObject) protected Stream: TStream; Lines: TList; procedure ClearLines; public constructor Create(AStream: TStream); virtual; destructor Destroy; override; procedure OnBeginDoc; virtual; procedure OnEndDoc; virtual; procedure OnBeginPage; virtual; procedure OnEndPage; virtual; procedure OnData(x, y: Integer; View: TfrView); virtual; procedure OnText(x, y: Integer; const text: String; View: TfrView); virtual; end; TfrFunctionDescription = class(TObject) funName:string; funGroup:string; funDescription:string; end; { TfrFunctionLibrary } TfrFunctionLibrary = class(TObject) public List: TStringList; constructor Create; virtual; destructor Destroy; override; function OnFunction(const FName: String; p1, p2, p3: Variant; var val: Variant): Boolean; procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: Variant); virtual; abstract; procedure AddFunctionDesc(funName, funGroup, funDescription:string); end; TfrCompressor = class(TObject) public Enabled: Boolean; procedure Compress(StreamIn, StreamOut: TStream); virtual; procedure DeCompress(StreamIn, StreamOut: TStream); virtual; end; function frCreateObject(Typ: Byte; const ClassName: String): TfrView; procedure frRegisterObject(ClassRef: TFRViewClass; ButtonBmp: TBitmap; const ButtonHint: String; EditorForm: TfrObjEditorForm); procedure frRegisterExportFilter(ClassRef: TClass; const FilterDesc, FilterExt: String); procedure frRegisterFunctionLibrary(ClassRef: TClass); procedure frRegisterTool(MenuCaption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent); function GetDefaultDataSet: TfrTDataSet; procedure SetBit(var w: Word; e: Boolean; m: Integer); const frCurrentVersion = 24; // this is current version (2.4) frSpecCount = 9; frSpecFuncs: Array[0..frSpecCount - 1] of String = ('PAGE#', '', 'DATE', 'TIME', 'LINE#', 'LINETHROUGH#', 'COLUMN#', 'CURRENT#', 'TOTALPAGES'); frColors: Array[0..15] of TColor = (clWhite, clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray, clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua); frAllFrames=[frbLeft, frbTop, frbRight, frbBottom]; type PfrTextRec = ^TfrTextRec; TfrTextRec = record Next: PfrTextRec; X: Integer; Text: String[255]; FontName: String[32]; FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer; end; TfrAddInObjectInfo = record ClassRef: TfrViewClass; EditorForm: TfrObjEditorForm; ButtonBmp: TBitmap; ButtonHint: String; end; TfrExportFilterInfo = record ClassRef: TClass; FilterDesc, FilterExt: String; end; TfrFunctionInfo = record FunctionLibrary: TfrFunctionLibrary; end; TfrToolsInfo = record Caption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent; end; var frDesigner: TfrReportDesigner; // designer reference frDataManager: TfrDataManager; // data manager reference frParser: TfrParser; // parser reference frInterpretator: TfrInterpretator; // interpretator reference frVariables: TfrVariables; // report variables reference frCompressor: TfrCompressor; // compressor reference CurReport: TfrReport; // currently proceeded report MasterReport: TfrReport; // reference to main composite report CurView: TfrView; // currently proceeded view CurBand: TfrBand; // currently proceeded band CurPage: TfrPage; // currently proceeded page DocMode: (dmDesigning, dmPrinting); // current mode DisableDrawing: Boolean; frAddIns: Array[0..31] of TfrAddInObjectInfo; // add-in objects frAddInsCount: Integer; frFilters: Array[0..31] of TfrExportFilterInfo; // export filters frFiltersCount: Integer; frFunctions: Array[0..31] of TfrFunctionInfo; // function libraries frFunctionsCount: Integer; frTools: Array[0..31] of TfrToolsInfo; // tools frToolsCount: Integer; PageNo: Integer; // current page number in Building mode frCharset: 0..255; frBandNames: Array[btReportTitle..btNone] of String; frSpecArr: Array[0..frSpecCount - 1] of String; frDateFormats, frTimeFormats: Array[0..3] of String; frVersion: Byte; // version of currently loaded report SMemo: TStringList; // temporary memo used during TfrView drawing ShowBandTitles: Boolean = True; ProcedureInitDesigner : Procedure = nil; (* FRE_COMPATIBLEREAD variable added for migrating from older versions of FreeReport and will be removed in next releases as soon as possible. *) {$IFDEF FREEREP2217READ} FRE_COMPATIBLE_READ: Boolean = False; {$ENDIF} implementation uses LR_Fmted, LR_Prntr, LR_Progr, LR_Utils, DateUtils {$IFDEF JPEG}, JPEG {$ENDIF}; type TfrStdFunctionLibrary = class(TfrFunctionLibrary) public constructor Create; override; procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: Variant); override; end; TInterpretator = class(TfrInterpretator) public procedure GetValue(const Name: String; var Value: Variant); override; procedure SetValue(const Name: String; Value: Variant); override; procedure DoFunction(const name: String; p1, p2, p3: Variant; var val: Variant); override; end; var VHeight: Integer; // used for height calculation of TfrMemoView SBmp: TBitmap; // small bitmap used by TfrBandView drawing TempBmp: TBitmap; // temporary bitmap used by TfrMemoView CurDate, CurTime: TDateTime; // date/time of report starting CurValue: Variant; // used for highlighting AggrBand: TfrBand; // used for aggregate functions CurVariable: String; IsColumns: Boolean; SavedAllPages: Integer; // number of pages in entire report ErrorFlag: Boolean; // error occured through TfrView drawing ErrorStr: String; // error description SubValue: String; // used in GetValue event handler ObjID: Integer = 0; BoolStr: Array[0..3] of String; HookList: TList; FRInitialized: Boolean = False; // variables used through report building PrevY, PrevBottomY, ColumnXAdjust: Integer; Append, WasPF: Boolean; CompositeMode: Boolean; {$IFDEF DebugLR} var nspc: integer = 0; sspc: string = ''; procedure IncSpc(aInc:Integer); begin nspc := nspc + aInc; if nspc<0 then nspc := 0; //WriteLn('[',nspc,']'); SetLength(sspc, nspc*2); if aInc>0 then fillchar(sspc[1], nspc*2, ' '); end; function typ2str(typ: TfrBandType): string; begin case typ of btReportTitle: result := 'btReportTitle'; btReportSummary: result := 'btReportSummary'; btPageHeader: result := 'btPageHeader'; btPageFooter: result := 'btPageFooter'; btMasterHeader: result := 'btMasterHeader'; btMasterData: result := 'btMasterData'; btMasterFooter: result := 'btMasterFooter'; btDetailHeader: result := 'btDetailHeader'; btDetailData: result := 'btDetailData'; btDetailFooter: result := 'btDetailFooter'; btSubDetailHeader: result := 'btSubDetailHeader'; btSubDetailData: result := 'btSubDetailData'; btSubDetailFooter: result := 'btSubDetailFooter'; btOverlay: result := 'btOverlay'; btColumnHeader: result := 'btColumnHeader'; btColumnFooter: result := 'btColumnFooter'; btGroupHeader: result := 'btGroupHeader'; btGroupFooter: result := 'btGroupFooter'; btCrossHeader: result := 'btCrossHeader'; btCrossData: result := 'btCrossData'; btCrossFooter: result := 'btCrossFooter'; btNone: result:='btNone'; end; end; {$ENDIF} {----------------------------------------------------------------------------} function frCreateObject(Typ: Byte; const ClassName: String): TfrView; var i: Integer; begin Result := nil; case Typ of gtMemo: Result := TfrMemoView.Create; gtPicture: Result := TfrPictureView.Create; gtBand: Result := TfrBandView.Create; gtSubReport: Result := TfrSubReportView.Create; gtLine: Result := TfrLineView.Create; gtAddIn: begin for i := 0 to frAddInsCount - 1 do begin {$IFDEF DebugLR} DebugLn(format('frCreateObject classname compare %s=%s',[frAddIns[i].ClassRef.ClassName,ClassName])); {$ENDIF} if frAddIns[i].ClassRef.ClassName = ClassName then begin Result := frAddIns[i].ClassRef.Create; // Result.Create; Result.Typ := gtAddIn; break; end; end; if Result = nil then raise EClassNotFound.Create(Format(sClassObjectNotFound,[ClassName])); end; end; if Result <> nil then begin {$IFDEF DebugLR} DebugLn(format('frCreateObject instance classname=%s',[ClassName])); {$ENDIF} Result.ID := ObjID; Inc(ObjID); end; end; procedure frRegisterObject(ClassRef: TfrViewClass; ButtonBmp: TBitmap; const ButtonHint: String; EditorForm: TfrObjEditorForm); begin frAddIns[frAddInsCount].ClassRef := ClassRef; frAddIns[frAddInsCount].EditorForm := EditorForm; frAddIns[frAddInsCount].ButtonBmp := ButtonBmp; frAddIns[frAddInsCount].ButtonHint := ButtonHint; if frDesigner <> nil then frDesigner.RegisterObject(ButtonBmp, ButtonHint, Integer(gtAddIn) + frAddInsCount); Inc(frAddInsCount); end; procedure frRegisterExportFilter(ClassRef: TClass; const FilterDesc, FilterExt: String); begin frFilters[frFiltersCount].ClassRef := ClassRef; frFilters[frFiltersCount].FilterDesc := FilterDesc; frFilters[frFiltersCount].FilterExt := FilterExt; Inc(frFiltersCount); end; procedure frRegisterFunctionLibrary(ClassRef: TClass); begin frFunctions[frFunctionsCount].FunctionLibrary := TfrFunctionLibrary(ClassRef.NewInstance); frFunctions[frFunctionsCount].FunctionLibrary.Create; Inc(frFunctionsCount); end; procedure frRegisterTool(MenuCaption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent); begin frTools[frToolsCount].Caption := MenuCaption; frTools[frToolsCount].ButtonBmp := ButtonBmp; frTools[frToolsCount].OnClick := OnClick; if frDesigner <> nil then frDesigner.RegisterTool(MenuCaption, ButtonBmp, OnClick); Inc(frToolsCount); end; function Create90Font(Font: TFont): HFont; var F: TLogFont; begin GetObject(Font.Handle, SizeOf(TLogFont), @F); F.lfEscapement := 900; F.lfOrientation := 900; Result := CreateFontIndirect(F); end; function GetDefaultDataSet: TfrTDataSet; var Res: TfrDataset; begin Result := nil; Res := nil; if CurBand <> nil then case CurBand.Typ of btMasterData, btReportSummary, btMasterFooter, btGroupHeader, btGroupFooter: Res := CurPage.Bands[btMasterData].DataSet; btDetailData, btDetailFooter: Res := CurPage.Bands[btDetailData].DataSet; btSubDetailData, btSubDetailFooter: Res := CurPage.Bands[btSubDetailData].DataSet; btCrossData, btCrossFooter: Res := CurPage.Bands[btCrossData].DataSet; end; if (Res <> nil) and (Res is TfrDBDataset) then Result := TfrDBDataSet(Res).GetDataSet; end; function ReadString(Stream: TStream): String; begin if frVersion >= 23 then {$IFDEF FREEREP2217READ} Result := frReadString(Stream) // load in current format else if (frVersion = 22) and FRE_COMPATIBLE_READ then Result := frReadString2217(Stream) // load in bad format else {$ELSE} Result := frReadString(Stream) else {$ENDIF} Result := frReadString22(Stream); end; procedure ReadMemo(Stream: TStream; Memo: TStrings); begin if frVersion >= 23 then {$IFDEF FREEREP2217READ} frReadMemo(Stream, Memo) // load in current format else if (frVersion = 22) and FRE_COMPATIBLE_READ then Memo.Text := frReadMemoText2217(Stream) // load in bad format else {$ELSE} frReadMemo(Stream, Memo) else {$ENDIF} frReadMemo22(Stream, Memo); end; procedure CreateDS(Desc: String; var DataSet: TfrDataSet; var IsVirtualDS: Boolean); begin if (Desc <> '') and (Desc[1] in ['1'..'9']) then begin DataSet := TfrUserDataSet.Create(nil); DataSet.RangeEnd := reCount; DataSet.RangeEndCount := StrToInt(Desc); IsVirtualDS := True; end else DataSet := frFindComponent(CurReport.Owner, Desc) as TfrDataSet; if DataSet <> nil then DataSet.Init; end; // locale neutral StrToFloatDef function StringToFloatDef(S:String; const ADefault:Double): Double; var Code: Integer; begin if S='' then Code:=1 else Val(S, Result, Code); if Code>0 then Result:=ADefault; end; procedure SetBit(var w: Word; e: Boolean; m: Integer); begin if e then w:=w or m else w:=w and not m; end; {----------------------------------------------------------------------------} constructor TfrView.Create; begin inherited Create; Parent := nil; Memo1 := TStringList.Create; fFrameWidth := 1; fFrameColor := clBlack; fFillColor := clNone; fFormat := 2*256 + Ord(DecimalSeparator); BaseName := 'View'; Visible := True; StreamMode := smDesigning; ScaleX := 1; ScaleY := 1; OffsX := 0; OffsY := 0; Flags := flStretched; fStretched:=True; fFrames:=[]; //No frame end; destructor TfrView.Destroy; begin Memo1.Free; inherited Destroy; end; procedure TfrView.Assign(From: TfrView); begin Inherited Assign(From); Name := From.Name; Typ := From.Typ; Selected := From.Selected; Flags := From.Flags; fFrameWidth := From.FrameWidth; fFrameColor := From.FrameColor; fFrameStyle := From.FrameStyle; fFillColor := From.FillColor; fFormat := From.Format; fFormatStr := From.FormatStr; fVisible := From.Visible; fFrames:=From.Frames; end; procedure TfrView.CalcGaps; var bx, by, bx1, by1, wx1, wx2, wy1, wy2: Integer; begin SaveX := x; SaveY := y; SaveDX := dx; SaveDY := dy; SaveFW := FrameWidth; if DocMode = dmDesigning then begin ScaleX := 1; ScaleY := 1; OffsX := 0; OffsY := 0; end; x := Round(x*ScaleX)+OffsX; y := Round(y* ScaleY)+OffsY; dx:= Round(dx*ScaleX); dy:= Round(dy*ScaleY); wx1 := Round((FrameWidth * ScaleX - 1) / 2); wx2 := Round(FrameWidth * ScaleX / 2); wy1 := Round((FrameWidth * ScaleY - 1) / 2); wy2 := Round(FrameWidth * ScaleY / 2); {$IFDEF DebugLR} DebugLn('CalcGaps: dx=',dbgs(dx),' ScaleX=',dbgs(ScaleX)); {$ENDIF} fFrameWidth := FrameWidth * ScaleX; gapx := wx2 + 2; gapy := wy2 div 2 + 1; bx := x; by := y; bx1 := Round((SaveX + SaveDX) * ScaleX + OffsX); by1 := Round((SaveY + SaveDY) * ScaleY + OffsY); if frbTop in Frames then Dec(bx1, wx2); if frbLeft in Frames then Dec(by1, wy2); if frbBottom in Frames then Inc(bx, wx1); if frbRight in Frames then Inc(by, wy1); DRect := Rect(bx, by, bx1 + 1, by1 + 1); end; procedure TfrView.RestoreCoord; begin x := SaveX; y := SaveY; dx := SaveDX; dy := SaveDY; fFrameWidth := SaveFW; end; procedure TfrView.ShowBackground; var fp: TColor; begin if DisableDrawing then Exit; if (DocMode = dmPrinting) and (FillColor = clNone) then Exit; fp := FillColor; if (DocMode = dmDesigning) and (fp = clNone) then fp := clWhite; Canvas.Brush.Style := bsSolid; Canvas.Brush.Color := fp; if DocMode = dmDesigning then Canvas.FillRect(DRect) else Canvas.FillRect(Rect(x, y, //use calculating coords instead of dx, dy - for best view Round((SaveX + SaveDX) * ScaleX + OffsX), Round((SaveY + SaveDY) * ScaleY + OffsY))); end; procedure TfrView.ShowFrame; var x1, y1: Integer; procedure IntLine(X11, Y11, DX11, DY11: Integer); begin Canvas.MoveTo(X11, Y11); Canvas.LineTo(X11+DX11, Y11+Dy11); end; procedure Line1(x, y, x1, y1: Integer); var i, w: Integer; begin {$IFDEF DebugLR} DebugLn('Line1(',InttoStr(x),',',IntToStr(y),',',IntToStr(x1),',',IntToStr(y1),')'); {$ENDIF} if Canvas.Pen.Style = psSolid then begin if FrameStyle<>frsDouble then begin Canvas.MoveTo(x, y); Canvas.LineTo(x1, y1); end else begin if x = x1 then begin Canvas.MoveTo(x - Round(FrameWidth), y); Canvas.LineTo(x1 - Round(FrameWidth), y1); Canvas.Pen.Color := FillColor; Canvas.MoveTo(x, y); Canvas.LineTo(x1, y1); Canvas.Pen.Color := FrameColor; Canvas.MoveTo(x + Round(FrameWidth), y); Canvas.LineTo(x1 + Round(FrameWidth), y1); end else begin Canvas.MoveTo(x, y - Round(FrameWidth)); Canvas.LineTo(x1, y1 - Round(FrameWidth)); Canvas.Pen.Color := FillColor; Canvas.MoveTo(x, y); Canvas.LineTo(x1, y1); Canvas.Pen.Color := FrameColor; Canvas.MoveTo(x, y + Round(FrameWidth)); Canvas.LineTo(x1, y1 + Round(FrameWidth)); end; end end else begin Canvas.Brush.Color:=FillColor; w := Canvas.Pen.Width; Canvas.Pen.Width := 1; if x = x1 then begin for i := 0 to w - 1 do begin Canvas.MoveTo(x - w div 2 + i, y); Canvas.LineTo(x - w div 2 + i, y1); end end else begin for i := 0 to w - 1 do begin Canvas.MoveTo(x, y - w div 2 + i); Canvas.LineTo(x1, y - w div 2 + i); end; end; Canvas.Pen.Width := w; end; end; begin if DisableDrawing then Exit; if (DocMode = dmPrinting) and (Frames=[]) then Exit; with Canvas do begin Brush.Style:= bsClear; Pen.Style:=psSolid; if (dx>0) and (dy>0) and (DocMode = dmDesigning) then begin Pen.Color := clBlack; Pen.Width := 1; IntLine(x,y+3,0,-3); IntLine(x,y, 4, 0); IntLine(x,y+dy-3, 0, 3); IntLine(x,y+dy, 4, 0); IntLine(x+dx-3,y,3,0); IntLine(x+dx,y,0,4); IntLine(x+dx-3,y+dy,3,0); IntLine(x+dx,y+dy,0,-4); end; Pen.Color := FrameColor; Pen.Width := Round(FrameWidth); if FrameStyle<>frsDouble then Pen.Style := TPenStyle(FrameStyle); // use calculating coords instead of dx, dy - for best view x1 := Round((SaveX + SaveDX) * ScaleX + OffsX); y1 := Round((SaveY + SaveDY) * ScaleY + OffsY); { // todo: Frame is not implemented in Win32 if ((frbTop in Frames) and (frbLeft in Frames) and (frbBottom in Frames) and (frbRight in Frames)) and (FrameStyle=frsSolid) then Frame(x,y, x1 + 1, y1 + 1) else } begin if (frbRight in Frames) then Line1(x1, y, x1, y1); if (frbLeft in Frames) then Line1(x, y, x, y1); if (frbBottom in Frames) then Line1(x, y1, x1, y1); if (frbTop in Frames) then Line1(x, y, x1, y); end; Brush.Style := bsSolid; end; end; procedure TfrView.BeginDraw(ACanvas: TCanvas); begin fCanvas := ACanvas; CurView := Self; end; procedure TfrView.Print(Stream: TStream); begin {$IFDEF DebugLR} DebugLn('%s%s.TfrView.Print()',[sspc,name]); {$ENDIF} BeginDraw(Canvas); Memo1.Assign(Memo); CurReport.InternalOnEnterRect(Memo1, Self); frInterpretator.DoScript(Script); if not Visible then Exit; Stream.Write(Typ, 1); if Typ = gtAddIn then frWriteString(Stream, ClassName); SaveToStream(Stream); {$IFDEF DebugLR} DebugLn('%s%s.TfrView.Print() end',[sspc,name]); {$ENDIF} end; procedure TfrView.ExportData; begin CurReport.InternalOnExportData(Self); end; procedure TfrView.LoadFromStream(Stream: TStream); var wb : Word; S : Single; begin {$IFDEF DebugLR} DebugLn('%s%s.TfrView.LoadFromStream begin StreamMode=%d ClassName=%s', [sspc,name,Ord(StreamMode),ClassName]); {$ENDIF} with Stream do begin if StreamMode = smDesigning then begin if frVersion >= 23 then Name := ReadString(Stream) else CreateUniqueName; end; //Read(x, 18); // this is equal to, but much faster: Read(x, 4); Read(y, 4); Read(dx, 4); Read(dy, 4); Read(Flags, 2); Read(S, SizeOf(S)); fFrameWidth := S; Read(fFrameColor, SizeOf(fFrameColor)); Read(fFrames,SizeOf(fFrames)); Read(fFrameStyle, SizeOf(fFrameStyle)); Read(fFillColor, 4); if StreamMode = smDesigning then begin Read(fFormat, 4); fFormatStr := ReadString(Stream); end; ReadMemo(Stream, Memo); if (frVersion >= 23) and (StreamMode = smDesigning) then begin ReadMemo(Stream, Script); Read(wb,2); Visible:=(Wb<>0); end; end; {$IFDEF DebugLR} DebugLn('%s%s.TfrView.LoadFromStream end',[sspc,name]); {$ENDIF} end; procedure TfrView.LoadFromXML(XML: TXMLConfig; Path: String); var S:string; begin inherited LoadFromXML(XML,Path); StreamMode := TfrStreamMode(XML.GetValue(Path+'StreamMode/Value', 0)); // TODO Check default if StreamMode = smDesigning then begin if frVersion >= 23 then Name := XML.GetValue(Path+'Name/Value', 'checkthis!') // TODO Check default else CreateUniqueName; end; x := XML.GetValue(Path + 'Size/Left/Value', 0); y := XML.GetValue(Path + 'Size/Top/Value', 0); dx := XML.GetValue(Path + 'Size/Width/Value', 100); dy := XML.GetValue(Path + 'Size/Height/Value', 100); Flags := Word(XML.GetValue(Path + 'Flags/Value', 0)); // TODO Check default FFrameWidth := StringToFloatDef(XML.GetValue(Path+'Frames/FrameWidth/Value', ''), 1.0); FFramecolor := StringToColor(XML.GetValue(Path+'Frames/FrameColor/Value', 'clBlack')); // TODO Check default S:=XML.GetValue(Path+'Frames/FrameBorders/Value',''); if S<>'' then RestoreProperty('Frames',S); S:=XML.GetValue(Path+'Frames/FrameStyle/Value',''); if S<>'' then RestoreProperty('FrameStyle',S); FFillColor := StringToColor(XML.GetValue(Path+'FillColor/Value', 'clWindow')); // TODO Check default if StreamMode = smDesigning then begin fFormat := XML.GetValue(Path+'Data/Format/Value', Format); // TODO Check default fFormatStr := XML.GetValue(Path+'Data/FormatStr/Value', FormatStr); Memo.Text := XML.GetValue(Path+'Data/Memo/Value', ''); // TODO Check default Script.Text:= XML.GetValue(Path+'Data/Script/Value', ''); // TODO Check default end else memo1.text := XML.GetValue(Path+'Data/Memo1/Value', ''); // TODO Check default end; procedure TfrView.SaveToStream(Stream: TStream); var S: Single; begin {$IFDEF DebugLR} DebugLn('%s%s.SaveToStream begin',[sspc,name]); {$ENDIF} with Stream do begin if StreamMode = smDesigning then frWriteString(Stream, Name); // Write(x, 18); // this is equal to, but much faster: Write(x, 4); Write(y, 4); Write(dx, 4); Write(dy, 4); Write(Flags, 2); S := fFrameWidth; Write(s,SizeOf(s)); Write(fFrameColor, SizeOf(fFrameColor)); Write(fFrames,SizeOf(fFrames)); Write(fFrameStyle, SizeOf(fFrameStyle)); Write(fFillColor, 4); if StreamMode = smDesigning then begin Write(fFormat, 4); frWriteString(Stream, fFormatStr); frWriteMemo(Stream, Memo); frWriteMemo(Stream, Script); Write(Visible, 2); end else frWriteMemo(Stream, Memo1); end; {$IFDEF DebugLR} Debugln('%s%s.SaveToStream end',[sspc,name]); {$ENDIF} end; procedure TfrView.SaveToXML(XML: TXMLConfig; Path: String); begin inherited SaveToXML(XML,Path); XML.SetValue(Path+'Typ/Value', frTypeObjectToStr(Typ)); XML.SetValue(Path+'StreamMode/Value', Ord(StreamMode)); //todo: use symbolic valuess XML.SetValue(Path+'Size/Left/Value', x); XML.SetValue(Path+'Size/Top/Value', y); XML.SetValue(Path+'Size/Width/Value', dx); XML.SetValue(Path+'Size/Height/Value', dy); XML.SetValue(Path+'Flags/Value', flags); if IsPublishedProp(self,'FillColor') then XML.SetValue(Path+'FillColor/Value', GetSaveProperty('FillColor')); if IsPublishedProp(self,'FrameColor') then XML.SetValue(Path+'Frames/FrameColor/Value', GetSaveProperty('FrameColor')); if IsPublishedProp(self,'FrameStyle') then XML.SetValue(Path+'Frames/FrameStyle/Value', GetSaveProperty('FrameStyle')); if IsPublishedProp(self,'FrameWidth') then XML.SetValue(Path+'Frames/FrameWidth/Value', GetSaveProperty('FrameWidth')); if IsPublishedProp(self,'Frames') then XML.SetValue(Path+'Frames/FrameBorders/Value', GetSaveProperty('Frames')); if StreamMode = smDesigning then begin if IsPublishedProp(self,'Format') then XML.SetValue(Path+'Data/Format/Value', Format); if IsPublishedProp(self,'FormatStr') then XML.SetValue(Path+'Data/FormatStr/Value', FormatStr); if IsPublishedProp(self,'Memo') then XML.SetValue(Path+'Data/Memo/Value', TStrings(Memo).Text); if IsPublishedProp(self,'Script') then XML.SetValue(Path+'Data/Script/Value', TStrings(Script).Text); end else XML.SetValue(Path+'Data/Memo1/Value', Memo1.Text); end; procedure TfrView.Resized; begin end; procedure TfrView.GetBlob(b: TfrTField); begin if b=nil then; end; procedure TfrView.OnHook(View: TfrView); begin if view=nil then; end; procedure TfrView.BeforeChange; begin if (frDesigner<>nil) and (fUpdate=0) then frDesigner.BeforeChange; end; procedure TfrView.AfterChange; begin if (frDesigner<>nil) and (fUpdate=0) then frDesigner.AfterChange; end; function TfrView.GetClipRgn(rt: TfrRgnType): HRGN; var bx, by, bx1, by1, w1, w2: Integer; begin if FrameStyle=frsDouble then begin w1 := Round(FrameWidth * 1.5); w2 := Round((FrameWidth - 1) / 2 + FrameWidth); end else begin w1 := Round(FrameWidth / 2); w2 := Round((FrameWidth - 1) / 2); end; bx:=x; by:=y; bx1:=x+dx+1; by1:=y+dy+1; if (frbTop in Frames) then Inc(bx1, w2); if (frbLeft in Frames) then Inc(by1, w2); if (frbBottom in Frames) then Dec(bx, w1); if (frbRight in Frames) then Dec(by, w1); if rt = rtNormal then Result := CreateRectRgn(bx, by, bx1, by1) else Result := CreateRectRgn(bx - 10, by - 10, bx1 + 10, by1 + 10); end; procedure TfrView.SetBounds(aLeft, aTop, aWidth, aHeight: Integer); begin Self.x := aLeft; Self.y := aTop; Self.dx := aWidth; Self.dy:= aHeight; end; function TfrView.PointInView(aX,aY: Integer): Boolean; Var Rc : TRect; bx, by, bx1, by1, w1, w2: Integer; begin if FrameStyle=frsDouble then begin w1 := Round(FrameWidth * 1.5); w2 := Round((FrameWidth - 1) / 2 + FrameWidth); end else begin w1 := Round(FrameWidth / 2); w2 := Round((FrameWidth - 1) / 2); end; bx:=x; by:=y; bx1:=dx+1; by1:=dy+1; if (frbTop in Frames) then Inc(bx1, w2); if (frbLeft in Frames) then Inc(by1, w2); if (frbBottom in Frames) then Dec(bx, w1); if (frbRight in Frames) then Dec(by, w1); Rc:=Bounds(bx, by, bx1, by1); Result:=((aX>Rc.Left) and (aXRc.Top) and (aY 0; Popup.Items.Add(m); end; procedure TfrView.P1Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count-1 do begin t := TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flStretched) + Word(Checked); end; end; frDesigner.AfterChange; end; function TfrView.GetLeft: Double; begin if frDesigner<>nil then result := frDesigner.PointsToUnits(x) else result := x; end; function TfrView.GetHeight: Double; begin if frDesigner<>nil then result := frDesigner.PointsToUnits(dy) else result := dy; end; function TfrView.GetTop: Double; begin if frDesigner<>nil then result := frDesigner.PointsToUnits(y) else result := y; end; function TfrView.GetWidth: Double; begin if frDesigner<>nil then result := frDesigner.PointsToUnits(dx) else result := dx; end; procedure TfrView.SetFillColor(const AValue: TColor); begin if (aValue<>fFillColor) and (fUpdate=0) then begin BeforeChange; fFillColor:=aValue; AfterChange; end; end; procedure TfrView.SetFormat(const AValue: Integer); begin if fFormat<>AValue then begin BeforeChange; fFormat := AValue; AfterChange; end; end; procedure TfrView.SetFormatStr(const AValue: String); begin if fFormatStr<>AValue then begin BeforeChange; fFormatStr := AValue; AFterChange; end; end; procedure TfrView.SetFrameColor(const AValue: TColor); begin if fFramecolor<>AValue then begin BeforeChange; fFrameColor := AValue; AfterChange; end; end; procedure TfrView.SetFrames(const AValue: TfrFrameBorders); begin if (aValue<>fFrames) and (fUpdate=0) then begin BeforeChange; fFrames:=AValue; AfterChange; end; end; procedure TfrView.SetFrameStyle(const AValue: TfrFrameStyle); begin if fFrameStyle<>AValue then begin BeforeChange; fFrameStyle := AValue; AfterChange; end; end; procedure TfrView.SetFrameWidth(const AValue: Double); begin if fFrameWidth<>AValue then begin BeforeChange; fFrameWidth := AValue; AfterChange; end; end; procedure TfrView.SetHeight(const AValue: Double); var tmp: Integer; begin if frDesigner<>nil then begin tmp := frDesigner.UnitsToPoints(AValue); frDesigner.MoveObjects(0,tmp-dy,true); end else dy := round(Avalue); end; procedure TfrView.SetLeft(const AValue: Double); var tmp: Integer; begin if frDesigner<>nil then begin tmp := frDesigner.UnitsToPoints(AValue); frDesigner.MoveObjects(tmp-x, 0, false); end else x := round(AValue); end; procedure TfrView.SetStretched(const AValue: Boolean); begin if fStretched<>AValue then begin BeforeChange; fStretched := AValue; AfterChange; end; end; procedure TfrView.SetTop(const AValue: Double); var tmp: Integer; begin if frDesigner<>nil then begin tmp := frDesigner.UnitsToPoints(AValue); frDesigner.MoveObjects(0, tmp-y, false); end else y := round(AValue); end; procedure TfrView.SetWidth(const AValue: Double); var tmp: Integer; begin if frDesigner<>nil then begin tmp := frDesigner.UnitsToPoints(AValue); frDesigner.MoveObjects(tmp-dx, 0, true); end else dx := round(AValue); end; {----------------------------------------------------------------------------} constructor TfrMemoView.Create; begin inherited Create; Typ := gtMemo; FFont := TFont.Create; FFont.Name := 'Arial'; FFont.Size := 10; FFont.Color := clBlack; FFont.Charset := frCharset; Highlight.FontColor := clBlack; Highlight.FillColor := clWhite; Highlight.FontStyle := 2; // fsBold BaseName := 'Memo'; Flags := flStretched + flWordWrap; LineSpacing := 2; CharacterSpacing := 0; Adjust := 0; fAngle :=0; end; destructor TfrMemoView.Destroy; begin FFont.Free; inherited Destroy; end; procedure TfrMemoView.SetFont(Value: TFont); begin BeforeChange; fFont.Assign(Value); AfterChange; end; procedure TfrMemoView.SetLayout(const AValue: TTextLayout); begin if Layout<>AValue then begin BeforeChange; Adjust := (Adjust and %11100111) or (ord(AValue) shl 3); AfterChange; end; end; procedure TfrMemoView.SetWordWrap(const AValue: Boolean); begin if WordWrap<>AValue then begin BeforeChange; SetBit(Flags, AValue, flWordWrap); AfterChange; end; end; procedure TfrMemoView.Assign(From: TfrView); begin inherited Assign(From); FFont.Assign(TfrMemoView(From).Font); Adjust := TfrMemoView(From).Adjust; Highlight := TfrMemoView(From).Highlight; HighlightStr := TfrMemoView(From).HighlightStr; LineSpacing := TfrMemoView(From).LineSpacing; end; procedure TfrMemoView.ExpandVariables; var i: Integer; procedure GetData(var s: String); var i, j: Integer; s1, s2: String; begin i := 1; repeat while (i < Length(s)) and (s[i] <> '[') do Inc(i); s1 := GetBrackedVariable(s, i, j); if i <> j then begin Delete(s, i, j - i + 1); s2 := ''; CurReport.InternalOnGetValue(s1, s2); Insert(s2, s, i); Inc(i, Length(s2)); j := 0; end; until i = j; end; var s: string; begin Memo1.Clear; for i := 0 to Memo.Count - 1 do begin s := Memo[i]; if Length(s) > 0 then begin GetData(s); // WORKAROUND: FPC BUG, setting Memo1.Text=char doesn't work if (Length(s)=1)and(Length(Memo1.Text)=0) then Memo1.Add(s) else Memo1.Text := Memo1.Text + s; end else Memo1.Add(''); end; end; procedure TfrMemoView.AssignFont(aCanvas: TCanvas); begin with aCanvas do begin {$IFDEF DebugLR} DebugLn('AssignFont('+self.Font.Name+')'); {$ENDIF} //** Brush.Style := bsClear; Font.Assign(Self.Font); //Font := Self.Font; if not IsPrinting and (ScaleY<>0) then Font.Height := -Round(Font.Size * 96 / 72 * ScaleY); end; end; type TWordBreaks = string; const gl: set of Char = ['À', 'Å', '¨', 'È', 'Î', 'Ó', 'Û', 'Ý', 'Þ', 'ß']; r_sogl: set of Char = ['Ú', 'Ü']; spaces: set of Char = [' ', '.', ',', '-']; function BreakWord(s: String): TWordBreaks; var i: Integer; CanBreak: Boolean; begin Result := ''; s := AnsiUpperCase(s); if Length(s) > 4 then begin i := 2; repeat CanBreak := False; if s[i] in gl then begin if (s[i + 1] in gl) or (s[i + 2] in gl) then CanBreak := True; end else begin if not (s[i + 1] in gl) and not (s[i + 1] in r_sogl) and (s[i + 2] in gl) then CanBreak := True; end; if CanBreak then Result := Result + Chr(i); Inc(i); until i > Length(s) - 2; end; {$IFDEF DebugLR} debugLn(' breakword: s=',dbgstr(s),' result=',dbgstr(result)); {$ENDIF} end; procedure TfrMemoView.WrapMemo; var size, size1, maxwidth: Integer; b: TWordBreaks; WCanvas: TCanvas; procedure OutLine(const str: String); var n, w: Word; begin n := Length(str); if (n > 0) and (str[n] = #1) then w := WCanvas.TextWidth(Copy(str, 1, n - 1)) else w := WCanvas.TextWidth(str); {$IFDEF DebugLR} debugLn(' Outline: str="',dbgstr(str),'" w/=',dbgs(w div 256),' w%=',dbgs(w mod 256)); {$ENDIF} SMemo.Add(str + Chr(w div 256) + Chr(w mod 256)); Inc(size, size1); end; procedure WrapLine(const s: String); var i, cur, beg, last: Integer; WasBreak, CRLF: Boolean; begin CRLF := False; for i := 1 to Length(s) do begin if s[i] in [#10, #13] then begin CRLF := True; break; end; end; last := 1; beg := 1; {$IFDEF DebugLR} debugLn(' WrapLine: init "',dbgstr(s),'" wcanvas.txtw=',dbgs(WCanvas.TextWidth(s)), ' maxwidth=',dbgs(maxwidth),' crlf=',dbgs(crlf)); {$ENDIF} if not CRLF and ((Length(s) <= 1) or (WCanvas.TextWidth(s) <= maxwidth)) then begin {$IFDEF DebugLR} debugLn(' WrapLine: fast crlf=',dbgs(crlf),' wcanvas.txtw=',dbgs(Wcanvas.TextWidth(s))); {$ENDIF} OutLine(s + #1) end else begin cur := 1; while cur <= Length(s) do begin if s[cur] in [#10, #13] then begin {$IFDEF DebugLR} debugLn(' Wrapline: crlf beg=',dbgs(beg),' cur=',dbgs(cur)); {$ENDIF} OutLine(Copy(s, beg, cur - beg) + #1); while (cur < Length(s)) and (s[cur] in [#10, #13]) do Inc(cur); beg := cur; last := beg; if s[cur] in [#13, #10] then begin {$IFDEF DebugLR} debugln(' Wrapline: Exiting as cur is in crlf cur=',dbgs(cur)); {$ENDIF} Exit; end else continue; end; if s[cur] <> ' ' then if WCanvas.TextWidth(Copy(s, beg, cur - beg + 1)) > maxwidth then begin WasBreak := False; if (Flags and flWordBreak) <> 0 then begin i := cur; while (i <= Length(s)) and not (s[i] in spaces) do Inc(i); {$IFDEF DebugLR} debugln(' wrapline: to BreakWord: ini=',dbgs(last+1),' fin=',dbgs(i-last-1)); {$ENDIF} b := BreakWord(Copy(s, last + 1, i - last - 1)); if Length(b) > 0 then begin i := 1; cur := last; while (i <= Length(b)) and (WCanvas.TextWidth(Copy(s, beg, last - beg + 1 + Ord(b[i])) + '-') <= maxwidth) do begin WasBreak := True; cur := last + Ord(b[i]); Inc(i); end; last := cur; end; end else if last = beg then last := cur; if WasBreak then begin {$IFDEF DebugLR} debugln(' wrapline: wasbreak=true, beg=',dbgs(beg),' fin=',dbgs(last-beg+1)); {$ENDIF} OutLine(Copy(s, beg, last - beg + 1) + '-'); end else if s[last] = ' ' then begin {$IFDEF DebugLR} debugln(' wrapline: s[last]=" ", beg=',dbgs(beg),' fin=',dbgs(last-beg)); {$ENDIF} OutLine(Copy(s, beg, last - beg)) end else begin {$IFDEF DebugLR} debugln(' wrapline: s[last]<>" ", beg=',dbgs(beg),' fin=',dbgs(last-beg)); {$ENDIF} OutLine(Copy(s, beg, last - beg + 1)); end; if ((Flags and flWordBreak) <> 0) and not WasBreak and (last = cur) then begin beg := cur + 1; cur := Length(s); break; end; if (Flags and flWordBreak) = 0 then begin if last = cur then begin beg := cur; break; end; end; beg := last + 1; last := beg; end; if s[cur] in spaces then last := cur; Inc(cur); end; if beg <> cur then begin {$IFDEF DebugLR} debugln(' wrapline: beg<>cur, beg=',dbgs(beg),' fin=',dbgs(cur-beg+1)); {$ENDIF} OutLine(Copy(s, beg, cur - beg + 1) + #1); end; end; end; procedure OutMemo; var i: Integer; begin size := y + gapy; size1 := -WCanvas.Font.Height + LineSpacing; maxWidth := dx - gapx - gapx; {$IFDEF DebugLR} DebugLn(' OutMemo: Size=',dbgs(Size),' Size1=',dbgs(Size1), ' MaxWidth=',dbgs(MaxWidth),' dx=',dbgs(dx),' gapx=',dbgs(gapx)); {$ENDIF} for i := 0 to Memo1.Count - 1 do begin if (Flags and flWordWrap) <> 0 then WrapLine(Memo1[i]) else OutLine(Memo1[i] + #1); end; VHeight := size - y + gapy; TextHeight := size1; end; procedure OutMemo90; var i: Integer; h, oldh: HFont; begin h := Create90Font(WCanvas.Font); oldh := SelectObject(WCanvas.Handle, h); size := x + gapx; size1 := -WCanvas.Font.Height + LineSpacing; maxwidth := dy - gapy - gapy; for i := 0 to Memo1.Count - 1 do begin if (Flags and flWordWrap) <> 0 then WrapLine(Memo1[i]) else OutLine(Memo1[i]); end; SelectObject(WCanvas.Handle, oldh); DeleteObject(h); VHeight := size - x + gapx; TextHeight := size1; end; begin WCanvas := TempBmp.Canvas; WCanvas.Font.Assign(Font); WCanvas.Font.Height := -Round(Font.Size * 96 / 72); {$IFDEF DebugLR} DebugLn(' TfrMemoView.WrapMemo:', ' Font.PPI=', dbgs(Font.PixelsPerInch), ' Font.Size=', dbgs(Font.Size), ' Canvas.Font.PPI=',dbgs(Canvas.Font.PixelsPerInch), ' WCanvas.Font.Size=',dbgs(WCanvas.Font.Size)); {$ENDIF} SetTextCharacterExtra(WCanvas.Handle, CharacterSpacing); SMemo.Clear; if Angle<>0 then OutMemo90 else OutMemo; end; var DxArray: Array[0..2047] of Integer; procedure TfrMemoView.ShowMemo; var DR : TRect; SavX,SavY : Integer; procedure OutMemo; var i, cury, th: Integer; function OutLine(st: String): Boolean; var {$IFDEF DebugLR} aw: Integer; {$ENDIF} n, nw, w, curx: Integer; ParaEnd: Boolean; Ts: TTextStyle; begin if not Streaming and (cury < DR.Bottom) then begin n := Length(St); w := Ord(St[n - 1]) * 256 + Ord(St[n]); SetLength(St, n - 2); ParaEnd := True; if Length(St) > 0 then begin if St[Length(St)] = #1 then SetLength(St, Length(St) - 1) else ParaEnd := False; end; // handle any alignment with same code AssignFont(Canvas); Ts := Canvas.TextStyle; Ts.Layout :=tlTop; Ts.Alignment :=self.Alignment; Ts.Wordbreak :=false; Ts.SingleLine:=True; Ts.Clipping :=True; Canvas.TextStyle := Ts; nw := Round(w * ScaleX); // needed width {$IFDEF DebugLR} DebugLn('2 Canvas.Font.Size=%d TextWidth=%d',[Canvas.Font.Size,Canvas.TextWidth(St)]); {$ENDIF} while (Canvas.TextWidth(St) > nw) and (Canvas.Font.Size>1) do begin Canvas.Font.Size := Canvas.Font.Size-1; {$IFDEF DebugLR} DebugLn('Rescal font %d',[Canvas.Font.Size]); {$ENDIF} end; th := -Canvas.Font.Height+Round(LineSpacing * ScaleY); {$IFDEF DebugLR} DebugLn('Th=%d Canvas.TextHeight(H)=%d',[Th,Canvas.TextHeight('H')]); Debugln('2 Canvas.Font.Size=%d TextWidth=%d',[Canvas.Font.Size,Canvas.TextWidth(St)]); aw := Canvas.TextWidth(St); // actual width DebugLn('nw=%d aw=%d',[nw,aw]); {$ENDIF} case Alignment of Classes.taLeftJustify : CurX :=x+gapx; Classes.taRightJustify: CurX :=x+dx-1-gapx-nw; Classes.taCenter : CurX :=x+gapx+(dx-gapx-gapx-nw) div 2; end; if not Exporting then Canvas.TextRect(DR, CurX, CurY, St) else CurReport.InternalOnExportText(curx, cury, St, Self); Inc(CurStrNo); Result := False; end else Result := True; cury := cury + th; end; begin {OutMemo} cury := y + gapy; th := -Canvas.Font.Height+Round(LineSpacing * ScaleY); {$IFDEF DebugLR} DebugLn('Th=',IntToStr(Th),' Canvas.TextHeight(H)=',InttoStr(Canvas.TextHeight('H')), 'DR=',dbgs(DR)); {$ENDIF} CurStrNo := 0; for i := 0 to Memo1.Count - 1 do if OutLine(Memo1[i]) then break; end; procedure OutMemo90; var i, th, curx: Integer; h, oldh: HFont; procedure OutLine(str: String); var i, n, cury: Integer; ParaEnd: Boolean; begin SetLength(str, Length(str) - 2); if str[Length(str)] = #1 then begin ParaEnd := True; SetLength(str, Length(str) - 1); end else ParaEnd := False; cury := 0; if Adjust = 4 then cury:=y + dy-gapy else if Adjust = 5 then cury := y + gapy + Canvas.TextWidth(str) else if Adjust = 6 then cury := y + dy - 1 - gapy - (dy - gapy - gapy - Canvas.TextWidth(str)) div 2 else if not Exporting then begin cury := y + dy - gapy; n := 0; for i := 1 to Length(str) do if str[i] = ' ' then Inc(n); //** {if (n <> 0) and not ParaEnd then SetTextJustification(Canvas.Handle, dy - gapy - gapy - Canvas.TextWidth(str), n);} end; if not Exporting then begin //** { ExtTextOut(Canvas.Handle, curx, cury, ETO_CLIPPED, @DR, PChar(str), Length(str), nil); if Adjust <> 7 then SetTextJustification(Canvas.Handle, 0, 0); } end; if Exporting then CurReport.InternalOnExportText(curx, cury, str, Self); Inc(CurStrNo); curx := curx + th; end; begin {OutMemo90} h := Create90Font(Canvas.Font); oldh := SelectObject(Canvas.Handle,h); curx := x + gapx; th := -Canvas.Font.Height + Round(LineSpacing * ScaleY); CurStrNo := 0; for i := 0 to Memo1.Count - 1 do OutLine(Memo1[i]); SelectObject(Canvas.Handle, oldh); DeleteObject(h); end; begin AssignFont(Canvas); SavX:=X; SavY:=Y; Try SetTextCharacterExtra(Canvas.Handle, Round(CharacterSpacing * ScaleX)); DR:=Rect(DRect.Left + 1, DRect.Top, DRect.Right - 2, DRect.Bottom - 1); VHeight:=Round(VHeight*ScaleY); if Alignment in [Classes.taLeftJustify..Classes.taCenter] then begin if Layout=tlCenter then y:=y+(dy-VHeight) div 2 else if Layout=tlBottom then y:=y+dy-VHeight; end; OutMemo; finally X:=SavX; Y:=SavY; end; (* if (Adjust and $18) <> 0 then begin ad := Adjust; ox := x; oy := y; Adjust := Adjust and $7; if (ad and $4) <> 0 then begin if (ad and $18) = $8 then x := x + (dx - VHeight) div 2 else if (ad and $18) = $10 then x := x + dx - VHeight; OutMemo90; end else begin if (ad and $18) = $8 then y := y + (dy - VHeight) div 2 else if (ad and $18) = $10 then y := y + dy - VHeight; OutMemo; end; Adjust := ad; x := ox; y := oy; end else if (Adjust and $4) <> 0 then OutMemo90 else OutMemo; *) end; function TfrMemoView.CalcWidth(aMemo: TStringList): Integer; var CalcRect: TRect; s: String; n: Integer; begin {$IFDEF DebugLR} DbgOut('TfrMemoView.CalcWidth: text=',dbgstr(aMemo.Text), ' Font.PPI=', dbgs(Font.PixelsPerInch), ' Font.Size=', dbgs(Font.Size),' dx=',dbgs(Dx),' dy=',dbgs(dy)); {$ENDIF} CalcRect := Rect(0, 0, dx, dy); Canvas.Font.Assign(Font); Canvas.Font.Height := -Round(Font.Size * 96 / 72); {$IFDEF DebugLR} DbgOut(' Canvas.Font.PPI=',dbgs(Canvas.Font.PixelsPerInch), ' Canvas.Font.Size=',dbgs(Canvas.Font.Size)); {$ENDIF} s := aMemo.Text; n := Length(s); if n > 2 then if (s[n - 1] = #13) and (s[n] = #10) then SetLength(s, n - 2); SetTextCharacterExtra(Canvas.Handle, Round(CharacterSpacing * ScaleX)); DrawText(Canvas.Handle, PChar(s), Length(s), CalcRect, DT_CALCRECT); Result := CalcRect.Right + Round(2 * FrameWidth) + 2; {$IFDEF DebugLR} DebugLn('RR Width=', dbgs(Result),' Rect=', dbgs(CalcRect)); {$ENDIF} end; procedure TfrMemoView.Draw(aCanvas: TCanvas); var NeedWrap: Boolean; newdx: Integer; OldScaleX, OldScaleY: Double; begin BeginDraw(aCanvas); {$IFDEF DebugLR} if IsPrinting then begin DebugLn(''); Debugln('TfrMemoView.Draw: Name=',Name, ' Printing=', dbgs(IsPrinting), ' Canvas.Font.PPI=',dbgs(Canvas.Font.PixelsPerInch)); end; NewDx := 0; {$ENDIF} if ((Flags and flAutoSize) <> 0) and (Memo.Count > 0) and (DocMode <> dmDesigning) then begin newdx := CalcWidth(Memo); if Alignment=Classes.taRightJustify then begin x := x + dx - newdx; dx := newdx; end else dx := newdx; end; {$IFDEF DebugLR} DebugLn('NewDx=',dbgs(NewDx),' Dx=',dbgs(dx)); {$ENDIF} Streaming := False; Memo1.Assign(Memo); OldScaleX := ScaleX; OldScaleY := ScaleY; ScaleX := 1; ScaleY := 1; CalcGaps; ScaleX := OldScaleX; ScaleY := OldScaleY; RestoreCoord; if Memo1.Count > 0 then begin NeedWrap := Pos(#1, Memo1.Text) = 0; {$IFDEF DebugLR} DebugLn(' Memo1: Count=',dbgs(Memo1.Count),' Text=',dbgstr(Memo1.text), ' NeedWrap=',dbgs(needwrap)); {$ENDIF} if Memo1[Memo1.Count - 1] = #1 then Memo1.Delete(Memo1.Count - 1); if NeedWrap then begin WrapMemo; Memo1.Assign(SMemo); end; end; CalcGaps; if not Exporting then ShowBackground; if not Exporting then ShowFrame; if Memo1.Count > 0 then ShowMemo; RestoreCoord; end; procedure TfrMemoView.Print(Stream: TStream); var St: String; CanExpandVar: Boolean; OldFont: TFont; OldFill: Integer; i: Integer; begin {$IFDEF DebugLR} DebugLn('%sTfrMemoView.Print %s',[sspc,Name]); {$ENDIF} BeginDraw(TempBmp.Canvas); Streaming := True; if DrawMode = drAll then frInterpretator.DoScript(Script); CanExpandVar := True; if (DrawMode = drAll) and (Assigned(CurReport.OnEnterRect) or ((FDataSet <> nil) and frIsBlob(TfrTField(FDataSet.FindField(FField))))) then begin Memo1.Assign(Memo); St:=Memo1.Text; CurReport.InternalOnEnterRect(Memo1, Self); if St<>Memo1.Text then CanExpandVar:= False; end else if DrawMode = drAfterCalcHeight then CanExpandVar := False; if DrawMode <> drPart then if CanExpandVar then ExpandVariables; if not Visible then begin DrawMode := drAll; Exit; end; OldFont := TFont.Create; OldFont.Assign(Font); OldFill := FillColor; if Length(HighlightStr) <> 0 then begin if frParser.Calc(HighlightStr) <> 0 then begin Font.Style:= frSetFontStyle(Highlight.FontStyle); Font.Color:= Highlight.FontColor; fFillColor := Highlight.FillColor; end; end; if (DrawMode = drPart) then begin CalcGaps; Streaming:=False; ShowMemo; SMemo.Assign(Memo1); while Memo1.Count > CurStrNo do Memo1.Delete(CurStrNo); if Pos(#1, Memo1.Text) = 0 then Memo1.Add(#1); end; Stream.Write(Typ, 1); if Typ = gtAddIn then frWriteString(Stream, ClassName); SaveToStream(Stream); if DrawMode = drPart then begin Memo1.Assign(SMemo); for i := 0 to CurStrNo - 1 do Memo1.Delete(0); end; Font.Assign(OldFont); OldFont.Free; fFillColor := OldFill; DrawMode := drAll; end; procedure TfrMemoView.ExportData; begin inherited; Exporting := True; Draw(TempBmp.Canvas); Exporting := False; end; function TfrMemoView.CalcHeight: Integer; var s: String; CanExpandVar: Boolean; OldFont: TFont; OldFill: Integer; begin Result := 0; DrawMode := drAfterCalcHeight; BeginDraw(TempBmp.Canvas); frInterpretator.DoScript(Script); if not Visible then Exit; CanExpandVar := True; Memo1.Assign(Memo); s := Memo1.Text; CurReport.InternalOnEnterRect(Memo1, Self); if s <> Memo1.Text then CanExpandVar := False; if CanExpandVar then ExpandVariables; OldFont := TFont.Create; OldFont.Assign(Font); OldFill := FillColor; if Length(HighlightStr) <> 0 then if frParser.Calc(HighlightStr) <> 0 then begin Font.Style := frSetFontStyle(Highlight.FontStyle); Font.Color := Highlight.FontColor; fFillColor := Highlight.FillColor; end; if ((Flags and flAutoSize) <> 0) and (Memo1.Count > 0) and (DocMode <> dmDesigning) then dx := CalcWidth(Memo1); CalcGaps; if Memo1.Count <> 0 then begin WrapMemo; Result := VHeight; end; Font.Assign(OldFont); OldFont.Free; fFillColor := OldFill; end; function TfrMemoView.MinHeight: Integer; begin Result := TextHeight; end; function TfrMemoView.RemainHeight: Integer; begin Result := Memo1.Count * TextHeight; end; procedure TfrMemoView.LoadFromStream(Stream: TStream); var w: Word; i: Integer; TmpAlign: TAlignment; TmpLayout: TTextLayout; begin {$IFDEF DebugLR} DebugLn('Stream.Position=',IntToStr(Stream.Position),' Stream.Size=',InttoStr(Stream.Size)); {$ENDIF} inherited LoadFromStream(Stream); Font.Name := ReadString(Stream); with Stream do begin Read(i, 4); Font.Size := i; Read(w, 2); Font.Style := frSetFontStyle(w); Read(i, 4); Font.Color := i; Read(w, 2); if frVersion < 23 then w := frCharset; Font.Charset := w; if StreamMode = smDesigning then begin Read(Highlight, 10); HighlightStr := ReadString(Stream); end; Read(TmpAlign,SizeOf(TmpAlign)); Read(TmpLayout,SizeOf(TmpLayout)); Read(fAngle,SizeOf(fAngle)); BeginUpdate; Alignment := tmpAlign; Layout := tmpLayout; EndUpdate; end; if frVersion = 21 then Flags := Flags or flWordWrap; end; procedure TfrMemoView.LoadFromXML(XML: TXMLConfig; Path: String); begin inherited LoadFromXML(XML, Path); Font.Name := XML.GetValue(Path+'Font/Name/Value', 'Arial'); // todo chk Font.Size := XML.GetValue(Path+'Font/Size/Value', 10); // todo chk RestoreProperty('CharSet',XML.GetValue(Path+'Font/Charset/Value',''),Font); RestoreProperty('Style',XML.GetValue(Path+'Font/Style/Value',''),Font); Font.Color := StringToColor(XML.GetValue(Path+'Font/Color/Value','clBlack')); // todo chk if StreamMode = smDesigning then begin Highlight.FontStyle := XML.GetValue(Path+'Highlight/FontStyle/Value', 0); // todo chk Highlight.FontColor := StringToColor(XML.GetValue(Path+'Highlight/FontColor/Value', 'clBlack')); Highlight.FillColor := StringToColor(XML.GetValue(Path+'Highlight/FillColor/Value', 'clWhite')); HighlightStr := XML.GetValue(Path+'Highlight/HighlightStr/Value', HighlightStr); end; RestoreProperty('Alignment',XML.GetValue(Path+'Alignment/Value','')); RestoreProperty('Layout',XML.GetValue(Path+'Layout/Value','')); fAngle := XML.GetValue(Path+'Angle/Value', 0); end; procedure TfrMemoView.SaveToStream(Stream: TStream); var i: Integer; w: Word; tmpAlign: TAlignment; tmpLayout: TTextLayout; begin inherited SaveToStream(Stream); frWriteString(Stream, Font.Name); with Stream do begin i := Font.Size; Write(i, 4); w := frGetFontStyle(Font.Style); Write(w, 2); i := Font.Color; Write(i, 4); w := Font.Charset; Write(w, 2); if StreamMode = smDesigning then begin Write(Highlight, 10); frWriteString(Stream, HighlightStr); end; if (Adjust and %11 = %11) then tmpAlign := taLeftJustify else tmpAlign := Alignment; tmpLayout := Layout; Write(tmpAlign,SizeOf(tmpAlign)); Write(tmpLayout,SizeOf(tmpLayout)); Write(fAngle,SizeOf(fAngle)); end; end; procedure TfrMemoView.SaveToXML(XML: TXMLConfig; Path: String); begin inherited SaveToXML(XML, Path); XML.SetValue(Path+'Font/Name/Value', Font.name); XML.SetValue(Path+'Font/Size/Value', Font.Size); XML.SetValue(Path+'Font/Color/Value', ColorToString(Font.Color)); XML.SetValue(Path+'Font/Charset/Value', GetSaveProperty('CharSet',Font)); XML.SetValue(Path+'Font/Style/Value', GetSaveProperty('Style',Font)); if StreamMode=smDesigning then begin XML.SetValue(Path+'Highlight/FontStyle/Value', HighLight.FontStyle); XML.SetValue(Path+'Highlight/FontColor/Value', ColorToString(Highlight.FontColor)); XML.SetValue(Path+'Highlight/FillColor/Value', ColorToString(Highlight.FillColor)); XML.SetValue(Path+'Highlight/HighlightStr/Value', HighlightStr); end; XML.SetValue(Path+'Alignment/Value',GetSaveProperty('Alignment')); XML.SetValue(Path+'Layout/Value', GetSaveProperty('Layout')); XML.SetValue(Path+'Angle/Value', FAngle); end; procedure TfrMemoView.GetBlob(b: TfrTField); var M: TMemoryStream; begin // todo: TBLobField.AssignTo is not implemented yet // even if I supply a patch for 2.0.4 it will // not be integrated because it's in RC1 now // (I guess) // //Memo1.Assign(b); M := TMemoryStream.Create; try TBlobField(B).SaveToStream(M); M.Position := 0; Memo1.LoadFromStream(M); finally M.Free; end; end; procedure TfrMemoView.FontChange(sender: TObject); begin AfterChange; end; procedure TfrMemoView.DefinePopupMenu(Popup: TPopupMenu); var m: TMenuItem; begin m := TMenuItem.Create(Popup); m.Caption := sVarFormat; m.OnClick := @P1Click; Popup.Items.Add(m); m := TMenuItem.Create(Popup); m.Caption := sFont; m.OnClick := @P4Click; Popup.Items.Add(m); inherited DefinePopupMenu(Popup); m := TMenuItem.Create(Popup); m.Caption := sWordWrap; m.OnClick := @P2Click; m.Checked := (Flags and flWordWrap) <> 0; Popup.Items.Add(m); m := TMenuItem.Create(Popup); m.Caption := sWordBreak; m.OnClick := @P3Click; m.Enabled := (Flags and flWordWrap) <> 0; if m.Enabled then m.Checked := (Flags and flWordBreak) <> 0; Popup.Items.Add(m); m := TMenuItem.Create(Popup); m.Caption := sAutoSize; m.OnClick := @P5Click; m.Checked := (Flags and flAutoSize) <> 0; Popup.Items.Add(m); end; procedure TfrMemoView.MonitorFontChanges; begin FFont.OnChange:= @FontChange; end; procedure TfrMemoView.P1Click(Sender: TObject); var t: TfrView; i: Integer; begin BeforeChange; frFmtForm := TfrFmtForm.Create(nil); try with frFmtForm do begin EdFormat := Self.Format; EdFormatStr := Self.FormatStr; if ShowModal = mrOk then begin for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t := TfrView(frDesigner.Page.Objects[i]); if t.Selected then begin (t as TfrMemoView).Format := EdFormat; (t as TfrMemoView).FormatStr := EdFormatStr; end; end; end; end; finally frFmtForm.Free; AfterChange end; end; function TfrMemoView.GetAutoSize: Boolean; begin Result:=((Flags and flAutoSize)<>0); end; function TfrMemoView.GetLayout: TTextLayout; begin result := TTextLayout((adjust shr 3) and %11); end; function TfrMemoView.GetAlignment: TAlignment; begin Result:=Classes.TAlignment(Adjust and %11); end; function TfrMemoView.GetWordWrap: Boolean; begin Result:=((Flags and flWordWrap)<>0); end; procedure TfrMemoView.P2Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then SetBit(t.Flags, Checked, flWordWrap); end; end; frDesigner.AfterChange; end; procedure TfrMemoView.P3Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flWordBreak) + Word(Checked) * flWordBreak; end; end; frDesigner.AfterChange; end; procedure TfrMemoView.P4Click(Sender: TObject); var t: TfrView; i: Integer; fd: TFontDialog; begin frDesigner.BeforeChange; fd := TFontDialog.Create(nil); with fd do begin Font.Assign(Self.Font); if Execute then for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then begin if Font.Name <> Self.Font.Name then TfrMemoView(t).Font.Name := Font.Name; if Font.Size <> Self.Font.Size then TfrMemoView(t).Font.Size := Font.Size; if Font.Color <> Self.Font.Color then TfrMemoView(t).Font.Color := Font.Color; if Font.Style <> Self.Font.Style then TfrMemoView(t).Font.Style := Font.Style; if Font.Charset <> Self.Font.Charset then TfrMemoView(t).Font.Charset := Font.Charset; end; end; end; fd.Free; frDesigner.AfterChange; end; procedure TfrMemoView.P5Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flAutoSize) + Word(Checked) * flAutoSize; end; end; frDesigner.AfterChange; end; procedure TfrMemoView.SetAlignment(const AValue: TAlignment); begin if Alignment<>AValue then begin BeforeChange; Adjust := (Adjust and not 3) or ord(AValue); AfterChange; end; end; procedure TfrMemoView.SetAutoSize(const AValue: Boolean); begin Flags:=Flags+flAutoSize; end; {----------------------------------------------------------------------------} constructor TfrBandView.Create; begin inherited Create; Typ := gtBand; fFormat := 0; BaseName := 'Band'; Flags := flBandOnFirstPage + flBandOnLastPage; end; procedure TfrBandView.Assign(From: TfrView); begin inherited Assign(From); if From is TfrBandView then begin BandType := TFrBandView(From).BandType; DataSet := TFrBandView(From).DataSet; GroupCondition:=TFrBandView(From).GroupCondition; end; end; procedure TfrBandView.LoadFromStream(Stream: TStream); begin inherited LoadFromStream(Stream); With Stream do begin Read(fBandType,SizeOf(BandType)); fCondition :=ReadString(Stream); fDataSetStr:=ReadString(Stream); end; end; procedure TfrBandView.LoadFromXML(XML: TXMLConfig; Path: String); begin inherited LoadFromXML(XML, Path); RestoreProperty('BandType',XML.GetValue(Path+'BandType/Value','')); // todo chk FCondition := XML.GetValue(Path+'Condition/Value', ''); // todo chk FDatasetStr := XML.GetValue(Path+'DatasetStr/Value', ''); // todo chk end; procedure TfrBandView.SaveToStream(Stream: TStream); begin inherited SaveToStream(Stream); with Stream do begin Write(fBandType,SizeOf(fBandType)); frWriteString(Stream, fCondition); frWriteString(Stream, fDataSetStr); end; end; procedure TfrBandView.SaveToXML(XML: TXMLConfig; Path: String); begin inherited SaveToXML(XML, Path); XML.SetValue(Path+'BandType/Value', GetSaveProperty('BandType')); //Ord(FBandType)); // todo: use symbolic values XML.SetValue(Path+'Condition/Value', FCondition); XML.SetValue(Path+'DatasetStr/Value', FDatasetStr); end; procedure TfrBandView.Draw(aCanvas: TCanvas); var h, oldh: HFont; St : String; begin fFrameWidth := 1; if BandType in [btCrossHeader..btCrossFooter] then begin y := 0; dy := frDesigner.Page.PrnInfo.Pgh; end else begin x := 0; dx := frDesigner.Page.PrnInfo.Pgw; end; BeginDraw(aCanvas); CalcGaps; with Canvas do begin //Brush.Bitmap := SBmp; Brush.Style := bsSolid; Brush.Color:=clBtnFace; FillRect(DRect); Brush.Color:=clLtGray; Brush.Style:=bsDiagCross; FillRect(DRect); frInitFont(Font,clBlack,8,[]); Pen.Width := 1; Pen.Color := clBtnFace; Pen.Style := psSolid; Brush.Style := bsClear; Rectangle(x, y, x + dx + 1, y + dy + 1); Brush.Color := clBtnFace; Brush.Style := bsSolid; if ShowBandTitles then begin if BandType in [btCrossHeader..btCrossFooter] then begin FillRect(Rect(x - 18, y, x, y + 100)); Pen.Color := clBtnShadow; MoveTo(x - 18, y + 98); LineTo(x, y + 98); Pen.Color := clBlack; MoveTo(x - 18, y + 99); LineTo(x, y + 99); Pen.Color := clBtnHighlight; MoveTo(x - 18, y + 99); LineTo(x - 18, y); h := Create90Font(Font); oldh := SelectObject(Handle, h); Brush.Color:=clBtnFace; TextOut(x - 15, y + 94, frBandNames[BandType]); SelectObject(Handle, oldh); DeleteObject(h); end else begin FillRect(Rect(x, y - 18, x + 100, y)); Pen.Color := clBtnShadow; MoveTo(x + 98, y - 18); LineTo(x + 98, y); Pen.Color := clBlack; MoveTo(x + 99, y - 18); LineTo(x + 99, y); st:=frBandNames[BandType]; Brush.Color:=clBtnFace; TextOut(x+4,y-17, frBandNames[BandType]); end; end else begin Brush.Style := bsClear; if BandType in [btCrossHeader..btCrossFooter] then begin h := Create90Font(Font); oldh := SelectObject(Handle, h); Brush.Color:=clBtnFace; TextOut(x + 2, y + 94, frBandNames[BandType]); SelectObject(Handle, oldh); DeleteObject(h); end else begin Brush.Color:=clBtnFace; TextOut(x + 4, y + 2, frBandNames[BandType]); end; end; end; end; function TfrBandView.GetClipRgn(rt: TfrRgnType): HRGN; var R,R1,R2: HRGN; RR : LongInt; begin if not ShowBandTitles then begin Result := inherited GetClipRgn(rt); Exit; end; if rt = rtNormal then R1 := CreateRectRgn(x, y, x + dx + 1, y + dy + 1) else R1 := CreateRectRgn(x - 10, y - 10, x + dx + 10, y + dy + 10); if BandType in [btCrossHeader..btCrossFooter] then R := CreateRectRgn(x - 18, y, x, y + 100) else R := CreateRectRgn(x, y - 18, x + 100, y); R2:=CreateRectRgn(0,0,0,0); RR:=CombineRgn(R2, R, R1, RGN_OR); Result:=R2; DeleteObject(R); DeleteObject(R1); end; function TfrBandView.PointInView(aX,aY: Integer): Boolean; Var Rc : TRect; begin Rc:=Bounds(x, y,dx+1,dy + 1); Result:=((aX>Rc.Left) and (aXRc.Top) and (aY',InttoStr(Rc.Left),') and (',InttoStr(aX),'<',InttoStr(Rc.Right)); DebugLn(') and (',InttoStr(aY),'>',InttoStr(Rc.Top),') and (',InttoStR(aY), '<',InttoStr(Rc.Bottom),')=',BoolToStr(Result)); {$ENDIF} if not Result and ShowBandTitles then begin if BandType in [btCrossHeader..btCrossFooter] then Rc:=Bounds(x-18,y, 18,100) else Rc:=Bounds(x,y-18,100, 18); Result:=((aX>Rc.Left) and (aXRc.Top) and (aY',InttoStr(Rc.Left),') and (',InttoStr(aX),'<', IntToStr(Rc.Right),') and (',IntToStr(aY),'>'); DebugLn(IntToStr(Rc.Top),') and (',InttoStr(aY),'<',IntToStr(Rc.Bottom),')=',BoolToStr(Result)); {$ENDIF} end; end; procedure TfrBandView.DefinePopupMenu(Popup: TPopupMenu); var m: TMenuItem; begin if BandType in [btReportTitle, btReportSummary, btPageHeader, btCrossHeader, btMasterHeader..btSubDetailFooter, btGroupHeader, btGroupFooter] then inherited DefinePopupMenu(Popup); if BandType in [btReportTitle, btReportSummary, btMasterData, btDetailData, btSubDetailData, btMasterFooter, btDetailFooter, btSubDetailFooter, btGroupHeader] then begin m := TMenuItem.Create(Popup); m.Caption := sFormNewPage; m.OnClick := @P1Click; m.Checked := (Flags and flBandNewPageAfter) <> 0; Popup.Items.Add(m); end; if BandType in [btMasterData, btDetailData] then begin m := TMenuItem.Create(Popup); m.Caption := sPrintIfSubsetEmpty; m.OnClick := @P2Click; m.Checked := (Flags and flBandPrintIfSubsetEmpty) <> 0; Popup.Items.Add(m); end; if BandType in [btReportTitle, btReportSummary, btMasterHeader..btSubDetailFooter, btGroupHeader, btGroupFooter] then begin m := TMenuItem.Create(Popup); m.Caption := sBreaked; m.OnClick := @P3Click; m.Checked := (Flags and flBandPageBreak) <> 0; Popup.Items.Add(m); end; if BandType in [btPageHeader, btPageFooter] then begin m := TMenuItem.Create(Popup); m.Caption := sOnFirstPage; m.OnClick := @P4Click; m.Checked := (Flags and flBandOnFirstPage) <> 0; Popup.Items.Add(m); end; if BandType = btPageFooter then begin m := TMenuItem.Create(Popup); m.Caption := sOnLastPage; m.OnClick := @P5Click; m.Checked := (Flags and flBandOnLastPage) <> 0; Popup.Items.Add(m); end; if BandType in [btMasterHeader, btDetailHeader, btSubDetailHeader, btCrossHeader, btGroupHeader] then begin m := TMenuItem.Create(Popup); m.Caption := sRepeatHeader; m.OnClick := @P6Click; m.Checked := (Flags and flBandRepeatHeader) <> 0; Popup.Items.Add(m); end; end; procedure TfrBandView.P1Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flBandNewPageAfter) + Word(Checked) * flBandNewPageAfter; end; end; end; procedure TfrBandView.P2Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flBandPrintifSubsetEmpty) + Word(Checked) * flBandPrintifSubsetEmpty; end; end; end; procedure TfrBandView.P3Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flBandPageBreak) + Word(Checked) * flBandPageBreak; end; end; end; procedure TfrBandView.P4Click(Sender: TObject); begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; Flags := (Flags and not flBandOnFirstPage) + Word(Checked) * flBandOnFirstPage; end; end; procedure TfrBandView.P5Click(Sender: TObject); begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; Flags := (Flags and not flBandOnLastPage) + Word(Checked) * flBandOnLastPage; end; end; procedure TfrBandView.P6Click(Sender: TObject); begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; Flags := (Flags and not flBandRepeatHeader) + Word(Checked) * flBandRepeatHeader; end; end; {----------------------------------------------------------------------------} constructor TfrSubReportView.Create; begin inherited Create; Typ := gtSubReport; BaseName := 'SubReport'; end; procedure TfrSubReportView.Assign(From: TfrView); begin inherited Assign(From); SubPage := (From as TfrSubReportView).SubPage; end; procedure TfrSubReportView.Draw(aCanvas: TCanvas); begin BeginDraw(aCanvas); fFrameWidth := 1; CalcGaps; with aCanvas do begin Font.Name := 'Arial'; Font.Style := []; Font.Size := 8; Font.Color := clBlack; Font.Charset := frCharset; Pen.Width := 1; Pen.Color := clBlack; Pen.Style := psSolid; Brush.Color := clWhite; Rectangle(x, y, x + dx + 1, y + dy + 1); Brush.Style := bsClear; TextRect(DRect, x + 2, y + 2, sSubReportOnPage + ' ' + IntToStr(SubPage + 1)); end; RestoreCoord; end; procedure TfrSubReportView.DefinePopupMenu(Popup: TPopupMenu); begin // no specific items in popup menu end; procedure TfrSubReportView.LoadFromStream(Stream: TStream); begin inherited LoadFromStream(Stream); Stream.Read(SubPage, 4); end; procedure TfrSubReportView.LoadFromXML(XML: TXMLConfig; Path: String); begin inherited LoadFromXML(XML, Path); SubPage := XML.GetValue(Path+'SubPage/Value', 0); // todo chk end; procedure TfrSubReportView.SaveToStream(Stream: TStream); begin inherited SaveToStream(Stream); Stream.Write(SubPage, 4); end; procedure TfrSubReportView.SaveToXML(XML: TXMLConfig; Path: String); begin inherited SaveToXML(XML, Path); XML.SetValue(Path+'SubPage/Value', SubPage); end; {----------------------------------------------------------------------------} constructor TfrPictureView.Create; begin inherited Create; Typ := gtPicture; fPicture := TPicture.Create; Flags := flStretched + flPictRatio; BaseName := 'Picture'; end; destructor TfrPictureView.Destroy; begin Picture.Free; inherited Destroy; end; procedure TfrPictureView.Assign(From: TfrView); begin inherited Assign(From); Picture.Assign(TfrPictureView(From).Picture); end; procedure TfrPictureView.Draw(aCanvas: TCanvas); var r: TRect; kx, ky: Double; w, h, w1, h1: Integer; procedure PrintBitmap(DestRect: TRect; Bitmap: TBitmap); var BitmapHeader: pBitmapInfo; BitmapImage: Pointer; HeaderSize: DWord; ImageSize: DWord; begin aCanvas.StretchDraw(DestRect, Bitmap); //** {GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize); GetMem(BitmapHeader, HeaderSize); GetMem(BitmapImage, ImageSize); try GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^); StretchDIBits( aCanvas.Handle, DestRect.Left, DestRect.Top, // Destination Origin DestRect.Right - DestRect.Left, // Destination Width DestRect.Bottom - DestRect.Top, // Destination Height 0, 0, // Source Origin Bitmap.Width, Bitmap.Height, // Source Width & Height BitmapImage, TBitmapInfo(BitmapHeader^), DIB_RGB_COLORS, SRCCOPY) finally FreeMem(BitmapHeader); FreeMem(BitmapImage) end; } end; begin BeginDraw(aCanvas); CalcGaps; with aCanvas do begin ShowBackground; if ((Picture.Graphic = nil) or Picture.Graphic.Empty) and (DocMode = dmDesigning) then begin Font.Name := 'Arial'; Font.Size := 8; Font.Style := []; Font.Color := clBlack; Font.Charset := frCharset; TextOut(x + 2, y + 2, sPicture); end else if not ((Picture.Graphic = nil) or Picture.Graphic.Empty) then begin if (Flags and flStretched) <> 0 then begin r := DRect; if (Flags and flPictRatio) <> 0 then begin kx := dx / Picture.Width; ky := dy / Picture.Height; if kx < ky then r := Rect(DRect.Left, DRect.Top, DRect.Right, DRect.Top + Round(Picture.Height * kx)) else r := Rect(DRect.Left, DRect.Top, DRect.Left + Round(Picture.Width * ky), DRect.Bottom); w := DRect.Right - DRect.Left; h := DRect.Bottom - DRect.Top; w1 := r.Right - r.Left; h1 := r.Bottom - r.Top; if (Flags and flPictCenter) <> 0 then OffsetRect(r, (w - w1) div 2, (h - h1) div 2); end; if IsPrinting and (Picture.Graphic is TBitmap) then PrintBitmap(r, Picture.Bitmap) else StretchDraw(r, Picture.Graphic); end else begin r := DRect; if (Flags and flPictCenter) <> 0 then begin w := DRect.Right - DRect.Left; h := DRect.Bottom - DRect.Top; OffsetRect(r, (w - Picture.Width) div 2, (h - Picture.Height) div 2); end; Draw(r.Left, r.Top, Picture.Graphic) end; end; ShowFrame; end; RestoreCoord; end; const pkNone = 0; pkBitmap = 1; //** pkMetafile = 2; pkIcon = 3; pkJPEG = 4; pkPNG = 5; procedure StreamToXML(XML: TXMLConfig; Path: String; Stream: TStream); var Buf: Array[0..1023] of byte; S: String; i: integer; procedure WriteBuf(Count: Integer); var j: Integer; begin for j:=0 to Count-1 do S := S + IntToHex(Buf[j], 2); end; begin XML.SetValue(Path+'Size/Value', Stream.Size); S := ''; for i:=1 to Stream.Size div SizeOf(Buf) do begin Stream.Read(Buf, SizeOf(buf)); WriteBuf(SizeOf(Buf)); end; i := Stream.Size mod SizeOf(Buf); if i>0 then begin Stream.Read(Buf, i); Writebuf(i); end; XML.SetValue(Path+'Data/Value', S); end; procedure XMLToStream(XML: TXMLConfig; Path: String; Stream: TStream); var S: String; i,Size,cd: integer; B: Byte; begin Size := XML.GetValue(Path+'Size/Value', 0); if Size>0 then begin S := XML.GetValue(Path+'Data/Value', ''); if S<>'' then for i:=1 to Size do begin Val('$'+S[i*2-1]+S[i*2], B, cd); Stream.Write(B, 1); end; end; end; procedure TfrPictureView.LoadFromStream(Stream: TStream); var b: Byte; n: Integer; Graphic: TGraphic; begin inherited LoadFromStream(Stream); Stream.Read(b, 1); Stream.Read(n, 4); Graphic := PictureTypeToGraphic(b); Picture.Graphic := Graphic; if Graphic <> nil then begin Graphic.Free; Picture.Graphic.LoadFromStream(Stream); end; Stream.Seek(n, soFromBeginning); end; procedure TfrPictureView.LoadFromXML(XML: TXMLConfig; Path: String); var b: Byte; m: TMemoryStream; Graphic: TGraphic; begin inherited LoadFromXML(XML, Path); b := XML.GetValue(Path+'Picture/Type/Value', pkNone); Graphic := PictureTypeToGraphic(b); Picture.Graphic := Graphic; if Graphic <> nil then begin Graphic.Free; M := TMemoryStream.Create; try XMLToStream(XML, Path+'Picture/', M); M.Position := 0; Picture.Graphic.LoadFromStream(M); finally M.Free; end; end; end; procedure TfrPictureView.SaveToStream(Stream: TStream); var b: Byte; n, o: Integer; begin inherited SaveToStream(Stream); b := GetPictureType; Stream.Write(b, 1); n := Stream.Position; Stream.Write(n, 4); if b <> pkNone then Picture.Graphic.SaveToStream(Stream); o := Stream.Position; Stream.Seek(n, soFromBeginning); Stream.Write(o, 4); Stream.Seek(0, soFromEnd); end; procedure TfrPictureView.SaveToXML(XML: TXMLConfig; Path: String); var b: Byte; n, o: Integer; m: TMemoryStream; begin inherited SaveToXML(XML, Path); b := GetPictureType; XML.SetValue(Path+'Picture/Type/Value', b); if b <> pkNone then begin M := TMemoryStream.Create; try Picture.Graphic.SaveToStream(M); M.Position:=0; StreamToXML(XML, Path+'Picture/', M); finally M.Free; end; end; end; procedure TfrPictureView.GetBlob(b: TfrTField); var s: TStream; GraphExt: string; gc: TGraphicClass; AGraphic: TGraphic; begin if b.IsNull then Picture.Assign(nil) else begin // todo: TBlobField.AssignTo is not implemented yet s := TDataset(FDataset).CreateBlobStream(TField(b),bmRead); if s.Size = 0 then Picture.Clear else begin try GraphExt := s.ReadAnsiString; gc := GetGraphicClassForFileExtension(GraphExt); if assigned(gc) then begin AGraphic := gc.Create; AGraphic.LoadFromStream(s); Picture.Assign(AGraphic); end; finally if assigned(AGraphic) then AGraphic.Free; s.Free; end end; end; end; procedure TfrPictureView.DefinePopupMenu(Popup: TPopupMenu); var m: TMenuItem; begin inherited DefinePopupMenu(Popup); m := TMenuItem.Create(Popup); m.Caption := sPictureCenter; m.OnClick := @P1Click; m.Checked := (Flags and flPictCenter) <> 0; Popup.Items.Add(m); m := TMenuItem.Create(Popup); m.Caption := sKeepAspectRatio; m.OnClick := @P2Click; m.Enabled := (Flags and flStretched) <> 0; if m.Enabled then m.Checked := (Flags and flPictRatio) <> 0; Popup.Items.Add(m); end; procedure TfrPictureView.P1Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t := TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flPictCenter) + Word(Checked) * flPictCenter; end; end; frDesigner.AfterChange; end; procedure TfrPictureView.P2Click(Sender: TObject); var i: Integer; t: TfrView; begin frDesigner.BeforeChange; with Sender as TMenuItem do begin Checked := not Checked; for i := 0 to frDesigner.Page.Objects.Count - 1 do begin t :=TfrView(frDesigner.Page.Objects[i]); if t.Selected then t.Flags := (t.Flags and not flPictRatio) + Word(Checked) * flPictRatio; end; end; frDesigner.AfterChange; end; function TfrPictureView.GetPictureType: byte; begin result := pkNone; if Picture.Graphic <> nil then if Picture.Graphic is TPortableNetworkGraphic then result := pkPNG else if Picture.Graphic is TJPEGImage then result := pkJPEG else if Picture.Graphic is TIcon then result := pkIcon else if Picture.Graphic is TBitmap then result := pkBitmap; end; function TfrPictureView.PictureTypeToGraphic(b: Byte): TGraphic; begin result := nil; case b of pkBitmap: result := TBitmap.Create; pkIcon: result := TIcon.Create; pkJPEG: result := TJPEGImage.Create; pkPNG: result := TPortableNetworkGraphic.Create; end; end; procedure TfrPictureView.SetPicture(const AValue: TPicture); begin BeforeChange; fPicture := AValue; AfterChange; end; class function TfrPictureView.GetFilter: string; procedure AddFilter(G:TGraphicClass); var S: string; begin if result<>'' then Result := Result + ';'; Result := Result + '*.' + StringReplace(G.GetFileExtensions, ';', ';*.', [rfReplaceAll]); end; begin Result := ''; AddFilter(TBitmap); AddFilter(TIcon); AddFilter(TJpegImage); AddFilter(TPortableNetworkGraphic); Result := '(' + Result + ')|'+Result; end; {----------------------------------------------------------------------------} constructor TfrLineView.Create; begin inherited Create; Typ := gtLine; fFrames:=[frbLeft]; BaseName := 'Line'; end; procedure TfrLineView.Draw(aCanvas: TCanvas); begin BeginDraw(aCanvas); if dx > dy then begin dy := 0; fFrames:=[frbTop]; end else begin dx := 0; fFrames:=[frbLeft]; end; CalcGaps; ShowFrame; RestoreCoord; end; procedure TfrLineView.DefinePopupMenu(Popup: TPopupMenu); begin // no specific items in popup menu end; function TfrLineView.GetClipRgn(rt: TfrRgnType): HRGN; var bx, by, bx1, by1, dd: Integer; begin bx := x; by := y; bx1 := x + dx + 1; by1 := y + dy + 1; if FrameStyle<>frsDouble then dd := Round(FrameWidth / 2) else dd := Round(FrameWidth * 1.5); if Frames=[frbLeft] then begin Dec(bx, dd); Inc(bx1, dd); end else begin Dec(by, dd); Inc(by1, dd); end; if rt = rtNormal then Result := CreateRectRgn(bx, by, bx1, by1) else Result := CreateRectRgn(bx - 10, by - 10, bx1 + 10, by1 + 10); end; {----------------------------------------------------------------------------} constructor TfrBand.Create(ATyp: TfrBandType; AParent: TfrPage); begin inherited Create; Typ := ATyp; Parent := AParent; Objects := TList.Create; Values := TStringList.Create; Next := nil; Positions[psLocal] := 1; Positions[psGlobal] := 1; Visible:=True; end; destructor TfrBand.Destroy; begin if Next <> nil then Next.Free; Objects.Free; Values.Free; if DataSet <> nil then DataSet.Exit; if IsVirtualDS then DataSet.Free; if VCDataSet <> nil then VCDataSet.Exit; if IsVirtualVCDS then VCDataSet.Free; inherited Destroy; end; procedure TfrBand.InitDataSet(Desc: String); begin if Typ = btGroupHeader then GroupCondition := Desc else if Pos(';', Desc) = 0 then CreateDS(Desc, DataSet, IsVirtualDS); if (Typ = btMasterData) and (Dataset = nil) and (CurReport.ReportType = rtSimple) then DataSet := CurReport.Dataset; end; procedure TfrBand.DoError; var i: Integer; begin ErrorFlag := True; ErrorStr := sErrorOccured; for i := 0 to CurView.Memo.Count - 1 do ErrorStr := ErrorStr + #13 + CurView.Memo[i]; ErrorStr := ErrorStr + #13 + sDoc + ' ' + CurReport.Name + #13 + sBand; // + ' ' + frBandNames[Integer(CurView.Parent.Typ)]; MasterReport.Terminated := True; end; function TfrBand.CalcHeight: Integer; var Bnd: TfrBand; DS : TfrDataSet; ddx: Integer; BM : Pointer; function SubDoCalcHeight(CheckAll: Boolean): Integer; var i, h: Integer; t: TfrView; begin CurBand := Self; AggrBand := Self; Result := dy; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); t.olddy := t.dy; if t is TfrStretcheable then if (t.Parent = Self) or CheckAll then begin h := TfrStretcheable(t).CalcHeight + t.y; if h > Result then Result := h; if CheckAll then TfrStretcheable(t).DrawMode := drAll; end end; end; begin Result := dy; if HasCross and (Typ <> btPageFooter) then begin Parent.ColPos := 1; CurReport.InternalOnBeginColumn(Self); if Parent.BandExists(Parent.Bands[btCrossData]) then begin Bnd := Parent.Bands[btCrossData]; if Bnd.DataSet <> nil then DS := Bnd.DataSet else DS := VCDataSet; BM:=DS.GetBookMark; DS.DisableControls; try DS.First; while not DS.Eof do begin ddx := 0; CurReport.InternalOnPrintColumn(Parent.ColPos, ddx); CalculatedHeight := SubDoCalcHeight(True); if CalculatedHeight > Result then Result := CalculatedHeight; Inc(Parent.ColPos); DS.Next; if MasterReport.Terminated then break; end; finally DS.GotoBookMark(BM); DS.FreeBookMark(BM); DS.EnableControls; end; end; end else Result := SubDoCalcHeight(False); CalculatedHeight := Result; end; procedure TfrBand.StretchObjects(MaxHeight: Integer); var i: Integer; t: TfrView; begin for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if (t is TfrStretcheable) or (t is TfrLineView) then if (t.Flags and flStretched) <> 0 then t.dy := MaxHeight - t.y; end; end; procedure TfrBand.UnStretchObjects; var i: Integer; t: TfrView; begin for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); t.dy := t.olddy; end; end; procedure TfrBand.DrawObject(t: TfrView); var ox,oy: Integer; begin {$IFDEF DebugLR} DebugLn('%sTfrBand.DrawObject INI t=%s:%s',[sspc,dbgsname(t),t.name]); IncSpc(1); {$ENDIF} CurPage := Parent; CurBand := Self; AggrBand := Self; try if (t.Parent = Self) and not DisableDrawing then begin ox := t.x; Inc(t.x, Parent.XAdjust - Parent.LeftMargin); oy := t.y; Inc(t.y, y); t.Print(MasterReport.EMFPages[PageNo]^.Stream); t.x := ox; t.y := oy; if (t is TfrMemoView) and (TfrMemoView(t).DrawMode in [drAll, drAfterCalcHeight]) then Parent.AfterPrint; end; except on exception do DoError; end; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrBand.DrawObject DONE t=%s:%s',[sspc,dbgsname(t),t.name]); {$ENDIF} end; procedure TfrBand.PrepareSubReports; var i: Integer; t: TfrView; Page: TfrPage; begin for i := SubIndex to Objects.Count - 1 do begin t :=TfrView(Objects[i]); Page := CurReport.Pages[(t as TfrSubReportView).SubPage]; Page.Mode := pmBuildList; Page.FormPage; Page.CurY := y + t.y; Page.CurBottomY := Parent.CurBottomY; Page.XAdjust := Parent.XAdjust + t.x; Page.ColCount := 1; Page.PlayFrom := 0; EOFArr[i - SubIndex] := False; end; Parent.LastBand := nil; end; procedure TfrBand.DoSubReports; var i: Integer; t: TfrView; Page: TfrPage; begin repeat if not EOFReached then for i := SubIndex to Objects.Count - 1 do begin t :=TfrView(Objects[i]); Page := CurReport.Pages[(t as TfrSubReportView).SubPage]; Page.CurY := Parent.CurY; Page.CurBottomY := Parent.CurBottomY; end; EOFReached := True; MaxY := Parent.CurY; for i := SubIndex to Objects.Count - 1 do begin if not EOFArr[i - SubIndex] then begin t :=TfrView(Objects[i]); Page := CurReport.Pages[(t as TfrSubReportView).SubPage]; if Page.PlayRecList then EOFReached := False else begin EOFArr[i - SubIndex] := True; if Page.CurY > MaxY then MaxY := Page.CurY; end; end; end; if not EOFReached then begin if Parent.Skip then begin Parent.LastBand := Self; Exit; end else Parent.NewPage; end; until EOFReached or MasterReport.Terminated; for i := SubIndex to Objects.Count - 1 do begin t :=TfrView(Objects[i]); Page := CurReport.Pages[(t as TfrSubReportView).SubPage]; Page.ClearRecList; end; Parent.CurY := MaxY; Parent.LastBand := nil; end; function TfrBand.DrawObjects: Boolean; var i: Integer; t: TfrView; begin Result := False; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if t.Typ = gtSubReport then begin SubIndex := i; Result := True; PrepareSubReports; DoSubReports; break; end; DrawObject(t); if MasterReport.Terminated then break; end; end; procedure TfrBand.DrawCrossCell(Parnt: TfrBand; CurX: Integer); var i, sfx, sfy: Integer; t: TfrView; begin CurBand := Self; CurBand.Positions[psGlobal] := Parnt.Positions[psGlobal]; CurBand.Positions[psLocal] := Parnt.Positions[psLocal]; if Typ = btCrossData then AggrBand := Parnt; try for i := 0 to Objects.Count - 1 do begin t := TfrView(Objects[i]); if Parnt.Objects.IndexOf(t) <> -1 then if not DisableDrawing then begin sfx := t.x; Inc(t.x, CurX); sfy := t.y; Inc(t.y, Parnt.y); t.Print(MasterReport.EMFPages[PageNo]^.Stream); if (t is TfrMemoView) and (TfrMemoView(t).DrawMode in [drAll, drAfterCalcHeight]) then Parent.AfterPrint; t.Parent := Self; t.x := sfx; t.y := sfy; end else begin CurView := t; frInterpretator.DoScript(t.Script); end; end; except on E: exception do DoError; //(E); end; end; procedure TfrBand.DrawCross; var Bnd : TfrBand; sfpage : Integer; CurX, ddx : Integer; DS : TfrDataSet; BM : Pointer; procedure CheckColumnPageBreak(ddx: Integer); var sfy: Integer; b: TfrBand; begin if CurX + ddx > Parent.RightMargin then begin Inc(ColumnXAdjust, CurX - Parent.LeftMargin); CurX := Parent.LeftMargin; Inc(PageNo); if PageNo >= MasterReport.EMFPages.Count then begin MasterReport.EMFPages.Add(Parent); sfy := Parent.CurY; Parent.ShowBand(Parent.Bands[btOverlay]); Parent.CurY := Parent.TopMargin; if (sfPage <> 0) or ((Parent.Bands[btPageHeader].Flags and flBandOnFirstPage) <> 0) then Parent.ShowBand(Parent.Bands[btPageHeader]); Parent.CurY := sfy; CurReport.InternalOnProgress(PageNo); end; if Parent.BandExists(Parent.Bands[btCrossHeader]) then if (Parent.Bands[btCrossHeader].Flags and flBandRepeatHeader) <> 0 then begin b := Parent.Bands[btCrossHeader]; b.DrawCrossCell(Self, Parent.LeftMargin); CurX := Parent.LeftMargin + b.dx; end; end; end; begin ColumnXAdjust := 0; Parent.ColPos := 1; CurX := 0; sfpage := PageNo; if Typ = btPageFooter then Exit; IsColumns := True; CurReport.InternalOnBeginColumn(Self); if Parent.BandExists(Parent.Bands[btCrossHeader]) then begin Bnd := Parent.Bands[btCrossHeader]; Bnd.DrawCrossCell(Self, Bnd.x); CurX := Bnd.x + Bnd.dx; end; if Parent.BandExists(Parent.Bands[btCrossData]) then begin Bnd := Parent.Bands[btCrossData]; if CurX = 0 then CurX := Bnd.x; if Bnd.DataSet <> nil then DS := Bnd.DataSet else DS := VCDataSet; if DS <> nil then begin BM:=DS.GetBookMark; DS.DisableControls; try DS.First; while not DS.Eof do begin ddx := Bnd.dx; CurReport.InternalOnPrintColumn(Parent.ColPos, ddx); CheckColumnPageBreak(ddx); Bnd.DrawCrossCell(Self, CurX); if Typ in [btMasterData, btDetailData, btSubdetailData] then Parent.DoAggregate([btPageFooter, btMasterFooter, btDetailFooter, btSubDetailFooter, btGroupFooter, btCrossFooter, btReportSummary]); Inc(CurX, ddx); Inc(Parent.ColPos); DS.Next; if MasterReport.Terminated then break; end; finally DS.GotoBookMark(BM); DS.FreeBookMark(BM); DS.EnableControls; end; end; end; if Parent.BandExists(Parent.Bands[btCrossFooter]) then begin Bnd := Parent.Bands[btCrossFooter]; if CurX = 0 then CurX := Bnd.x; CheckColumnPageBreak(Bnd.dx); AggrBand := Bnd; Bnd.DrawCrossCell(Self, CurX); Bnd.InitValues; end; PageNo := sfpage; ColumnXAdjust := 0; IsColumns := False; end; function TfrBand.CheckPageBreak(ay, ady: Integer; PBreak: Boolean): Boolean; begin {$IFDEF DebugLR} DebugLn('%sTfrBand.CheckPageBreak INI ay=%d ady=%d Pbreak=%d', [sspc,ay,ady,ord(pbreak)]); IncSpc(1); {$ENDIF} Result := False; with Parent do begin {$IFDEF DebugLR} DebugLn('%say+dy+ady=%d CurBottomY=%d', [sspc, ay+Bands[btColumnFooter].dy+ady,CurBottomY]); {$ENDIF} if not RowsLayout then begin if ay + Bands[btColumnFooter].dy + ady > CurBottomY then begin if not PBreak then NewColumn(Self); Result := True; end; end; end; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrBand.CheckPageBreak END ay=%d ady=%d Result=%d', [sspc,ay,ady,ord(Result)]); {$ENDIF} end; function TfrBand.CheckNextColumn: boolean; var BandHeight: Integer; begin with Parent do begin if (CurColumn=0) and (typ=btMasterData) then begin BandHeight := DoCalcHeight; {$IFDEF DebugLR} DebugLn('%sTfrBand.CheckNextColumn INI CurY=%d BHeight=%d CurY+BH=%d CurBottomY=%d', [sspc,CurY,BandHeight,CurY+BandHeight,CurBottomY]); {$ENDIF} // check left height space when on last column if CurY + BandHeight>CurBottomY then NewPage; {$IFDEF DebugLR} DebugLn('%sTfrBand.CheckNextColumn END CurY=%d BHeight=%d CurY+BH=%d CurBottomY=%d', [sspc,CurY,BandHeight,CurY+BandHeight,CurBottomY]); {$ENDIF} end; end; end; procedure TfrBand.DrawPageBreak; var i: Integer; newDy, oldy, olddy, aMaxy: Integer; t: TfrView; Flag: Boolean; procedure CorrY(t: TfrView; dy: Integer); var i: Integer; t1: TfrView; begin for i := 0 to Objects.Count - 1 do begin t1 :=TfrView(Objects[i]); if t1 <> t then if (t1.y > t.y + t.dy) and (t1.x >= t.x) and (t1.x <= t.x + t.dx) then Inc(t1.y, dy); end; end; begin {$IFDEF DebugLR} DebugLn('%sDrawPageBreak INI y=%d Maxdy',[sspc,y,maxdy]); IncSpc(1); {$ENDIF} for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); t.Selected := True; t.OriginalRect := Rect(t.x, t.y, t.dx, t.dy); end; if not CheckPageBreak(y, maxdy, True) then DrawObjects else begin for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if t is TfrStretcheable then TfrStretcheable(t).ActualHeight := 0; if t is TfrMemoView then begin TfrMemoView(t).CalcHeight; // wraps a memo onto separate lines t.Memo1.Assign(SMemo); end; end; repeat newDy := Parent.CurBottomY - Parent.Bands[btColumnFooter].dy - y - 2; aMaxy := 0; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if t.Selected then if (t.y >= 0) and (t.y < newdy) then if (t.y + t.dy < newdy) then begin if aMaxy < t.y + t.dy then aMaxy := t.y + t.dy; DrawObject(t); t.Selected := False; end else begin if t is TfrStretcheable then begin olddy := t.dy; t.dy := newdy - t.y + 1; Inc(TfrStretcheable(t).ActualHeight, t.dy); if t.dy > TfrStretcheable(t).MinHeight then begin TfrStretcheable(t).DrawMode := drPart; DrawObject(t); end; t.dy := olddy; end else t.y := newdy end else if t is TfrStretcheable then if (t.y < 0) and (t.y + t.dy >= 0) then if t.y + t.dy < dy then begin oldy := t.y; olddy := t.dy; t.dy := t.y + t.dy; t.y := 0; if t.dy > TfrStretcheable(t).MinHeight div 2 then begin t.dy := TfrStretcheable(t).RemainHeight + t.gapy * 2 + 1; Inc(TfrStretcheable(t).ActualHeight, t.dy - 1); if aMaxy < t.y + t.dy then aMaxy := t.y + t.dy; TfrStretcheable(t).DrawMode := drPart; DrawObject(t); end; t.y := oldy; t.dy := olddy; CorrY(t, TfrStretcheable(t).ActualHeight - t.dy); t.Selected := False; end else begin oldy := t.y; olddy := t.dy; t.y := 0; t.dy := newdy; Inc(TfrStretcheable(t).ActualHeight, t.dy); TfrStretcheable(t).DrawMode := drPart; DrawObject(t); t.y := oldy; t.dy := olddy; end; end; Flag := False; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if t.Selected then Flag := True; Dec(t.y, newdy); end; if Flag then CheckPageBreak(y, 10000, False); y := Parent.CurY; if MasterReport.Terminated then break; until not Flag; maxdy := aMaxy; end; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); t.y := t.OriginalRect.Top; t.dy := t.OriginalRect.Bottom; end; Inc(Parent.CurY, maxdy); {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sDrawPageBreak END Parent.CurY=%d',[sspc,Parent.CurY]); {$ENDIF} end; function TfrBand.HasCross: Boolean; var i: Integer; t: TfrView; begin Result := False; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); if t.Parent <> Self then begin Result := True; break; end; end; end; procedure TfrBand.DoDraw; var sfy, sh: Integer; UseY, WasSub: Boolean; begin if Objects.Count = 0 then Exit; sfy := y; UseY := not (Typ in [btPageFooter, btOverlay, btNone]); if UseY then y := Parent.CurY; {$IFDEF DebugLR} DebugLn('%sTfrBand.DoDraw INI sfy=%d y=%d dy=%d XAdjust=%d CurY=%d Stretch=%d PageBreak=%d', [sspc, sfy, y, dy, Parent.XAdjust, parent.cury, Ord(Stretched), Ord(PageBreak)]); IncSpc(1); {$ENDIF} if Stretched then begin sh := CalculatedHeight; // sh := CalcHeight; if sh > dy then StretchObjects(sh); maxdy := sh; if not PageBreak then CheckPageBreak(y, sh, False); y := Parent.CurY; WasSub := False; if PageBreak then begin DrawPageBreak; sh := 0; end else begin WasSub := DrawObjects; if HasCross then DrawCross; end; UnStretchObjects; if not WasSub then Inc(Parent.CurY, sh); end else begin if UseY then begin if not PageBreak then CheckPageBreak(y, dy, False); y := Parent.CurY; end; if PageBreak then begin maxdy := CalculatedHeight; // maxdy := CalcHeight; DrawPageBreak; end else begin WasSub := DrawObjects; if HasCross then DrawCross; if UseY and not WasSub then begin if (not Parent.RowsLayout) or (Parent.CurColumn=Parent.ColCount-1) then Inc(Parent.CurY, dy); end; end; end; y := sfy; if Typ in [btMasterData, btDetailData, btSubDetailData] then Parent.DoAggregate([btPageFooter, btMasterFooter, btDetailFooter, btSubDetailFooter, btGroupFooter, btReportSummary]); {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrBand.DoDraw END sfy=%d y=%d dy=%d xadjust=%d CurY=%d', [sspc, sfy, y, dy, parent.xadjust, parent.cury]); {$ENDIF} end; function TfrBand.DoCalcHeight: Integer; var b: TfrBand; begin if (Typ in [btMasterData, btDetailData, btSubDetailData]) and (Next <> nil) and (Next.Dataset = nil) then begin b := Self; Result := 0; repeat Result := Result + b.CalcHeight; b := b.Next; until b = nil; end else begin Result := dy; CalculatedHeight := dy; if Stretched then Result := CalcHeight; end; end; function TfrBand.Draw: Boolean; var b: TfrBand; begin {$IFDEF debugLr} DebugLn('%sTFrBand.Draw INI %s:%s y=%d vis=%s',[sspc, Name, ClassName,y,BoolToStr(Visible,true)]); IncSpc(1); {$endif} Result := False; CurView := View; CurBand := Self; AggrBand := Self; CalculatedHeight := -1; ForceNewPage := False; ForceNewColumn := False; if Assigned(CurReport.FOnBeginBand) then CurReport.FOnBeginBand(Self); frInterpretator.DoScript(Script); if Parent.RowsLayout then begin if Visible then begin if Objects.Count > 0 then begin if not (Typ in [btPageFooter, btOverlay, btNone]) then begin if Parent.Skip then exit else CheckNextColumn; end; EOFReached := True; // only masterdata band supported in RowsLayout columns report if typ=btMasterData then begin DoDraw; Parent.NextColumn(Self); end; if not EOFReached then Result := True; end; end; end else begin // new page was requested in script if ForceNewPage then begin Parent.CurColumn := Parent.ColCount - 1; Parent.NewColumn(Self); end; if ForceNewColumn then Parent.NewColumn(Self); if Visible then begin if Typ = btColumnHeader then Parent.LastStaticColumnY := Parent.CurY; if Typ = btPageFooter then y := Parent.CurBottomY; if Objects.Count > 0 then begin if not (Typ in [btPageFooter, btOverlay, btNone]) then if (Parent.CurY + DoCalcHeight > Parent.CurBottomY) and not PageBreak then begin Result := True; if Parent.Skip then Exit else CheckPageBreak(0, 10000, False); end; EOFReached := True; // dealing with multiple bands if (Typ in [btMasterData, btDetailData, btSubDetailData]) and (Next <> nil) and (Next.Dataset = nil) and (DataSet <> nil) then begin b := Self; repeat b.DoDraw; b := b.Next; until b = nil; end else begin DoDraw; if not (Typ in [btMasterData, btDetailData, btSubDetailData, btGroupHeader]) and NewPageAfter then Parent.NewPage; end; if not EOFReached then Result := True; end; end // if band is not visible, just performing aggregate calculations // relative to it else if Typ in [btMasterData, btDetailData, btSubDetailData] then Parent.DoAggregate([btPageFooter, btMasterFooter, btDetailFooter, btSubDetailFooter, btGroupFooter, btReportSummary]); // check if multiple pagefooters (in cross-tab report) - resets last of them if not DisableInit then if (Typ <> btPageFooter) or (PageNo = MasterReport.EMFPages.Count - 1) then InitValues; end; if Assigned(CurReport.FOnEndBand) then CurReport.FOnEndBand(Self); {$IFDEF debugLr} IncSpc(-1); DebugLn('%sTFrBand.Draw END %s y=%d PageNo=%d',[sspc, dbgsname(self),y, PageNo]); {$endif} end; procedure TfrBand.InitValues; var b: TfrBand; begin if Typ = btGroupHeader then begin b := Self; while b <> nil do begin if b.FooterBand <> nil then begin b.FooterBand.Values.Clear; b.FooterBand.Count := 0; end; b.LastGroupValue := frParser.Calc(b.GroupCondition); b := b.Next; end; end else begin Values.Clear; Count := 0; end end; procedure TfrBand.DoAggregate; var i: Integer; t: TfrView; s: String; v: Boolean; begin for i := 0 to Values.Count - 1 do begin s := Values[i]; Values[i] := Copy(s, 1, Pos('=', s) - 1) + '=0' + Copy(s, Pos('=', s) + 2, 255); end; v := Visible; Visible := False; AggrBand := Self; for i := 0 to Objects.Count - 1 do begin t :=TfrView(Objects[i]); CurView := t; if t is TfrMemoView then TfrMemoView(t).ExpandVariables; end; Visible := v; Inc(Count); end; {----------------------------------------------------------------------------} type TfrBandParts = (bpHeader, bpData, bpFooter); const MAXBNDS = 3; Bnds: Array[1..MAXBNDS, TfrBandParts] of TfrBandType = ((btMasterHeader, btMasterData, btMasterFooter), (btDetailHeader, btDetailData, btDetailFooter), (btSubDetailHeader, btSubDetailData, btSubDetailFooter)); constructor TfrPage.Create(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation); begin Self.Create; ChangePaper(ASize, AWidth, AHeight, AOr); PrintToPrevPage := False; UseMargins := True; end; constructor TfrPage.CreatePage; begin self.Create; end; destructor TfrPage.Destroy; begin Clear; Objects.Free; RTObjects.Free; List.Free; fMargins.Free; inherited Destroy; end; procedure TfrPage.ChangePaper(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation); begin try Prn.SetPrinterInfo(ASize, AWidth, AHeight, AOr); Prn.FillPrnInfo(PrnInfo); except on E:exception do begin Prn.SetPrinterInfo($100, AWidth, AHeight, AOr); Prn.FillPrnInfo(PrnInfo); end; end; pgSize := Prn.PaperSize; Width := Prn.PaperWidth; Height := Prn.PaperHeight; Orientation:= Prn.Orientation; end; procedure TfrPage.Clear; begin while Objects.Count > 0 do Delete(0); end; procedure TfrPage.Delete(Index: Integer); begin TfrView(Objects[Index]).Free; Objects.Delete(Index); end; function TfrPage.FindObjectByID(ID: Integer): Integer; var i: Integer; begin Result := -1; for i := 0 to Objects.Count - 1 do begin if TfrView(Objects[i]).ID = ID then begin Result := i; break; end; end; end; function TfrPage.FindObject(aName: String): TfrObject; var i: Integer; begin Result := nil; if AnsiCompareText(Self.Name, aName) = 0 then Result:=Self else begin for i := 0 to Objects.Count - 1 do begin if AnsiCompareText(TfrObject(Objects[i]).Name, aName) = 0 then begin Result :=TfrObject(Objects[i]); Exit; end; end; end; end; function TfrPage.FindRTObject(aName: String): TfrObject; var i: Integer; begin Result := nil; if AnsiCompareText(Self.Name, aName) = 0 then Result:=Self else for i := 0 to RTObjects.Count - 1 do begin if AnsiCompareText(TfrObject(RTObjects[i]).Name, aName) = 0 then begin Result :=TfrObject(RTObjects[i]); Exit; end; end; end; procedure TfrPage.InitReport; var b: TfrBandType; begin for b := btReportTitle to btNone do Bands[b] := TfrBand.Create(b, Self); while RTObjects.Count > 0 do begin TfrView(RTObjects[0]).Free; RTObjects.Delete(0); end; TossObjects; InitFlag := True; CurPos := 1; ColPos := 1; end; procedure TfrPage.DoneReport; var b: TfrBandType; begin if InitFlag then begin for b := btReportTitle to btNone do Bands[b].Free; while RTObjects.Count > 0 do begin TfrView(RTObjects[0]).Free; RTObjects.Delete(0); end; end; InitFlag := False; end; function TfrPage.TopMargin: Integer; begin if UseMargins then begin if Margins.Top = 0 then Result := PrnInfo.Ofy else Result := Margins.Top; end else Result := 0; end; function TfrPage.BottomMargin: Integer; begin with PrnInfo do if UseMargins then if Margins.Bottom = 0 then Result:=Ofy+Ph else Result:=Pgh-Margins.Bottom else Result:=Pgh; if (DocMode <> dmDesigning) and BandExists(Bands[btPageFooter]) then Result := Result - Bands[btPageFooter].dy; end; function TfrPage.LeftMargin: Integer; begin if UseMargins then begin if Margins.Left = 0 then Result := PrnInfo.Ofx else Result := Margins.Left; end else Result := 0; end; function TfrPage.RightMargin: Integer; begin with PrnInfo do begin if UseMargins then begin if Margins.Right = 0 then Result := Ofx + Pw else Result := Pgw - Margins.Right; end else Result := Pgw; end; end; procedure TfrPage.TossObjects; var i, j, n, last, miny: Integer; b: TfrBandType; bt, t: TfrView; Bnd, Bnd1: TfrBand; FirstBand, Flag: Boolean; BArr: Array[0..31] of TfrBand; s: String; begin for i := 0 to Objects.Count - 1 do begin bt :=TfrView(Objects[i]); t := frCreateObject(bt.Typ, bt.ClassName); t.Assign(bt); t.StreamMode := smPrinting; RTObjects.Add(t); if (t.Flags and flWantHook) <> 0 then HookList.Add(t); end; for i := 0 to RTObjects.Count - 1 do // select all objects exclude bands begin t :=TfrView(RTObjects[i]); t.Selected := t.Typ <> gtBand; t.Parent := nil; frInterpretator.PrepareScript(t.Script, t.Script, SMemo); if t.Typ = gtSubReport then CurReport.Pages[(t as TfrSubReportView).SubPage].Skip := True; end; Flag := False; for i := 0 to RTObjects.Count - 1 do // search for btCrossXXX bands begin bt :=TfrView(RTObjects[i]); if (bt.Typ = gtBand) and (TfrBandView(bt).BandType in [btCrossHeader..btCrossFooter]) then with Bands[TfrBandView(bt).BandType] do begin Memo.Assign(bt.Memo); Script.Assign(bt.Script); x := bt.x; dx := bt.dx; InitDataSet(TfrBandView(bt).DataSet); View := bt; Flags := bt.Flags; Visible := bt.Visible; bt.Parent := Bands[TfrBandView(bt).BandType]; Flag := True; end; end; if Flag then // fill a ColumnXXX bands at first for b := btCrossHeader to btCrossFooter do begin Bnd := Bands[b]; for i := 0 to RTObjects.Count - 1 do begin t :=TfrView(RTObjects[i]); if t.Selected then if (t.x >= Bnd.x) and (t.x + t.dx <= Bnd.x + Bnd.dx) then begin t.x := t.x - Bnd.x; t.Parent := Bnd; Bnd.Objects.Add(t); end; end; end; for b := btReportTitle to btGroupFooter do // fill other bands begin FirstBand := True; Bnd := Bands[b]; BArr[0] := Bnd; Last := 1; for i := 0 to RTObjects.Count - 1 do // search for specified band begin bt :=TfrView(RTObjects[i]); if (bt.Typ = gtBand) and (TfrBandView(bt).BandType=b) then begin if not FirstBand then begin Bnd.Next := TfrBand.Create(b,Self); Bnd := Bnd.Next; BArr[Last] := Bnd; Inc(Last); end; FirstBand := False; Bnd.Memo.Assign(bt.Memo); Bnd.Script.Assign(bt.Script); Bnd.y := bt.y; Bnd.dy := bt.dy; Bnd.View := bt; Bnd.Flags := bt.Flags; Bnd.Visible := bt.Visible; bt.Parent := Bnd; with bt as TfrBandView, Bnd do begin if Typ = btGroupHeader then InitDataSet(TfrBandView(Bt).fCondition) else InitDataSet(TfrBandView(Bt).DataSet); Stretched := (Flags and flStretched) <> 0; PrintIfSubsetEmpty := (Flags and flBandPrintIfSubsetEmpty) <> 0; if Skip then begin NewPageAfter := False; PageBreak := False; end else begin NewPageAfter := (Flags and flBandNewPageAfter) <> 0; PageBreak := (Flags and flBandPageBreak) <> 0; end; end; for j := 0 to RTObjects.Count - 1 do // placing objects over band begin t :=TfrView(RTObjects[j]); if (t.Parent = nil) and (t.Typ <> gtSubReport) then if t.Selected then if (t.y >= Bnd.y) and (t.y <= Bnd.y + Bnd.dy) then begin t.Parent := Bnd; t.y := t.y - Bnd.y; t.Selected := False; Bnd.Objects.Add(t); end; end; for j := 0 to RTObjects.Count - 1 do // placing ColumnXXX objects over band begin t :=TfrView(RTObjects[j]); if t.Parent <> nil then if t.Selected then if (t.y >= Bnd.y) and (t.y <= Bnd.y + Bnd.dy) then begin t.y := t.y - Bnd.y; t.Selected := False; Bnd.Objects.Add(t); end; end; for j := 0 to RTObjects.Count - 1 do // placing subreports over band begin t :=TfrView(RTObjects[j]); if (t.Parent = nil) and (t.Typ = gtSubReport) then if t.Selected then if (t.y >= Bnd.y) and (t.y <= Bnd.y + Bnd.dy) then begin t.Parent := Bnd; t.y := t.y - Bnd.y; t.Selected := False; Bnd.Objects.Add(t); end; end; end; end; for i := 0 to Last - 1 do // sorting bands begin miny := BArr[i].y; n := i; for j := i + 1 to Last - 1 do if BArr[j].y < miny then begin miny := BArr[j].y; n := j; end; Bnd := BArr[i]; BArr[i] := BArr[n]; BArr[n] := Bnd; end; Bnd := BArr[0]; Bands[b] := Bnd; Bnd.Prev := nil; for i := 1 to Last - 1 do // finally ordering begin Bnd.Next := BArr[i]; Bnd := Bnd.Next; Bnd.Prev := BArr[i - 1]; end; Bnd.Next := nil; Bands[b].LastBand := Bnd; end; for i := 0 to RTObjects.Count - 1 do // place other objects on btNone band begin t :=TfrView(RTObjects[i]); if t.Selected then begin t.Parent := Bands[btNone]; Bands[btNone].y := 0; Bands[btNone].Objects.Add(t); end; end; for i := 1 to MAXBNDS do // connect header & footer to each data-band begin Bnd := Bands[Bnds[i, bpHeader]]; while Bnd <> nil do begin Bnd1 := Bands[Bnds[i, bpData]]; while Bnd1 <> nil do begin if Bnd1.y > Bnd.y + Bnd.dy then break; Bnd1 := Bnd1.Next; end; if (Bnd1 <> nil) and (Bnd1.HeaderBand = nil) then Bnd1.HeaderBand := Bnd; Bnd := Bnd.Next; end; Bnd := Bands[Bnds[i, bpFooter]]; while Bnd <> nil do begin Bnd1 := Bands[Bnds[i, bpData]]; while Bnd1 <> nil do begin if Bnd1.y + Bnd1.dy > Bnd.y then begin Bnd1 := Bnd1.Prev; break; end; if Bnd1.Next = nil then break; Bnd1 := Bnd1.Next; end; if (Bnd1 <> nil) and (Bnd1.FooterBand = nil) then Bnd1.FooterBand := Bnd; Bnd := Bnd.Next; end; end; Bnd := Bands[btGroupHeader].LastBand; Bnd1 := Bands[btGroupFooter]; repeat Bnd.FooterBand := Bnd1; Bnd := Bnd.Prev; Bnd1 := Bnd1.Next; until (Bnd = nil) or (Bnd1 = nil); if BandExists(Bands[btCrossData]) and (Pos(';', TfrBandView(Bands[btCrossData].View).DataSet) <> 0) then begin s := TfrBandView(Bands[btCrossData].View).DataSet; i := 1; while i < Length(s) do begin j := i; while s[j] <> '=' do Inc(j); n := j; while s[n] <> ';' do Inc(n); for b := btMasterHeader to btGroupFooter do begin Bnd := Bands[b]; while Bnd <> nil do begin if Bnd.View <> nil then if AnsiCompareText(Bnd.View.Name, Copy(s, i, j - i)) = 0 then CreateDS(Copy(s, j + 1, n - j - 1), Bnd.VCDataSet, Bnd.IsVirtualVCDS); Bnd := Bnd.Next; end; end; i := n + 1; end; end; if ColCount = 0 then ColCount := 1; ColWidth := (RightMargin - LeftMargin) div ColCount; end; procedure TfrPage.PrepareObjects; var i, j: Integer; t: TfrView; Value: TfrValue; s: String; DSet: TfrTDataSet; Field: TfrTField; begin if (MasterReport.DoublePass and MasterReport.FinalPass) then Exit; CurPage := Self; for i := 0 to RTObjects.Count - 1 do begin t :=TfrView(RTObjects[i]); t.FField := ''; if t.Memo.Count > 0 then s := t.Memo[0]; j := Length(s); if (j > 2) and (s[1] = '[') then begin while (j > 0) and (s[j] <> ']') do Dec(j); s := Copy(s, 2, j - 2); t.FDataSet := nil; t.FField := ''; Value := CurReport.Values.FindVariable(s); if Value = nil then begin CurBand := t.Parent; DSet := GetDefaultDataset; frGetDatasetAndField(s, DSet, Field); if Field <> nil then begin t.FDataSet := DSet; t.FField := Field.FieldName; end; end else if Value.Typ = vtDBField then if Value.DSet <> nil then begin t.FDataSet := Value.DSet; t.FField := Value.Field; end; end; end; end; procedure TfrPage.ShowBand(b: TfrBand); begin if b <> nil then begin {$IFDEF DebugLR} DebugLn('%sTfrPage.ShowBand INI b=%s:%s',[sspc,dbgsname(b),typ2str(b.typ)]); IncSpc(1); {$ENDIF} if Mode = pmBuildList then AddRecord(b, rtShowBand) else b.Draw; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrPage.ShowBand END b=%s:%s',[sspc,dbgsname(b),typ2str(b.typ)]); {$ENDIF} end; end; constructor TfrPage.Create; begin inherited Create; fMargins:=TfrRect.Create; BaseName:='Page'; List := TList.Create; Objects := TList.Create; RTObjects := TList.Create; PageType:=ptReport; end; procedure TfrPage.ShowBandByName(s: String); var bt: TfrBandType; b: TfrBand; begin for bt := btReportTitle to btNone do begin b := Bands[bt]; while b <> nil do begin if b.View <> nil then if AnsiCompareText(b.View.Name, s) = 0 then begin b.Draw; Exit; end; b := b.Next; end; end; end; procedure TfrPage.ShowBandByType(bt: TfrBandType); var b: TfrBand; begin b := Bands[bt]; if b <> nil then b.Draw; end; procedure TfrPage.AddRecord(b: TfrBand; rt: TfrBandRecType); var p: PfrBandRec; begin GetMem(p, SizeOf(TfrBandRec)); p^.Band := b; p^.Action := rt; List.Add(p); end; procedure TfrPage.ClearRecList; var i: Integer; begin for i := 0 to List.Count - 1 do FreeMem(PfrBandRec(List[i]), SizeOf(TfrBandRec)); List.Clear; end; function TfrPage.PlayRecList: Boolean; var p: PfrBandRec; b: TfrBand; begin Result := False; while PlayFrom < List.Count do begin p := List[PlayFrom]; b := p^.Band; case p^.Action of rtShowBand: begin if LastBand <> nil then begin LastBand.DoSubReports; if LastBand <> nil then begin Result := True; Exit; end; end else if b.Draw then begin Result := True; Exit; end; end; rtFirst: begin b.DataSet.First; b.Positions[psLocal] := 1; end; rtNext: begin b.DataSet.Next; Inc(CurPos); Inc(b.Positions[psGlobal]); Inc(b.Positions[psLocal]); end; end; Inc(PlayFrom); end; end; procedure TfrPage.DrawPageFooters; begin {$IFDEF DebugLR} DebugLn('%sTFrPage.DrawPageFootersPage INI PageNo=%d XAdjust=%d CurColumn=%d', [sspc,PageNo, XAdjust, CurColumn]); {$ENDIF} CurColumn := 0; XAdjust := LeftMargin; if (PageNo <> 0) or ((Bands[btPageFooter].Flags and flBandOnFirstPage) <> 0) then while PageNo < MasterReport.EMFPages.Count do begin if not (Append and WasPF) then begin if (CurReport <> nil) and Assigned(CurReport.FOnEndPage) then CurReport.FOnEndPage(PageNo); if (MasterReport <> CurReport) and (MasterReport <> nil) and Assigned(MasterReport.FOnEndPage) then MasterReport.FOnEndPage(PageNo); if not RowsLayout then ShowBand(Bands[btPageFooter]); end; Inc(PageNo); end; PageNo := MasterReport.EMFPages.Count; {$IFDEF DebugLR} DebugLn('%sTFrPage.DrawPageFootersPage FIN PageNo=%d XAdjust=%d CurColumn=%d', [sspc, PageNo, XAdjust, CurColumn]); {$ENDIF} end; procedure TfrPage.NewPage; begin {$IFDEF DebugLR} DebugLn('%sTFrPage.NewPage INI PageNo=%d CurBottomY=%d CurY=%d XAdjust=%d', [sspc,PageNo, CurBottomY, CurY, XAdjust]); IncSpc(1); {$ENDIF} CurReport.InternalOnProgress(PageNo + 1); if not RowsLayout then ShowBand(Bands[btColumnFooter]); DrawPageFooters; CurBottomY := BottomMargin; MasterReport.EMFPages.Add(Self); Append := False; ShowBand(Bands[btOverlay]); CurY := TopMargin; ShowBand(Bands[btPageHeader]); if not RowsLayout then ShowBand(Bands[btColumnHeader]); {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTFrPage.NewPage END PageNo=%d CurBottomY=%d CurY=%d XAdjust=%d', [sspc,PageNo, CurBottomY, CurY, XAdjust]); {$ENDIF} end; procedure TfrPage.NewColumn(Band: TfrBand); var b: TfrBand; begin {$IFDEF DebugLR} DebugLn('%sTfrPage.NewColumn INI CurColumn=%d ColCount=%d CurY=%d XAdjust=%d', [sspc,CurColumn, ColCount, CurY, XAdjust]); IncSpc(1); {$ENDIF} if CurColumn < ColCount - 1 then begin ShowBand(Bands[btColumnFooter]); Inc(CurColumn); Inc(XAdjust, ColWidth + ColGap); CurY := LastStaticColumnY; ShowBand(Bands[btColumnHeader]); end else NewPage; b := Bands[btGroupHeader]; if b <> nil then while (b <> nil) and (b <> Band) do begin b.DisableInit := True; if (b.Flags and flBandRepeatHeader) <> 0 then ShowBand(b); b.DisableInit := False; b := b.Next; end; if Band.Typ in [btMasterData, btDetailData, btSubDetailData] then if (Band.HeaderBand <> nil) and ((Band.HeaderBand.Flags and flBandRepeatHeader) <> 0) then ShowBand(Band.HeaderBand); {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrPage.NewColumn END CurColumn=%d ColCount=%d CurY=%d XAdjust=%d', [sspc,CurColumn, ColCount, CurY, XAdjust]); {$ENDIF} end; procedure TfrPage.NextColumn(Band: TFrBand); begin {$IFDEF DebugLR} DebugLn('%sTfrPage.NextColumn INI CurColumn=%d ColCount=%d CurY=%d XAdjust=%d', [sspc,CurColumn, ColCount, CurY, XAdjust]); IncSpc(1); {$ENDIF} if CurColumn < ColCount - 1 then begin Inc(CurColumn); Inc(XAdjust, ColWidth + ColGap); Inc(ColPos); end else begin CurColumn := 0; ColPos:=1; XAdjust := LeftMargin; end; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrPage.NextColumn END CurColumn=%d ColCount=%d CurY=%d XAdjust=%d', [sspc,CurColumn, ColCount, CurY, XAdjust]); {$ENDIF} end; function TfrPage.RowsLayout: boolean; begin // esta funcion debe leerse de las opciones de la pagina result := (ColCount>1) and (LayoutOrder=loRows) end; procedure TfrPage.DoAggregate(a: Array of TfrBandType); var i: Integer; procedure DoAggregate1(bt: TfrBandType); var b: TfrBand; begin b := Bands[bt]; while b <> nil do begin b.DoAggregate; b := b.Next; end; end; begin for i := Low(a) to High(a) do DoAggregate1(a[i]); end; procedure TfrPage.FormPage; var BndStack: Array[1..MAXBNDS * 3] of TfrBand; MaxLevel, BndStackTop: Integer; i, sfPage : Integer; HasGroups : Boolean; procedure AddToStack(b: TfrBand); begin if b <> nil then begin Inc(BndStackTop); BndStack[BndStackTop] := b; end; end; procedure ShowStack; var i: Integer; begin {$IFDEF DebugLR} DebugLn('%sShowStack INI',[sspc]); {$ENDIF} for i := 1 to BndStackTop do if BandExists(BndStack[i]) then ShowBand(BndStack[i]); BndStackTop := 0; {$IFDEF DebugLR} DebugLn('%sShowStack END',[sspc]); {$ENDIF} end; procedure DoLoop(Level: Integer); var WasPrinted: Boolean; b, b1, b2: TfrBand; BM : Pointer; procedure InitGroups(b: TfrBand); begin while b <> nil do begin Inc(b.Positions[psLocal]); Inc(b.Positions[psGlobal]); ShowBand(b); b := b.Next; end; end; begin {$IFDEF DebugLR} DebugLn('%sDoop(Level=%d) INI',[sspc,Level]); IncSpc(1); {$ENDIF} b := Bands[Bnds[Level, bpData]]; while (b <> nil) and (b.Dataset <> nil) do begin BM:=b.DataSet.GetBookMark; b.DataSet.DisableControls; try b.DataSet.First; if Mode = pmBuildList then AddRecord(b, rtFirst) else b.Positions[psLocal] := 1; b1 := Bands[btGroupHeader]; while b1 <> nil do begin b1.Positions[psLocal] := 0; b1.Positions[psGlobal] := 0; b1 := b1.Next; end; if not b.DataSet.Eof then begin if (Level = 1) and HasGroups then InitGroups(Bands[btGroupHeader]); if b.HeaderBand <> nil then AddToStack(b.HeaderBand); if b.FooterBand <> nil then b.FooterBand.InitValues; while not b.DataSet.Eof do begin Application.ProcessMessages; if MasterReport.Terminated then break; AddToStack(b); WasPrinted := True; if Level < MaxLevel then begin DoLoop(Level + 1); if BndStackTop > 0 then if b.PrintIfSubsetEmpty then ShowStack else begin Dec(BndStackTop); WasPrinted := False; end; end else ShowStack; b.DataSet.Next; if (Level = 1) and HasGroups then begin b1 := Bands[btGroupHeader]; while b1 <> nil do begin if (frParser.Calc(b1.GroupCondition) <> b1.LastGroupValue) or b.Dataset.Eof then begin ShowBand(b.FooterBand); b2 := Bands[btGroupHeader].LastBand; while b2 <> b1 do begin ShowBand(b2.FooterBand); b2.Positions[psLocal] := 0; b2 := b2.Prev; end; ShowBand(b1.FooterBand); if not b.DataSet.Eof then begin if b1.NewPageAfter then NewPage; InitGroups(b1); ShowBand(b.HeaderBand); b.Positions[psLocal] := 0; end; break; end; b1 := b1.Next; end; end; if Mode = pmBuildList then AddRecord(b, rtNext) else if WasPrinted then begin Inc(CurPos); Inc(b.Positions[psGlobal]); Inc(b.Positions[psLocal]); if not b.DataSet.Eof and b.NewPageAfter then NewPage; end; if MasterReport.Terminated then break; end; if BndStackTop = 0 then ShowBand(b.FooterBand) else Dec(BndStackTop); end; finally b.DataSet.GotoBookMark(BM); b.DataSet.FreeBookMark(BM); b.DataSet.EnableControls; end; b := b.Next; end; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sDoop(Level=%d) END',[sspc,Level]); {$ENDIF} end; begin {$IFDEF DebugLR} DebugLn('%sTfrPage.FormPage INI Mode=%d',[sspc,ord(mode)]); IncSpc(1); {$ENDIF} if Mode = pmNormal then begin if Append then begin if PrevY = PrevBottomY then begin Append := False; WasPF := False; PageNo := MasterReport.EMFPages.Count; end; end; if Append and WasPF then CurBottomY := PrevBottomY else CurBottomY := BottomMargin; CurColumn := 0; XAdjust := LeftMargin; {$IFDEF DebugLR} DebugLn('%sXAdjust=%d CurBottomY=%d PrevY=%d',[sspc,XAdjust,CurBottomY,PrevY]); {$ENDIF} if not Append then begin MasterReport.EMFPages.Add(Self); CurY := TopMargin; ShowBand(Bands[btOverlay]); ShowBand(Bands[btNone]); end else CurY := PrevY; sfPage := PageNo; {$IFDEF DebugLR} DebugLn('%sXAdjust=%d CurY=%d sfPage=%d',[sspc,XAdjust,CurY,sfpage]); {$ENDIF} ShowBand(Bands[btReportTitle]); if PageNo = sfPage then // check if new page was formed begin if BandExists(Bands[btPageHeader]) and ((Bands[btPageHeader].Flags and flBandOnFirstPage) <> 0) then ShowBand(Bands[btPageHeader]); if not RowsLayout then ShowBand(Bands[btColumnHeader]); end; end; BndStackTop := 0; for i := 1 to MAXBNDS do begin if BandExists(Bands[Bnds[i, bpData]]) then MaxLevel := i; end; HasGroups := Bands[btGroupHeader].Objects.Count > 0; {$IFDEF DebugLR} DebugLn('%sMaxLevel=%d doing DoLoop(1)',[sspc,MaxLevel]); {$ENDIF} DoLoop(1); if Mode = pmNormal then begin if not RowsLayout then ShowBand(Bands[btColumnFooter]); ShowBand(Bands[btReportSummary]); PrevY := CurY; PrevBottomY := CurBottomY; if CurColumn > 0 then PrevY := BottomMargin; CurColumn := 0; XAdjust := LeftMargin; sfPage := PageNo; WasPF := False; if (Bands[btPageFooter].Flags and flBandOnLastPage) <> 0 then begin WasPF := BandExists(Bands[btPageFooter]); if WasPF then DrawPageFooters; end; PageNo := sfPage + 1; end; {$IFDEF DebugLR} IncSpc(-1); DebugLn('%sTfrPage.FormPage END PrevY=%d PrevBottomY=%d PageNo=%d XAdjust=%d', [sspc,PrevY,PrevBottomY,PageNo,XAdjust]); {$ENDIF} end; function TfrPage.BandExists(b: TfrBand): Boolean; begin Result := b.Objects.Count > 0; end; procedure TfrPage.AfterPrint; var i: Integer; begin for i := 0 to HookList.Count - 1 do TfrView(HookList[i]).OnHook(CurView); end; procedure TfrPage.LoadFromStream(Stream: TStream); var b: Byte; s: String[6]; Bool : WordBool; Rc : TRect; begin with Stream do begin Read(pgSize, 4); Read(dx, 4); //Width Read(dy, 4); //Height Read(Rc, Sizeof(Rc)); Margins.AsRect:=Rc; Read(b, 1); Orientation:=TPrinterOrientation(b); if frVersion < 23 then Read(s[1], 6); Read(Bool, 2); PrintToPrevPage:=Bool; Read(Bool, 2); UseMargins:=Bool; Read(fColCount, 4); Read(fColGap, 4); if frVersion>23 then Read(ord(PageType), SizeOf(TfrPageType)); Read(fLayoutOrder, 4); end; ChangePaper(pgSize, Width, Height, Orientation); end; procedure TfrPage.LoadFromXML(XML: TXMLConfig; Path: String); var b:byte; begin inherited LoadFromXML(XML,Path); dx := XML.GetValue(Path+'Width/Value', 0); // TODO chk dy := XML.GetValue(Path+'Height/Value', 0); // TODO chk b := XML.GetValue(Path+'Height/PageType', ord(PageType)); PageType:=TfrPageType(b); end; procedure TfrPage.SaveToStream(Stream: TStream); var b: Byte; Bool : WordBool; Rc : TRect; begin with Stream do begin Write(pgSize, 4); Write(Width, 4); Write(Height, 4); Rc:=Margins.AsRect; Write(Rc, Sizeof(Rc)); b := Byte(Orientation); Write(b, 1); Bool:=PrintToPrevPage; Write(Bool, 2); Bool:=UseMargins; Write(Bool, 2); Write(ColCount, 4); Write(ColGap, 4); Write(ord(PageType), SizeOf(TfrPageType)); Write(LayoutOrder, 4); end; end; procedure TfrPage.SavetoXML(XML: TXMLConfig; Path: String); begin Inherited SavetoXML(XML,Path); XML.SetValue(Path+'Width/Value', Width); XML.SetValue(Path+'Height/Value', Height); XML.SetValue(Path+'Height/PageType', ord(PageType)); end; {-----------------------------------------------------------------------} constructor TfrPages.Create(AParent: TfrReport); begin inherited Create; Parent := AParent; FPages := TList.Create; end; destructor TfrPages.Destroy; begin Clear; FPages.Free; inherited Destroy; end; function TfrPages.GetCount: Integer; begin Result := FPages.Count; end; function TfrPages.GetPages(Index: Integer): TfrPage; begin Result :=TfrPage(FPages[Index]); end; procedure TfrPages.Clear; var i: Integer; begin for i := 0 to FPages.Count - 1 do Pages[i].Free; FPages.Clear; end; procedure TfrPages.Add(aClassName : string='TfrPageReport'); Var Pg : TFrPage; Rf : TFrPageClass; begin Pg:=nil; Rf:=TFrPageClass(GetClass(aClassName)); if Assigned(Rf) then begin Pg:=Rf.CreatePage; if Assigned(Pg) then begin Pg.CreateUniqueName; FPages.Add(Pg); end; end else showMessage(Format('Class %s not found',[aClassName])) end; procedure TfrPages.Delete(Index: Integer); begin Pages[Index].Free; FPages.Delete(Index); end; procedure TfrPages.LoadFromStream(Stream: TStream); var b: Byte; t: TfrView; s: String; buf: String[8]; procedure AddObject(ot: Byte; clname: String); begin Stream.Read(b, 1); Pages[b].Objects.Add(frCreateObject(ot, clname)); t :=TfrView(Pages[b].Objects.Items[Pages[b].Objects.Count - 1]); end; begin Clear; Stream.Read(Parent.PrintToDefault, 2); Stream.Read(Parent.DoublePass, 2); Parent.SetPrinterTo(ReadString(Stream)); while Stream.Position < Stream.Size do begin {$IFDEF DebugLR} DebugLn('TfrPages.LoadFromStream'); {$ENDIF} Stream.Read(b, 1); if b = $FF then // page info begin if frVersion>23 then begin S:=ReadString(Stream); Add(S); end else Add; Pages[Count - 1].LoadFromStream(Stream); end else if b = $FE then // values begin Parent.FVal.ReadBinaryData(Stream); ReadMemo(Stream, SMemo); Parent.Variables.Assign(SMemo); end else if b = $FD then // datasets begin if frDataManager <> nil then frDataManager.LoadFromStream(Stream); break; end else begin if b > Integer(gtAddIn) then begin raise Exception.Create(''); break; end; s := ''; if b = gtAddIn then begin s := ReadString(Stream); if AnsiUpperCase(s) = 'TFRFRAMEDMEMOVIEW' then AddObject(gtMemo, '') else AddObject(gtAddIn, s); end else AddObject(b, ''); t.LoadFromStream(Stream); if AnsiUpperCase(s) = 'TFRFRAMEDMEMOVIEW' then Stream.Read(buf[1], 8); end; end; end; procedure TfrPages.LoadFromXML(XML: TXMLConfig; Path: String); var b: Byte; t: TfrView; s: string; procedure AddObject(aPage: TFrPage; ot: Byte; clname: String); begin aPage.Objects.Add(frCreateObject(ot, clname)); t :=TfrView(aPage.Objects.Items[aPage.Objects.Count - 1]); end; var i,j,aCount,oCount: Integer; aTyp: byte; aPath,aSubPath,clName: string; begin Clear; {$IFDEF DebugLR} DebugLn('TfrPages.LoadFromXML: LoadingFrom: ', Path); {$ENDIF} Parent.PrintToDefault:= XML.GetValue(Path+'PrintToDefault/Value', True); Parent.DoublePass := XML.GetValue(Path+'DoublePass/Value', False); // TODO: check default clName := XML.GetValue(Path+'SelectedPrinter/Value',''); Parent.SetPrinterTo(clName); // TODO: check default aCount := XML.GetValue(Path+'PageCount/Value', 0); for i := 0 to aCount - 1 do // adding pages at first begin aPath := Path+'Page'+IntToStr(i+1)+'/'; clname:= XML.GetValue(aPath+'ClassName/Value', 'TFRPAGEREPORT'); add(clName); Pages[i].LoadFromXML(XML, aPath); oCount := XML.GetValue(aPath+'ObjectCount/Value', 0); for j:=0 to oCount - 1 do begin aSubPath := aPath + 'Object'+IntTostr(j+1)+'/'; aTyp := StrTofrTypeObject(XML.GetValue(aSubPath+'Typ/Value', '0')); if aTyp>gtAddin then raise Exception.Create(''); clname := XML.GetValue(aSubPath+'ClassName/Value', 'TFRVIEW'); // TODO: Check default if aTyp=gtAddin then begin if ansiuppercase(clname)='TFRFRAMEDMEMOVIEW' then addObject(Pages[i], gtMemo, '') else addObject(Pages[i], gtAddin, clName) end else AddObject(Pages[i], aTyp, ''); t.LoadFromXML(XML, aSubPath); end; end; Parent.FVal.ReadBinaryDataFromXML(XML, Path+'FVal/'); Parent.Variables.Text:= XML.GetValue(Path+'ParentVars/Value', '' ); if frDataManager<>nil then frDatamanager.LoadFromXML(XML, Path+'Datamanager/'); end; procedure TfrPages.SaveToStream(Stream: TStream); var b: Byte; i, j: Integer; t: TfrView; S:string; begin Stream.Write(Parent.PrintToDefault, 2); Stream.Write(Parent.DoublePass, 2); frWriteString(Stream, Prn.Printers[Prn.PrinterIndex]); for i := 0 to Count - 1 do // adding pages at first begin b := $FF; Stream.Write(b, 1); // page info frWriteString(Stream, Pages[i].Classname); Pages[i].SaveToStream(Stream); end; for i := 0 to Count - 1 do begin for j := 0 to Pages[i].Objects.Count - 1 do // then adding objects begin t :=TfrView(Pages[i].Objects[j]); b := Byte(t.Typ); Stream.Write(b, 1); if t.Typ = gtAddIn then frWriteString(Stream, t.ClassName); Stream.Write(i, 1); t.SaveToStream(Stream); end; end; b := $FE; Stream.Write(b, 1); Parent.FVal.WriteBinaryData(Stream); SMemo.Assign(Parent.Variables); frWriteMemo(Stream, SMemo); if frDataManager <> nil then begin b := $FD; Stream.Write(b, 1); frDataManager.SaveToStream(Stream); end; end; procedure TfrPages.SavetoXML(XML: TXMLConfig; Path: String); var b: Byte; i, j: Integer; t: TfrView; aPath,aSubPath: String; begin XML.SetValue(Path+'PrintToDefault/Value', Parent.PrintToDefault); XML.SetValue(Path+'DoublePass/Value', Parent.DoublePass); XML.SetValue(Path+'SelectedPrinter/Value', Prn.Printers[Prn.PrinterIndex]); XML.SetValue(Path+'PageCount/Value', Count); for i := 0 to Count - 1 do // adding pages at first begin aPath := Path+'Page'+IntToStr(i+1)+'/'; Pages[i].SaveToXML(XML, aPath); XML.SetValue(aPath+'ObjectCount/Value', Pages[i].Objects.count); for j:=0 to Pages[i].Objects.count - 1 do begin aSubPath := aPath + 'Object'+IntTostr(j+1)+'/'; T := TfrView(Pages[i].Objects[j]); T.SaveToXML(XML, aSubPath); end; end; Parent.FVal.WriteBinaryDataToXML(XML, Path+'FVal/'); XML.SetValue(Path+'ParentVars/Value',Parent.Variables.Text); if frDataManager <> nil then begin frDataManager.SaveToXML(XML, Path+'Datamanager/'); end; end; {-----------------------------------------------------------------------} constructor TfrEMFPages.Create(AParent: TfrReport); begin inherited Create; Parent := AParent; FPages := TList.Create; end; destructor TfrEMFPages.Destroy; begin Clear; FPages.Free; inherited Destroy; end; function TfrEMFPages.GetCount: Integer; begin Result := FPages.Count; end; function TfrEMFPages.GetPages(Index: Integer): PfrPageInfo; begin Result := FPages[Index]; end; procedure TfrEMFPages.Clear; begin while FPages.Count > 0 do Delete(0); end; procedure TfrEMFPages.Draw(Index: Integer; Canvas: TCanvas; DrawRect: TRect); var p: PfrPageInfo; t: TfrView; i: Integer; sx, sy: Double; v, IsPrinting: Boolean; h: THandle; begin IsPrinting := Printer.Printing and (Canvas is TPrinterCanvas); {$IFDEF DebugLR} DebugLn('TfrEMFPages.Draw IsPrinting=%d PageIndex=%d Canvas.ClassName=%s '+ 'CanvasPPI=%d',[ord(IsPrinting), Index, Canvas.ClassName, Canvas.Font.pixelsPerInch]); DebugLn('----------------------------------------------------'); {$ENDIF} DocMode := dmPrinting; p := FPages[Index]; with p^ do begin if Visible then begin if Page = nil then ObjectsToPage(Index); sx:=(DrawRect.Right-DrawRect.Left)/PrnInfo.PgW; sy:=(DrawRect.Bottom-DrawRect.Top)/PrnInfo.PgH; h:= Canvas.Handle; for i := 0 to Page.Objects.Count - 1 do begin t :=TfrView(Page.Objects[i]); v := True; if not IsPrinting then begin with t, DrawRect do begin v := RectVisible(h, Rect(Round(x * sx) + Left - 10, Round(y * sy) + Top - 10, Round((x + dx) * sx) + Left + 10, Round((y + dy) * sy) + Top + 10)); end; end; if v then begin t.ScaleX := sx; t.ScaleY := sy; t.OffsX := DrawRect.Left; t.OffsY := DrawRect.Top; t.IsPrinting := IsPrinting; t.Draw(Canvas); end; end; end else begin Page.Free; Page := nil; end; end; end; procedure TfrEMFPages.ExportData(Index: Integer); var p: PfrPageInfo; b: Byte; t: TfrView; s: String; begin p := FPages[Index]; with p^ do begin Stream.Position := 0; Stream.Read(frVersion, 1); while Stream.Position < Stream.Size do begin Stream.Read(b, 1); if b = gtAddIn then s := ReadString(Stream) else s := ''; t := frCreateObject(b, s); t.StreamMode := smPrinting; t.LoadFromStream(Stream); t.ExportData; t.Free; end; end; end; procedure TfrEMFPages.ObjectsToPage(Index: Integer); var p: PfrPageInfo; b: Byte; t: TfrView; s: String; begin p := FPages[Index]; with p^ do begin if Page <> nil then Page.Free; Page := TfrPageReport.Create(pgSize, pgWidth, pgHeight, pgOr); Stream.Position := 0; Stream.Read(frVersion, 1); while Stream.Position < Stream.Size do begin Stream.Read(b, 1); if b = gtAddIn then s := ReadString(Stream) else s := ''; t := frCreateObject(b, s); t.StreamMode := smPrinting; t.LoadFromStream(Stream); t.StreamMode := smDesigning; Page.Objects.Add(t); end; end; end; procedure TfrEMFPages.PageToObjects(Index: Integer); var i: Integer; p: PfrPageInfo; t: TfrView; begin p := FPages[Index]; with p^ do begin Stream.Clear; frVersion := frCurrentVersion; Stream.Write(frVersion, 1); for i := 0 to Page.Objects.Count - 1 do begin t :=TfrView(Page.Objects[i]); t.StreamMode := smPrinting; Stream.Write(t.Typ, 1); if t.Typ = gtAddIn then frWriteString(Stream, t.ClassName); t.Memo1.Assign(t.Memo); t.SaveToStream(Stream); end; end; end; procedure TfrEMFPages.Insert(Index: Integer; APage: TfrPage); var p: PfrPageInfo; begin GetMem(p, SizeOf(TfrPageInfo)); FillChar(p^, SizeOf(TfrPageInfo), 0); if Index >= FPages.Count then FPages.Add(p) else FPages.Insert(Index, p); with p^ do begin Stream := TMemoryStream.Create; frVersion := frCurrentVersion; Stream.Write(frVersion, 1); pgSize := APage.pgSize; pgWidth := APage.Width; pgHeight := APage.Height; pgOr := APage.Orientation; pgMargins := APage.UseMargins; PrnInfo := APage.PrnInfo; end; end; procedure TfrEMFPages.Add(APage: TfrPage); begin Insert(FPages.Count, APage); if (CurReport <> nil) and Assigned(CurReport.FOnBeginPage) then CurReport.FOnBeginPage(PageNo); if (MasterReport <> CurReport) and (MasterReport <> nil) and Assigned(MasterReport.FOnBeginPage) then MasterReport.FOnBeginPage(PageNo); end; procedure TfrEMFPages.Delete(Index: Integer); begin if Pages[Index]^.Page <> nil then Pages[Index]^.Page.Free; if Pages[Index]^.Stream <> nil then Pages[Index]^.Stream.Free; FreeMem(Pages[Index], SizeOf(TfrPageInfo)); FPages.Delete(Index); end; procedure TfrEMFPages.LoadFromStream(AStream: TStream); var i, o, c: Integer; b, compr: Byte; p: PfrPageInfo; s: TMemoryStream; procedure ReadVersion22; var Pict: TfrPictureView; begin frReadMemo22(AStream, SMemo); if SMemo.Count > 0 then Parent.SetPrinterTo(SMemo[0]); AStream.Read(c, 4); i := 0; repeat AStream.Read(o, 4); GetMem(p, SizeOf(TfrPageInfo)); FillChar(p^, SizeOf(TfrPageInfo), 0); FPages.Add(p); with p^ do begin AStream.Read(pgSize, 2); AStream.Read(pgWidth, 4); AStream.Read(pgHeight, 4); AStream.Read(b, 1); pgOr := TPrinterOrientation(b); AStream.Read(b, 1); pgMargins := Boolean(b); Prn.SetPrinterInfo(pgSize, pgWidth, pgHeight, pgOr); Prn.FillPrnInfo(PrnInfo); Pict := TfrPictureView.Create; Pict.SetBounds(0, 0, PrnInfo.PgW, PrnInfo.PgH); Pict.Picture.Graphic.LoadFromStream(AStream); Stream := TMemoryStream.Create; b := frCurrentVersion; Stream.Write(b, 1); Pict.StreamMode := smPrinting; Stream.Write(Pict.Typ, 1); Pict.SaveToStream(Stream); Pict.Free; end; AStream.Seek(o, soFromBeginning); Inc(i); until i >= c; end; begin Clear; AStream.Read(compr, 1); if not (compr in [0, 1, 255]) then begin AStream.Seek(0, soFromBeginning); ReadVersion22; Exit; end; Parent.SetPrinterTo(frReadString(AStream)); AStream.Read(c, 4); i := 0; repeat AStream.Read(o, 4); GetMem(p, SizeOf(TfrPageInfo)); FillChar(p^, SizeOf(TfrPageInfo), #0); FPages.Add(p); with p^ do begin AStream.Read(pgSize, 2); AStream.Read(pgWidth, 4); AStream.Read(pgHeight, 4); AStream.Read(b, 1); pgOr := TPrinterOrientation(b); AStream.Read(b, 1); pgMargins := Boolean(b); if compr <> 0 then begin s := TMemoryStream.Create; s.CopyFrom(AStream, o - AStream.Position); Stream := TMemoryStream.Create; frCompressor.DeCompress(s, Stream); s.Free; end else begin Stream := TMemoryStream.Create; Stream.CopyFrom(AStream, o - AStream.Position); end; Prn.SetPrinterInfo(pgSize, pgWidth, pgHeight, pgOr); Prn.FillPrnInfo(PrnInfo); end; AStream.Seek(o, soFromBeginning); Inc(i); until i >= c; end; procedure TfrEMFPages.LoadFromXML(XML: TXMLConfig; Path: String); begin // todo end; procedure TfrEMFPages.SaveToStream(AStream: TStream); var i, o, n: Integer; b: Byte; s: TMemoryStream; begin b := Byte(frCompressor.Enabled); AStream.Write(b, 1); frWriteString(AStream, Prn.Printers[Prn.PrinterIndex]); n := Count; AStream.Write(n, 4); i := 0; repeat o := AStream.Position; AStream.Write(o, 4); // dummy write with Pages[i]^ do begin AStream.Write(pgSize, 2); AStream.Write(pgWidth, 4); AStream.Write(pgHeight, 4); b := Byte(pgOr); AStream.Write(b, 1); b := Byte(pgMargins); AStream.Write(b, 1); Stream.Position := 0; if frCompressor.Enabled then begin s := TMemoryStream.Create; frCompressor.Compress(Stream, s); AStream.CopyFrom(s, s.Size); s.Free; end else AStream.CopyFrom(Stream, Stream.Size); end; n := AStream.Position; AStream.Seek(o, soFromBeginning); AStream.Write(n, 4); AStream.Seek(0, soFromEnd); Inc(i); until i >= Count; end; procedure TfrEMFPages.SaveToXML(XML: TXMLConfig; Path: String); begin // Todo end; {-----------------------------------------------------------------------} constructor TfrValues.Create; begin inherited Create; FItems := TStringList.Create; end; destructor TfrValues.Destroy; begin Clear; FItems.Free; inherited Destroy; end; procedure TfrValues.WriteBinaryData(Stream: TStream); var i, n: Integer; procedure WriteStr(s: String); var n: Byte; begin n := Length(s); Stream.Write(n, 1); Stream.Write(s[1], n); end; begin with Stream do begin n := FItems.Count; WriteBuffer(n, SizeOf(n)); for i := 0 to n - 1 do with Objects[i] do begin WriteBuffer(Typ, SizeOf(Typ)); WriteBuffer(OtherKind, SizeOf(OtherKind)); WriteStr(DataSet); WriteStr(Field); WriteStr(FItems[i]); end; end; end; procedure TfrValues.WriteBinaryDataToXML(XML: TXMLConfig; Path: String); var i: integer; aSubPath: String; begin XML.SetValue(Path+'Count/Value', FItems.Count); for i:= 0 to FItems.Count-1 do with Objects[i] do begin aSubPath := Path+'Objects'+InttoStr(i+1)+'/'; XML.SetValue(aSubPath+'Typ/Value', Ord(Typ)); XML.SetValue(aSubPath+'OtherKind/Value', OtherKind); XML.SetValue(aSubPath+'Dataset/Value', DataSet); XML.SetValue(aSubPath+'Field/Value', Field); XML.SetValue(aSubPath+'Item/Value', FItems[i]); end; end; procedure TfrValues.ReadBinaryData(Stream: TStream); var i, j, n: Integer; function ReadStr: String; var n: Byte; begin Stream.Read(n, 1); SetLength(Result, n); Stream.Read(Result[1], n); end; begin Clear; FItems.Sorted := False; with Stream do begin ReadBuffer(n, SizeOf(n)); for i := 0 to n - 1 do begin j := AddValue; with Objects[j] do begin ReadBuffer(Typ, SizeOf(Typ)); ReadBuffer(OtherKind, SizeOf(OtherKind)); DataSet := ReadStr; Field := ReadStr; FItems[j] := ReadStr; end; end; end; end; procedure TfrValues.ReadBinaryDataFromXML(XML: TXMLConfig; Path: String); var i,j,n: Integer; aSubPath: String; begin clear; FItems.Sorted := False; n := XML.GetValue(Path+'Count/Value', 0); for i:= 0 to n - 1 do begin j := AddValue; with Objects[j] do begin aSubPath := Path+'Objects'+InttoStr(i+1)+'/'; Typ := TfrValueType(XML.GetValue(aSubPath+'Typ/Value', 0)); // TODO check default value OtherKind := XML.GetValue( aSubPath+'OtherKind/Value', 0); // TODO check default value DataSet := XML.GetValue(aSubPath+'Dataset/Value', ''); // TODO check default value Field := XML.GetValue(aSubPath+'Field/Value', ''); // TODO check default value FItems[j] := XML.GetValue(aSubPath+'Item/Value', ''); // TODO check default value end; end; end; function TfrValues.GetValue(Index: Integer): TfrValue; begin Result := TfrValue(FItems.Objects[Index]); end; function TfrValues.AddValue: Integer; begin Result := FItems.AddObject('', TfrValue.Create); end; procedure TfrValues.Clear; var i: Integer; begin for i := 0 to FItems.Count - 1 do TfrValue(FItems.Objects[i]).Free; FItems.Clear; end; function TfrValues.FindVariable(const s: String): TfrValue; var i: Integer; begin Result := nil; i := FItems.IndexOf(s); if i <> -1 then Result := Objects[i]; end; {----------------------------------------------------------------------------} constructor TfrReport.Create(AOwner: TComponent); const Clr: Array[0..1] of TColor = (clWhite, clSilver); var j: Integer; i: Integer; begin inherited Create(AOwner); if not FRInitialized then begin FRInitialized := True; SBmp := TBitmap.Create; TempBmp := TBitmap.Create; SBmp.Width := 8; SBmp.Height := 8; TempBmp.Width := 8; TempBmp.Height := 8; for j := 0 to 7 do begin for i := 0 to 7 do SBmp.Canvas.Pixels[i, j] := Clr[(j + i) mod 2]; end; frProgressForm := TfrProgressForm.Create(nil); end; FPages := TfrPages.Create(Self); FEMFPages := TfrEMFPages.Create(Self); FVars := TStringList.Create; FVal := TfrValues.Create; FShowProgress := True; FModalPreview := True; FModifyPrepared := True; FPreviewButtons := [pbZoom, pbLoad, pbSave, pbPrint, pbFind, pbHelp, pbExit]; FInitialZoom := pzDefault; FileName := sUntitled; FComments:=TStringList.Create; end; destructor TfrReport.Destroy; begin if CurReport=Self then CurReport:=nil; FVal.Free; FVars.Free; FEMFPages.Free; FEMFPages := nil; FPages.Free; FComments.Free; inherited Destroy; end; procedure TfrReport.Clear; begin Pages.Clear; if frDataManager <> nil then frDataManager.Clear; DoublePass := False; ClearAttribs; DocMode := dmDesigning; end; procedure TfrReport.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); Filer.DefineBinaryProperty('ReportForm', @ReadBinaryData, @WriteBinaryData, True); end; procedure TfrReport.WriteBinaryData(Stream: TStream); var n: Integer; Stream1: TMemoryStream; begin n := frCurrentVersion; Stream.Write(n, 4); if FStoreInDFM then begin Stream1 := TMemoryStream.Create; SaveToStream(Stream1); Stream1.Position := 0; n := Stream1.Size; Stream.Write(n, 4); Stream.CopyFrom(Stream1, n); Stream1.Free; end; end; procedure TfrReport.ReadBinaryData(Stream: TStream); var n: Integer; Stream1: TMemoryStream; begin Stream.Read(n, 4); // version if FStoreInDFM then begin Stream.Read(n, 4); Stream1 := TMemoryStream.Create; Stream1.CopyFrom(Stream, n); Stream1.Position := 0; LoadFromStream(Stream1); Stream1.Free; end; end; procedure TfrReport.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = Dataset) then Dataset := nil; if (Operation = opRemove) and (AComponent = Preview) then Preview := nil; end; // report building events procedure TfrReport.InternalOnProgress(Percent: Integer); begin if Assigned(FOnProgress) then FOnProgress(Percent) else if fShowProgress then begin with frProgressForm do begin if (MasterReport.DoublePass and MasterReport.FinalPass) or (FCurrentFilter <> nil) then Label1.Caption:=Format('%s %d %s %d',[FirstCaption,Percent,sFrom,SavedAllPages]) else Label1.Caption:=Format('%s %d',[FirstCaption,Percent]); Application.ProcessMessages; end; end; end; function CopyVarString(V: Variant): String; begin Result := pchar(TVarData(V).VString) end; procedure TfrReport.InternalOnGetValue(ParName: String; var ParValue: String); var i, j, AFormat: Integer; AFormatStr: String; V : Variant; ValStr: String; begin SubValue := ''; AFormat := CurView.Format; AFormatStr := CurView.FormatStr; i := Pos(' #', ParName); if i <> 0 then begin AFormatStr := Copy(ParName, i + 2, Length(ParName) - i - 1); ParName := Copy(ParName, 1, i - 1); if AFormatStr[1] in ['0'..'9', 'N', 'n'] then begin if AFormatStr[1] in ['0'..'9'] then AFormatStr := 'N' + AFormatStr; AFormat := $01000000; if AFormatStr[2] in ['0'..'9'] then AFormat := AFormat + $00010000; i := Length(AFormatStr); while i > 1 do begin if AFormatStr[i] in ['.', ',', '-'] then begin AFormat := AFormat + Ord(AFormatStr[i]); AFormatStr[i] := '.'; if AFormatStr[2] in ['0'..'9'] then begin Inc(i); j := i; while (i <= Length(AFormatStr)) and (AFormatStr[i] in ['0'..'9']) do Inc(i); AFormat := AFormat + 256 * StrToInt(Copy(AFormatStr, j, i - j)); end; break; end; Dec(i); end; if not (AFormatStr[2] in ['0'..'9']) then begin AFormatStr := Copy(AFormatStr, 2, 255); AFormat := AFormat + $00040000; end; end else if AFormatStr[1] in ['D', 'T', 'd', 't'] then begin AFormat := $02040000; AFormatStr := Copy(AFormatStr, 2, 255); end else if AFormatStr[1] in ['B', 'b'] then begin AFormat := $04040000; AFormatStr := Copy(AFormatStr, 2, 255); end; end; CurVariable := ParName; CurValue := 0; GetVariableValue(ParName, CurValue); ParValue := FormatValue(CurValue, AFormat, AFormatStr); { if TVarData(CurValue).VType=varString then ValStr := CopyVarString(CurValue) else ValStr := CurValue; ParValue := FormatValueStr(ValStr, Format, FormatStr); } {$IFDEF DebugLR} DebugLn('%sTfrReport.InternalOnGetValue(%s) Value=%s',[sspc,ParName,ParValue]); {$ENDIF} end; procedure TfrReport.InternalOnEnterRect(Memo: TStringList; View: TfrView); begin with View do if (FDataSet <> nil) and frIsBlob(TfrTField(FDataSet.FindField(FField))) then GetBlob(TfrTField(FDataSet.FindField(FField))); if Assigned(FOnEnterRect) then FOnEnterRect(Memo, View); end; procedure TfrReport.InternalOnExportData(View: TfrView); begin FCurrentFilter.OnData(View.x, View.y, View); end; procedure TfrReport.InternalOnExportText(x, y: Integer; const text: String; View: TfrView); begin FCurrentFilter.OnText(x, y, text, View); end; procedure TfrReport.InternalOnBeginColumn(Band: TfrBand); begin if Assigned(FOnBeginColumn) then FOnBeginColumn(Band); end; procedure TfrReport.InternalOnPrintColumn(ColNo: Integer; var ColWidth: Integer); begin if Assigned(FOnPrintColumn) then FOnPrintColumn(ColNo, ColWidth); end; function TfrReport.FormatValue(V: Variant; AFormat: Integer; const AFormatStr: String): String; var f1, f2: Integer; c: Char; s: String; begin if (TVarData(v).VType = varEmpty) {VarIsEmpty(v)} or VarIsNull(v) then begin Result := ' '; Exit; end; c := DecimalSeparator; f1 := (AFormat div $01000000) and $0F; f2 := (AFormat div $00010000) and $FF; try case f1 of fmtText: begin Result := v; end; fmtNumber: begin DecimalSeparator := Chr(AFormat and $FF); case f2 of 0: Result := FormatFloat('###.##', v); 1: Result := FloatToStrF(Extended(v), ffFixed, 15, (AFormat div $0100) and $FF); 2: Result := FormatFloat('#,###.##', v); 3: Result := FloatToStrF(Extended(v), ffNumber, 15, (AFormat div $0100) and $FF); 4: Result := FormatFloat(AFormatStr, v); end; end; fmtDate: if f2 = 4 then Result := FormatDateTime(AFormatStr, v) else Result := FormatDateTime(frDateFormats[f2], v); fmtTime: if f2 = 4 then Result := FormatDateTime(AFormatStr, v) else Result := FormatDateTime(frTimeFormats[f2], v); fmtBoolean : begin if f2 = 4 then s := AFormatStr else s := BoolStr[f2]; if Integer(v) = 0 then Result := Copy(s, 1, Pos(';', s) - 1) else Result := Copy(s, Pos(';', s) + 1, 255); end; end; except on e:exception do Result := v; end; DecimalSeparator := c; end; { function TfrReport.GetLRTitle: String; begin if csDesigning in ComponentState then Result:=fDefaultTitle else begin if fTitle<>'' then Result:=fTitle else Result:=fDefaultTitle; end; end; } procedure TfrReport.GetVariableValue(const s: String; var aValue: Variant); var Value: TfrValue; D: TfrTDataSet; F: TfrTField; function MasterBand: TfrBand; begin Result := CurBand; if Result.DataSet = nil then while Result.Prev <> nil do Result := Result.Prev; end; begin TVarData(aValue).VType := varEmpty; if Assigned(FOnGetValue) then FOnGetValue(s,aValue); if TVarData(aValue).VType = varEmpty then begin Value := Values.FindVariable(s); if Assigned(Value) then begin with Value do begin case Typ of vtNotAssigned: aValue := ''; vtDBField : begin F := TfrTField(DSet.FindField(Field)); if not F.DataSet.Active then F.DataSet.Open; if Assigned(F.OnGetText) then aValue:=F.DisplayText else aValue:=F.AsVariant; end; vtFRVar : aValue := frParser.Calc(Field); vtOther : begin if OtherKind = 1 then aValue:=frParser.Calc(Field) else aValue:=frParser.Calc(frSpecFuncs[OtherKind]); end; end; end; end else begin D := GetDefaultDataSet; frGetDataSetAndField(s, D, F); if F <> nil then begin if not F.DataSet.Active then F.DataSet.Open; if Assigned(F.OnGetText) then aValue:=F.DisplayText else aValue:=F.AsVariant end else if s = 'VALUE' then aValue:= CurValue else if s = frSpecFuncs[0] then aValue:= PageNo + 1 else if s = frSpecFuncs[2] then aValue := CurDate else if s = frSpecFuncs[3] then aValue:= CurTime else if s = frSpecFuncs[4] then aValue:= MasterBand.Positions[psLocal] else if s = frSpecFuncs[5] then aValue:= MasterBand.Positions[psGlobal] else if s = frSpecFuncs[6] then aValue:= CurPage.ColPos else if s = frSpecFuncs[7] then aValue:= CurPage.CurPos else if s = frSpecFuncs[8] then aValue:= SavedAllPages else begin if frVariables.IndexOf(s) <> -1 then begin aValue:= frVariables[s]; Exit; end; if s <> SubValue then begin SubValue := s; aValue:= frParser.Calc(s); SubValue := ''; end else raise(EParserError.Create('Undefined symbol ";"' + SubValue + ';')); end; end; end; end; procedure TfrReport.OnGetParsFunction(const aName: String; p1, p2, p3: Variant; var val: Variant); var i: Integer; begin // val := '0'; val := varempty; for i := 0 to frFunctionsCount - 1 do if frFunctions[i].FunctionLibrary.OnFunction(aName, p1, p2, p3, val) then exit; if AggrBand.Visible then if Assigned(FOnFunction) then FOnFunction(aName, p1, p2, p3, val); end; // load/save methods procedure TfrReport.LoadFromStream(Stream: TStream); begin CurReport := Self; Stream.Read(frVersion, 1); if frVersion < 21 then begin frVersion := 21; Stream.Position := 0; end; if frVersion <= frCurrentVersion then try {$IFDEF FREEREP2217READ} if FRE_COMPATIBLE_READ and (frVersion = 23) then frVersion := 22; {$ENDIF} Pages.LoadFromStream(Stream); except Pages.Clear; Pages.Add; MessageDlg(sFRFError,mtError,[mbOk],0) end else MessageDlg(sFRFError,mtError,[mbOk],0); end; procedure TfrReport.LoadFromXML(XML: TXMLConfig; Path: String); begin CurReport := Self; frVersion := XML.GetValue(Path+'Version/Value', 21); fComments.Text := XML.GetValue(Path+'Comments/Value', ''); fKeyWords := XML.GetValue(Path+'KeyWords/Value', ''); fSubject := XML.GetValue(Path+'Subject/Value', ''); fTitle := XML.GetValue(Path+'Title/Value', ''); // XML.SetValue(Path+'ReportCreateDate/Value', FReportCreateDate); // XML.SetValue(Path+'ReportCreateDate/Value', FReportLastChange); FReportVersionBuild:=XML.GetValue(Path+'ReportVersionBuild/Value', ''); FReportVersionMajor:=XML.GetValue(Path+'ReportVersionMajor/Value', ''); FReportVersionMinor:=XML.GetValue(Path+'ReportVersionMinor/Value', ''); FReportVersionRelease:=XML.GetValue(Path+'ReportVersionRelease/Value', ''); FReportAutor:=XML.GetValue(Path+'ReportAutor/Value', ''); if frVersion < 21 then frVersion := 21; if frVersion <= frCurrentVersion then try {$IFDEF FREEREP2217READ} if FRE_COMPATIBLE_READ and (frVersion = 23) then frVersion := 22; {$ENDIF} pages.LoadFromXML(XML, Path+'Pages/'); except Pages.Clear; Pages.Add; MessageDlg(sFRFError,mtError,[mbOk],0) end else MessageDlg(sFRFError,mtError,[mbOk],0); end; procedure TfrReport.SaveToStream(Stream: TStream); begin CurReport := Self; frVersion := frCurrentVersion; Stream.Write(frVersion, 1); Pages.SaveToStream(Stream); end; procedure TfrReport.LoadFromFile(FName: String); var Stream: TFileStream; Ext : String; begin Ext:=ExtractFileExt(fName); if SameText('.lrf',Ext) then LoadFromXMLFile(fName) else begin Stream := TFileStream.Create(UTF8ToSys(FName), fmOpenRead); LoadFromStream(Stream); Stream.Free; FileName := FName; end; end; procedure TfrReport.LoadFromXMLFile(Fname: String); var XML: TXMLConfig; begin {$IFDEF ver2_0_0} XML := TXMLConfig.Create(FName); {$ELSE} XML := TXMLConfig.Create(nil); XML.Filename := FName; {$ENDIF} try LoadFromXML(XML, 'LazReport/'); FileName := FName; finally XML.Free; end; end; procedure TfrReport.SaveToFile(FName: String); var Stream: TFileStream; Ext : string; begin Ext:=ExtractFileExt(fName); if (Ext='') or (Ext='.') then begin Ext:='.lrf'; fName:=ChangeFileExt(fName,Ext); end; if SameText('.lrf',Ext) then SaveToXMLFile(fName) else begin Stream := TFileStream.Create(UTF8ToSys(FName), fmCreate); SaveToStream(Stream); Stream.Free; end; end; procedure TfrReport.SavetoXML(XML: TXMLConfig; Path: String); begin CurReport := Self; frVersion := frCurrentVersion; XML.SetValue(Path+'Version/Value', frVersion); XML.SetValue(Path+'Title/Value', fTitle); XML.SetValue(Path+'Subject/Value', fSubject); XML.SetValue(Path+'KeyWords/Value', fKeyWords); XML.SetValue(Path+'Comments/Value', fComments.Text); // XML.SetValue(Path+'ReportCreateDate/Value', FReportCreateDate); // XML.SetValue(Path+'ReportCreateDate/Value', FReportLastChange); XML.SetValue(Path+'ReportVersionBuild/Value', FReportVersionBuild); XML.SetValue(Path+'ReportVersionMajor/Value', FReportVersionMajor); XML.SetValue(Path+'ReportVersionMinor/Value', FReportVersionMinor); XML.SetValue(Path+'ReportVersionRelease/Value', FReportVersionRelease); XML.SetValue(Path+'ReportAutor/Value', FReportAutor); Pages.SaveToXML(XML, Path+'Pages/'); end; procedure TfrReport.SaveToXMLFile(FName: String); var XML: TXMLConfig; begin {$IFDEF ver2_0_0} XML := TXMLConfig.CreateClean(FName); {$ELSE} XML := TXMLConfig.Create(nil); XML.StartEmpty := True; XML.Filename := FName; {$ENDIF} try SaveToXML(XML, 'LazReport/'); XML.Flush; finally XML.Free; end; end; procedure TfrReport.LoadFromDB(Table: TDataSet; DocN: Integer); var Stream: TMemoryStream; begin Table.First; while not Table.Eof do begin if Table.Fields[0].AsInteger = DocN then begin Stream := TMemoryStream.Create; TfrTBlobField(Table.Fields[1]).SaveToStream(Stream); Stream.Position := 0; LoadFromStream(Stream); Stream.Free; Exit; end; Table.Next; end; end; procedure TfrReport.SaveToDB(Table: TDataSet; DocN: Integer); var Stream: TMemoryStream; Found: Boolean; begin Found := False; Table.First; while not Table.Eof do begin if Table.Fields[0].AsInteger = DocN then begin Found := True; break; end; Table.Next; end; if Found then Table.Edit else Table.Append; Table.Fields[0].AsInteger := DocN; Stream := TMemoryStream.Create; SaveToStream(Stream); Stream.Position := 0; TfrTBlobField(Table.Fields[1]).LoadFromStream(Stream); Stream.Free; Table.Post; end; procedure TfrReport.LoadPreparedReport(FName: String); var Stream: TFileStream; begin Stream := TFileStream.Create(UTF8ToSys(FName), fmOpenRead); EMFPages.LoadFromStream(Stream); Stream.Free; CanRebuild := False; end; procedure TfrReport.SavePreparedReport(FName: String); var Stream: TFileStream; begin Stream := TFileStream.Create(UTF8ToSys(FName), fmCreate); EMFPages.SaveToStream(Stream); Stream.Free; end; procedure TfrReport.LoadTemplate(FName: String; comm: TStrings; Bmp: TBitmap; Load: Boolean); var Stream: TFileStream; b: Byte; fb: TBitmap; fm: TStringList; pos: Integer; begin fb := TBitmap.Create; fm := TStringList.Create; Stream := TFileStream.Create(UTF8ToSys(FName), fmOpenRead); if Load then begin ReadMemo(Stream, fm); Stream.Read(pos, 4); Stream.Read(b, 1); if b <> 0 then fb.LoadFromStream(Stream); Stream.Position := pos; Pages.LoadFromStream(Stream); end else begin ReadMemo(Stream, Comm); Stream.Read(pos, 4); Bmp.Assign(nil); Stream.Read(b, 1); if b <> 0 then Bmp.LoadFromStream(Stream); end; fm.Free; fb.Free; Stream.Free; end; procedure TfrReport.SaveTemplate(FName: String; Comm: TStrings; Bmp: TBitmap); var Stream: TFileStream; b: Byte; pos, lpos: Integer; begin Stream := TFileStream.Create(UTF8ToSys(FName), fmCreate); frWriteMemo(Stream, Comm); b := 0; pos := Stream.Position; lpos := 0; Stream.Write(lpos, 4); if Bmp.Empty then Stream.Write(b, 1) else begin b := 1; Stream.Write(b, 1); Bmp.SaveToStream(Stream); end; lpos := Stream.Position; Stream.Position := pos; Stream.Write(lpos, 4); Stream.Position := lpos; Pages.SaveToStream(Stream); Stream.Free; end; // report manipulation methods procedure TfrReport.DesignReport; var HF: String; begin CurReport := Self; if Pages.Count = 0 then Pages.Add; HF := Application.HelpFile; Application.HelpFile := 'FRuser.hlp'; if not Assigned(frDesigner) and Assigned(ProcedureInitDesigner) then ProcedureInitDesigner(); if frDesigner <> nil then {$IFDEF MODALDESIGNER} frDesigner.ShowModal; {$ELSE} frDesigner.Show; {$ENDIF} Application.HelpFile := HF; end; var FirstPassTerminated, FirstTime: Boolean; procedure TfrReport.BuildBeforeModal(Sender: TObject); begin {$IFDEF DebugLR} DebugLn('20'); {$ENDIF} DoBuildReport; {$IFDEF DebugLR} DebugLn('21'); {$ENDIF} if FinalPass then begin if Terminated then frProgressForm.ModalResult := mrCancel else frProgressForm.ModalResult := mrOk; end else begin {$IFDEF DebugLR} DebugLn('22'); {$ENDIF} FirstPassTerminated := Terminated; SavedAllPages := EMFPages.Count; DoublePass := False; FirstTime := False; DoPrepareReport; // do final pass DoublePass := True; {$IFDEF DebugLR} DebugLn('23'); {$ENDIF} end; end; function TfrReport.PrepareReport: Boolean; var ParamOk: Boolean; begin DocMode := dmPrinting; CurDate := Date; CurTime := Time; MasterReport := Self; CurReport := Self; Values.Items.Sorted := True; frParser.OnGetValue := @GetVariableValue; frParser.OnFunction := @OnGetParsFunction; if Assigned(FOnBeginDoc) then FOnBeginDoc; Result := False; ParamOk := True; if frDataManager <> nil then begin FillQueryParams; ParamOk := frDataManager.ShowParamsDialog; end; if ParamOk then Result := DoPrepareReport; FinalPass := False; if frDataManager <> nil then frDataManager.AfterParamsDialog; if Assigned(FOnEndDoc) then FOnEndDoc; end; function TfrReport.DoPrepareReport: Boolean; var s: String; begin Result := True; Terminated := False; Append := False; DisableDrawing := False; FinalPass := True; FirstTime := True; PageNo := 0; EMFPages.Clear; {$IFDEF DebugLR} DebugLn('DoPrepareReport DoublePass=',BoolToStr(DoublePass)); {$ENDIF} s := sReportPreparing; if DoublePass then begin {$IFDEF DebugLR} DebugLn('DoPrepareReport FirstPass Begin'); {$ENDIF} DisableDrawing := True; FinalPass := False; if not Assigned(FOnProgress) and FShowProgress then begin with frProgressForm do begin if Title = '' then Caption := s else Caption := s + ' - ' + Title; FirstCaption := sFirstPass; Label1.Caption := FirstCaption + ' 1'; OnBeforeModal := @BuildBeforeModal; Show_Modal(Self); end; {$IFDEF DebugLR} DebugLn('DoPrepareReport FirstPass End'); {$ENDIF} end else BuildBeforeModal(nil); Exit; end; if not Assigned(FOnProgress) and FShowProgress then begin {$IFDEF DebugLR} DebugLn('DoPrepareReport SecondPass begin'); {$ENDIF} with frProgressForm do begin {$IFDEF DebugLR} DebugLn('1'); {$ENDIF} if Title = '' then Caption := s else Caption := s + ' - ' + Title; FirstCaption := sPagePreparing; Label1.Caption := FirstCaption + ' 1'; OnBeforeModal:=@BuildBeforeModal; {$IFDEF DebugLR} DebugLn('2'); {$ENDIF} if Visible then begin {$IFDEF DebugLR} DebugLn('3'); {$ENDIF} if not FirstPassTerminated then DoublePass := True; BuildBeforeModal(nil); {$IFDEF DebugLR} DebugLn('4'); {$ENDIF} end else begin {$IFDEF DebugLR} DebugLn('5'); {$ENDIF} SavedAllPages := 0; if Show_Modal(Self) = mrCancel then Result := False; {$IFDEF DebugLR} DebugLn('6'); {$ENDIF} end; {$IFDEF DebugLR} DebugLn('DoPrepareReport SecondPass End'); {$ENDIF} end; end else BuildBeforeModal(nil); Terminated := False; end; var ExportStream: TFileStream; procedure TfrReport.ExportBeforeModal(Sender: TObject); var i: Integer; begin Application.ProcessMessages; for i := 0 to EMFPages.Count - 1 do begin FCurrentFilter.OnBeginPage; EMFPages.ExportData(i); InternalOnProgress(i + 1); Application.ProcessMessages; FCurrentFilter.OnEndPage; end; FCurrentFilter.OnEndDoc; frProgressForm.ModalResult := mrOk; end; procedure TfrReport.ExportTo(Filter: TClass; aFileName: String); var s: String; begin ExportStream := TFileStream.Create(UTF8ToSys(aFileName), fmCreate); FCurrentFilter := TfrExportFilter(Filter.NewInstance); FCurrentFilter.Create(ExportStream); FCurrentFilter.OnBeginDoc; CurReport := Self; MasterReport := Self; SavedAllPages := EMFPages.Count; with frProgressForm do begin s := sReportPreparing; if Title = '' then Caption := s else Caption := s + ' - ' + Title; FirstCaption := sPagePreparing; Label1.Caption := FirstCaption + ' 1'; OnBeforeModal := @ExportBeforeModal; Show_Modal(Self); end; FCurrentFilter.Free; FCurrentFilter := nil; ExportStream.Free; end; procedure TfrReport.FillQueryParams; var i, j: Integer; t: TfrView; procedure PrepareDS(ds: TfrDataSet); begin if (ds <> nil) and (ds is TfrDBDataSet) then frDataManager.PrepareDataSet(TfrTDataSet((ds as TfrDBDataSet).GetDataSet)); end; begin if frDataManager = nil then Exit; frDataManager.BeforePreparing; if Dataset <> nil then PrepareDS(DataSet); for i := 0 to Pages.Count - 1 do for j := 0 to Pages[i].Objects.Count-1 do begin t :=TfrView(Pages[i].Objects[j]); if t is TfrBandView then PrepareDS(frFindComponent(CurReport.Owner, TfrBandView(t).DataSet) as TfrDataSet); end; frDataManager.AfterPreparing; end; procedure TfrReport.DoBuildReport; var i : Integer; b : Boolean; BM : Pointer; begin HookList.Clear; CanRebuild := True; DocMode := dmPrinting; CurReport := Self; Values.Items.Sorted := True; frParser.OnGetValue := @GetVariableValue; frParser.OnFunction := @OnGetParsFunction; ErrorFlag := False; b := (Dataset <> nil) and (ReportType = rtMultiple); if b then begin BM:=DataSet.GetBookMark; DataSet.DisableControls; Dataset.Init; Dataset.First; end; try for i := 0 to Pages.Count - 1 do Pages[i].Skip := False; for i := 0 to Pages.Count - 1 do Pages[i].InitReport; PrepareDataSets; for i := 0 to Pages.Count - 1 do if Pages[i].PageType = ptReport then Pages[i].PrepareObjects; repeat {$IFDEF DebugLR} DebugLn('p1'); {$ENDIF} InternalOnProgress(PageNo + 1); {$IFDEF DebugLR} DebugLn('p2'); {$ENDIF} for i := 0 to Pages.Count - 1 do begin if Pages[i].PageType = ptReport then begin FCurPage := Pages[i]; if FCurPage.Skip then Continue; FCurPage.Mode := pmNormal; if Assigned(FOnManualBuild) then FOnManualBuild(FCurPage) else FCurPage.FormPage; {$IFDEF DebugLR} debugLn('p3'); {$ENDIF} Append := False; if ((i = Pages.Count - 1) and CompositeMode and (not b or Dataset.Eof)) or ((i <> Pages.Count - 1) and Pages[i + 1].PrintToPrevPage) then begin Dec(PageNo); Append := True; end; if not Append then begin PageNo := MasterReport.EMFPages.Count; InternalOnProgress(PageNo); end; if MasterReport.Terminated then Break; end; end; {$IFDEF DebugLR} DebugLn('p4'); {$ENDIF} InternalOnProgress(PageNo); if b then Dataset.Next; until MasterReport.Terminated or not b or Dataset.Eof; for i := 0 to Pages.Count - 1 do Pages[i].DoneReport; finally if b then begin Dataset.Exit; DataSet.GotoBookMark(BM); DataSet.FreeBookMark(BM); DataSet.EnableControls; end; end; if (frDataManager <> nil) and FinalPass then frDataManager.AfterPreparing; Values.Items.Sorted := False; end; procedure TfrReport.ShowReport; begin PrepareReport; if ErrorFlag then begin MessageDlg(ErrorStr,mtError,[mbOk],0); EMFPages.Clear; end else ShowPreparedReport; end; procedure TfrReport.ShowPreparedReport; var s: String; p: TfrPreviewForm; begin CurReport := Self; MasterReport := Self; DocMode := dmPrinting; if EMFPages.Count = 0 then Exit; s := sPreview; if Title <> '' then s := s + ' - ' + Title; if not (csDesigning in ComponentState) and Assigned(Preview) then begin Preview.Connect(Self); end else begin p := TfrPreviewForm.Create(nil); {$IFDEF DebugLR} DebugLn('1 TfrPreviewForm.visible=',BooLToStr(p.Visible)); {$ENDIF} p.Caption := s; {$IFDEF DebugLR} DebugLn('2 TfrPreviewForm.visible=',BooLToStr(p.Visible)); {$ENDIF} p.Show_Modal(Self); end; end; procedure TfrReport.PrintBeforeModal(Sender: TObject); begin DoPrintReport(FPageNumbers, FCopies); frProgressForm.ModalResult := mrOk; end; procedure TfrReport.PrintPreparedReport(PageNumbers: String; Copies: Integer); var s: String; begin CurReport:=Self; MasterReport:=Self; s:=sReportPreparing; Terminated:=False; FPageNumbers:=PageNumbers; FCopies:=Copies; if not Assigned(FOnProgress) and FShowProgress then begin with frProgressForm do begin if Title = '' then Caption := s else Caption := s + ' - ' + Title; FirstCaption := sPagePrinting; Label1.Caption := FirstCaption; OnBeforeModal := @PrintBeforeModal; Show_Modal(Self); end end else PrintBeforeModal(nil); Terminated := False; end; procedure TfrReport.DoPrintReport(PageNumbers: String; Copies: Integer); var i, j: Integer; f: Boolean; pgList: TStringList; procedure ParsePageNumbers; var i, j, n1, n2: Integer; s: String; IsRange: Boolean; begin s := PageNumbers; while Pos(' ', s) <> 0 do Delete(s, Pos(' ', s), 1); if s = '' then Exit; s := s + ','; i := 1; j := 1; n1 := 1; IsRange := False; while i <= Length(s) do begin if s[i] = ',' then begin n2 := StrToInt(Copy(s, j, i - j)); j := i + 1; if IsRange then begin while n1 <= n2 do begin pgList.Add(IntToStr(n1)); Inc(n1); end; end else pgList.Add(IntToStr(n2)); IsRange := False; end else if s[i] = '-' then begin IsRange := True; n1 := StrToInt(Copy(s, j, i - j)); j := i + 1; end; Inc(i); end; end; procedure PrintPage(n: Integer); begin with Printer, EMFPages[n]^ do begin if not Prn.IsEqual(pgSize, pgWidth, pgHeight, pgOr) then begin EndDoc; Prn.SetPrinterInfo(pgSize, pgWidth, pgHeight, pgOr); BeginDoc; end else if not f then NewPage; Prn.FillPrnInfo(PrnInfo); Visible := True; with PrnInfo do begin if pgMargins then EMFPages.Draw(n, Printer.Canvas, Rect(-POfx, -POfy, PPgw - POfx, PPgh - POfy)) else EMFPages.Draw(n, Printer.Canvas, Rect(0, 0, PPw, PPh)); end; Visible := False; EMFPages.Draw(n, Printer.Canvas, Rect(0, 0, 0, 0)); end; InternalOnProgress(n + 1); Application.ProcessMessages; f := False; end; {$IFDEF DebugLR} procedure DebugPrnInfo(msg: string); var k: integer; begin DebugLn('--------------------------------------------------'); DebugLn(Msg); for k:=0 to EMFPages.Count-1 do begin DebugLn('EMFPage ',dbgs(k)); with EmfPages[k]^.PrnInfo do begin DebugLn(Format(' Ppgw=%d PPgh=%d Pgw=%d Pgh=%d',[PPgw,PPgh,Pgw,Pgh])); DebugLn(Format(' Pofx=%d POfy=%d Ofx=%d Ofy=%d',[POfx,POfy,Ofx,Ofy])); DebugLn(Format(' Ppw=%d Pph=%d Pw=%d Ph=%d',[Ppw,Pph,Pw,Ph])); end; end; end; {$ENDIF} begin {$IFDEF DebugLR} DebugLn('DoPrintReport INIT'); DebugPrnInfo('=== INIT'); {$ENDIF} Prn.Printer := Printer; pgList := TStringList.Create; ParsePageNumbers; if Copies <= 0 then Copies := 1; with EMFPages[0]^ do begin Prn.SetPrinterInfo(pgSize, pgWidth, pgHeight, pgOr); Prn.FillPrnInfo(PrnInfo); end; {$IFDEF DebugLR} DebugPrnInfo('=== AFTER EMFPages[0]^'); {$ENDIF} if Title <> '' then Printer.Title:=Format('LazReport : %s',[Title]) else Printer.Title:=Format('LazReport : %s',[sUntitled]); Printer.BeginDoc; f:= True; for i := 0 to EMFPages.Count - 1 do begin if (pgList.Count = 0) or (pgList.IndexOf(IntToStr(i + 1)) <> -1) then begin for j := 0 to Copies - 1 do begin {$IFDEF DebugLR} DebugPrnInfo('=== Before PrintPage('+IntToStr(i)+')'); {$ENDIF} PrintPage(i); if Terminated then begin Printer.Abort; pgList.Free; Exit; end; end; end; end; Printer.EndDoc; pgList.Free; {$IFDEF DebugLR} DebugPrnInfo('=== END'); {$ENDIF} end; procedure TfrReport.SetComments(const AValue: TStringList); begin FComments.Assign(AValue); end; procedure TfrReport.SetDataset(const AValue: TfrDataset); begin FDataSet := AValue; end; // printer manipulation methods procedure TfrReport.SetPrinterTo(PrnName: String); begin if not PrintToDefault then if Prn.Printers.IndexOf(PrnName) <> -1 then Prn.PrinterIndex := Prn.Printers.IndexOf(PrnName); end; procedure TfrReport.SetReportAutor(const AValue: string); begin if FReportAutor=AValue then exit; FReportAutor:=AValue; end; procedure TfrReport.SetReportCreateDate(const AValue: TDateTime); begin if FReportCreateDate=AValue then exit; FReportCreateDate:=AValue; end; procedure TfrReport.SetReportLastChange(const AValue: TDateTime); begin if FReportLastChange=AValue then exit; FReportLastChange:=AValue; end; procedure TfrReport.SetReportVersionBuild(const AValue: string); begin if FReportVersionBuild=AValue then exit; FReportVersionBuild:=AValue; end; procedure TfrReport.SetReportVersionMajor(const AValue: string); begin if FReportVersionMajor=AValue then exit; FReportVersionMajor:=AValue; end; procedure TfrReport.SetReportVersionMinor(const AValue: string); begin if FReportVersionMinor=AValue then exit; FReportVersionMinor:=AValue; end; procedure TfrReport.SetReportVersionRelease(const AValue: string); begin if FReportVersionRelease=AValue then exit; FReportVersionRelease:=AValue; end; function TfrReport.ChangePrinter(OldIndex, NewIndex: Integer): Boolean; procedure ChangePages; var i: Integer; begin for i := 0 to Pages.Count - 1 do begin with Pages[i] do ChangePaper(pgSize, Width, Height, Orientation); end; end; begin Result := True; try Prn.PrinterIndex := NewIndex; Prn.PaperSize := -1; ChangePages; except on Exception do begin MessageDlg(sPrinterError,mtError,[mbOk],0); Prn.PrinterIndex := OldIndex; ChangePages; Result := False; end; end; end; procedure TfrReport.EditPreparedReport(PageIndex: Integer); var p: PfrPageInfo; Stream: TMemoryStream; Designer: TfrReportDesigner; DesName: String; begin if frDesigner = nil then Exit; Screen.Cursor := crHourGlass; Designer := frDesigner; DesName := Designer.Name; Designer.Name := DesName + '__'; Designer.Page := nil; frDesigner := TfrReportDesigner(frDesigner.ClassType.NewInstance); frDesigner.Create(nil); Stream := TMemoryStream.Create; SaveToStream(Stream); Pages.Clear; EMFPages.ObjectsToPage(PageIndex); p := EMFPages[PageIndex]; Pages.FPages.Add(p^.Page); CurReport := Self; Screen.Cursor := crDefault; try frDesigner.ShowModal; if frDesigner.Modified then if MessageDlg(sSaveChanges+' ?',mtConfirmation,[mbYes,mbNo],0)=mrYes then EMFPages.PageToObjects(PageIndex); finally Pages.FPages.Clear; Stream.Position := 0; LoadFromStream(Stream); Stream.Free; frDesigner.Free; frDesigner := Designer; frDesigner.Name := DesName; frDesigner.Page := Pages[0]; frDesigner.RedrawPage; end; end; // miscellaneous methods procedure TfrReport.PrepareDataSets; var i: Integer; begin with Values do for i := 0 to Items.Count - 1 do with Objects[i] do if Typ = vtDBField then DSet := frGetDataSet(DataSet); end; procedure TfrReport.SetVars(Value: TStrings); begin FVars.Assign(Value); end; procedure TfrReport.ClearAttribs; begin // FDefaultTitle:=''; FTitle:=''; FSubject:=''; FKeyWords:=''; FComments.Clear; ReportAutor := ''; ReportVersionMajor := ''; ReportVersionMinor := ''; ReportVersionRelease := ''; ReportVersionBuild := ''; ReportCreateDate := Now; ReportLastChange := Now; end; procedure TfrReport.GetVarList(CatNo: Integer; List: TStrings); var i, n: Integer; s: String; begin List.Clear; i := 0; n := 0; if FVars.Count > 0 then repeat s := FVars[i]; if Length(s) > 0 then if s[1] <> ' ' then Inc(n); Inc(i); until n > CatNo; while i < FVars.Count do begin s := FVars[i]; if (s <> '') and (s[1] = ' ') then List.Add(Copy(s, 2, Length(s) - 1)) else break; Inc(i); end; end; procedure TfrReport.GetCategoryList(List: TStrings); var i: Integer; s: String; begin List.Clear; for i := 0 to FVars.Count - 1 do begin s := FVars[i]; if (Length(s)>0) and (s[1]<>' ') then List.Add(s); end; end; function TfrReport.FindVariable(Variable: String): Integer; var i: Integer; begin Result := -1; Variable := ' ' + Variable; for i := 0 to FVars.Count - 1 do if Variable = FVars[i] then begin Result := i; break; end; end; function TfrReport.FindObject(aName: String): TfrObject; var i, j: Integer; begin Result := nil; for i := 0 to Pages.Count - 1 do begin Result:=Pages[i].FindObject(aName); if Assigned(Result) then Break; end; end; {----------------------------------------------------------------------------} constructor TfrCompositeReport.Create(AOwner: TComponent); begin inherited Create(AOwner); Reports := TList.Create; end; destructor TfrCompositeReport.Destroy; begin Reports.Free; inherited Destroy; end; procedure TfrCompositeReport.DoBuildReport; var i: Integer; Doc: TfrReport; ParamOk: Boolean; begin CanRebuild := True; PageNo := 0; for i := 0 to Reports.Count - 1 do begin Doc := TfrReport(Reports[i]); CompositeMode := False; if i <> Reports.Count - 1 then if (TfrReport(Reports[i + 1]).Pages.Count > 0) and TfrReport(Reports[i + 1]).Pages[0].PrintToPrevPage then CompositeMode := True; if Assigned(Doc.FOnBeginDoc) and FirstTime then Doc.FOnBeginDoc; ParamOk := True; if (frDataManager <> nil) and FirstTime then begin Doc.FillQueryParams; ParamOk := frDataManager.ShowParamsDialog; end; if ParamOk then Doc.DoBuildReport; if (frDataManager <> nil) and FinalPass then frDataManager.AfterParamsDialog; if Assigned(Doc.FOnEndDoc) and FinalPass then Doc.FOnEndDoc; Append := CompositeMode; CompositeMode := False; if Terminated then break; end; end; {----------------------------------------------------------------------------} procedure TfrObjEditorForm.ShowEditor(t: TfrView); begin // abstract method end; {----------------------------------------------------------------------------} constructor TfrExportFilter.Create(AStream: TStream); begin inherited Create; Stream := AStream; Lines := TList.Create; end; destructor TfrExportFilter.Destroy; begin ClearLines; Lines.Free; inherited Destroy; end; procedure TfrExportFilter.ClearLines; var i: Integer; p, p1: PfrTextRec; begin for i := 0 to Lines.Count - 1 do begin p := PfrTextRec(Lines[i]); while p <> nil do begin p1 := p; p := p^.Next; FreeMem(p1, SizeOf(TfrTextRec)); end; end; Lines.Clear; end; procedure TfrExportFilter.OnBeginDoc; begin // abstract method end; procedure TfrExportFilter.OnEndDoc; begin // abstract method end; procedure TfrExportFilter.OnBeginPage; begin // abstract method end; procedure TfrExportFilter.OnEndPage; begin // abstract method end; procedure TfrExportFilter.OnData(x, y: Integer; View: TfrView); begin // abstract method end; procedure TfrExportFilter.OnText(x, y: Integer; const text: String; View: TfrView); begin // abstract method end; {----------------------------------------------------------------------------} constructor TfrFunctionLibrary.Create; begin inherited Create; List := TStringList.Create; //List.Sorted := True; end; destructor TfrFunctionLibrary.Destroy; var i:integer; begin for i:=0 to List.Count-1 do if Assigned(List.Objects[i]) then begin List.Objects[i].Free; List.Objects[i]:=nil; end; List.Free; inherited Destroy; end; function TfrFunctionLibrary.OnFunction(const FName: String; p1, p2, p3: Variant; var val: Variant): Boolean; var i: Integer; begin Result := False; // if List.Find(FName, i) then I:=List.IndexOf(FName); if I>=0 then begin DoFunction(i, p1, p2, p3, val); Result := True; end; end; procedure TfrFunctionLibrary.AddFunctionDesc(funName, funGroup, funDescription: string); var i: Integer; begin if List.Find(funName, i) then begin if not Assigned(List.Objects[i]) then List.Objects[i]:=TfrFunctionDescription.Create; TfrFunctionDescription(List.Objects[i]).funName:=funName; TfrFunctionDescription(List.Objects[i]).funGroup:=funGroup; TfrFunctionDescription(List.Objects[i]).funDescription:=funDescription; end end; {----------------------------------------------------------------------------} constructor TfrStdFunctionLibrary.Create; begin inherited Create; with List do begin Add('AVG'); {0} Add('COUNT'); {1} Add('DAYOF'); {2} Add('FORMATDATETIME'); {3} Add('FORMATFLOAT'); {4} Add('FORMATTEXT'); {5} Add('INPUT'); {6} Add('LENGTH'); {7} Add('LOWERCASE'); {8} Add('MAX'); {9} Add('MAXNUM'); {10} Add('MESSAGEBOX'); {11} Add('MIN'); {12} Add('MINNUM'); {13} Add('MONTHOF'); {14} Add('NAMECASE'); {15} Add('POS'); {16} Add('STRTODATE'); {17} Add('STRTOTIME'); {18} Add('SUM'); {19} Add('TRIM'); {20} Add('UPPERCASE'); {21} Add('YEAROF'); {22} end; AddFunctionDesc('AVG', SAggregateCategory, SDescriptionAVG); AddFunctionDesc('COUNT', SAggregateCategory, SDescriptionCOUNT); AddFunctionDesc('MAX', SAggregateCategory, SDescriptionMAX); AddFunctionDesc('MIN', SAggregateCategory, SDescriptionMIN); AddFunctionDesc('SUM', SAggregateCategory, SDescriptionSUM); AddFunctionDesc('DAYOF', SDateTimeCategory, SDescriptionDAYOF); AddFunctionDesc('MONTHOF', SDateTimeCategory, SDescriptionMONTHOF); AddFunctionDesc('STRTODATE', SDateTimeCategory, SDescriptionSTRTODATE); AddFunctionDesc('STRTOTIME', SDateTimeCategory, SDescriptionSTRTOTIME); AddFunctionDesc('YEAROF', SDateTimeCategory, SDescriptionYEAROF); AddFunctionDesc('FORMATDATETIME', SStringCategory, SDescriptionFORMATDATETIME); AddFunctionDesc('FORMATFLOAT', SStringCategory, SDescriptionFORMATFLOAT); AddFunctionDesc('FORMATTEXT', SStringCategory, SDescriptionFORMATTEXT); AddFunctionDesc('LENGTH', SStringCategory, SDescriptionLENGTH); AddFunctionDesc('LOWERCASE', SStringCategory, SDescriptionLOWERCASE); AddFunctionDesc('NAMECASE', SStringCategory, SDescriptionNAMECASE); AddFunctionDesc('TRIM', SStringCategory, SDescriptionTRIM); AddFunctionDesc('UPPERCASE', SStringCategory, SDescriptionUPPERCASE); AddFunctionDesc('POS', SStringCategory, SDescriptionPOS); AddFunctionDesc('INPUT', SOtherCategory, SDescriptionINPUT); AddFunctionDesc('MESSAGEBOX', SOtherCategory, SDescriptionMESSAGEBOX); AddFunctionDesc('MAXNUM', SMathCategory, SDescriptionMAXNUM); AddFunctionDesc('MINNUM', SMathCategory, SDescriptionMINNUM); end; procedure TfrStdFunctionLibrary.DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: Variant); var DataSet: TfrTDataSet; Field: TfrTField; Obj: TFrObject; s1, s2, VarName: String; min, max, avg, sum, count, d, v: Double; dk: (dkNone, dkSum, dkMin, dkMax, dkAvg, dkCount); vv, v2, v1: Variant; BM : Pointer; begin dk := dkNone; val := '0'; case FNo of 0: dk := dkAvg; //Add('AVG'); {0} 1: dk := dkCount; //Add('COUNT'); {1} 2: val := DayOf(frParser.Calc(p1)); //Add('DAYOF'); {2} 3: val := FormatDateTime(frParser.Calc(p1), frParser.Calc(p2)); //Add('FORMATDATETIME'); {3} 4: val := FormatFloat(frParser.Calc(p1), frParser.Calc(p2)); //Add('FORMATFLOAT'); {4} // 5: val := FormatMaskText(frParser.Calc(p1) + ';0; ', frParser.Calc(p2)); //Add('FORMATTEXT'); {5} 6:begin //Add('INPUT'); {6} s1 := InputBox('', frParser.Calc(p1), frParser.Calc(p2)); val := s1; end; 7:val := Length(frParser.Calc(p1)); //Add('LENGTH'); {7} 8: val := AnsiLowerCase(frParser.Calc(p1)); //Add('LOWERCASE'); {8} 9: dk := dkMax; //Add('MAX'); {9} 10:begin //Add('MAXNUM'); {10} v2 := frParser.Calc(p1); v1 := frParser.Calc(p2); if v2 > v1 then val := v2 else val := v1; end; 11:val := Application.MessageBox(PChar(String(frParser.Calc(p1))), //Add('MESSAGEBOX'); {11} PChar(String(frParser.Calc(p2))), frParser.Calc(p3)); 12: dk := dkMin; //Add('MIN'); {12} 13:begin //Add('MINNUM'); {13} v2 := frParser.Calc(p1); v1 := frParser.Calc(p2); if v2 < v1 then val := v2 else val := v1; end; 14: val := MonthOf(frParser.Calc(p1)); //Add('MONTHOF'); {14} 15:begin //Add('NAMECASE'); {15} s1 := AnsiLowerCase(frParser.Calc(p1)); if Length(s1) > 0 then val := AnsiUpperCase(s1[1]) + Copy(s1, 2, Length(s1) - 1) else val := ''; end; 16:begin // Add('POS'); {16} S1:=frParser.Calc(p1); S2:=frParser.Calc(p2); val := Pos(S1, S2); end; 17: val := StrToDate(frParser.Calc(p1)); //Add('STRTODATE'); {17} 18: val := StrToTime(frParser.Calc(p1)); //Add('STRTOTIME'); {18} 19: dk := dkSum; //Add('SUM'); {19} 20: begin //Add('TRIM'); {20} S1:=frParser.Calc(p1); val := Trim(S1); end; 21: val := AnsiUpperCase(frParser.Calc(p1)); //Add('UPPERCASE'); {21} 22: val := YearOf(frParser.Calc(p1)); //Add('YEAROF'); {22} end; if dk <> dkNone then begin if dk = dkCount then DataSet := frGetDataSet(lrGetUnBrackedStr(p1)) else begin // if bandname is provided if yes, don't try to use dataset/field Obj := curPage.FindObject(trim(P2)); if (obj is TfrBandView) and (TfrBandView(Obj).BandType in [btMasterData,btDetailData, btSubDetailData,btCrossData]) then DataSet := nil else frGetDataSetAndField(lrGetUnBrackedStr(p1), DataSet, Field); end; if (DataSet <> nil) and AggrBand.Visible then begin min := 1e200; max := -1e200; sum := 0; count := 0; avg := 0; BM:=DataSet.GetBookMark; DataSet.DisableControls; try DataSet.First; while not DataSet.Eof do begin v := 0; if dk <> dkCount then begin if not Field.IsNull then v := Field.AsFloat else v := 0; end; if v > max then max := v; if v < min then min := v; sum := sum + v; count := count + 1; DataSet.Next; end; finally DataSet.GotoBookMark(BM); DataSet.FreeBookMark(BM); DataSet.EnableControls; end; if count > 0 then avg := sum / count; d := 0; case dk of dkSum: d := sum; dkMin: d := min; dkMax: d := max; dkAvg: d := avg; dkCount: d := count; end; val := FloatToStr(d); end else if DataSet = nil then begin s1 := Trim(string(p2)); if s1 = '' then s1 := CurBand.View.Name; if dk <> dkCount then s2 := Trim(string(p3)) else s2 := Trim(string(p2)); if (AggrBand.Typ in [btPageFooter, btMasterFooter, btDetailFooter, btSubDetailFooter, btGroupFooter, btCrossFooter, btReportSummary]) and ((s2 = '1') or ((s2 <> '1') and CurBand.Visible)) then begin VarName := List[FNo] + p1; if IsColumns then if AggrBand.Typ = btCrossFooter then VarName := VarName + '00' else VarName := VarName + IntToStr(CurPage.ColPos); if not AggrBand.Visible and (AnsiCompareText(CurBand.View.Name, s1) = 0) then begin s1 := AggrBand.Values.Values[VarName]; if s1 <> '' then if s1[1] = '1' then Exit else s1 := Copy(s1, 2, 255); vv := 0; if dk <> dkCount then vv := frParser.Calc(p1); if VarIsNull(vv) or (TVarData(vv).VType=varEmpty) then vv := 0; d := vv; if s1 = '' then if dk = dkMin then s1 := '1e200' else if dk = dkMax then s1 := '-1e200' else s1 := '0'; v := StrToFloat(s1); case dk of dkAvg: v := v + d; dkCount: v := v + 1; dkMax: if v < d then v := d; dkMin: if v > d then v := d; dkSum: v := v + d; end; AggrBand.Values.Values[VarName] := '1' + FloatToStr(v); Exit; end else if AggrBand.Visible then begin val := Copy(AggrBand.Values.Values[VarName], 2, 255); if dk = dkAvg then val := FloatToStr(StrToFloat(val) / AggrBand.Count); Exit; end; end; end; end; end; {-----------------------------------------------------------------------------} const PropCount = 6; PropNames: Array[0..PropCount - 1] of String = ('Text','FontName', 'FontSize', 'FontStyle', 'FontColor', 'Adjust'); ColNames: Array[0..16] of String = ('clWhite', 'clBlack', 'clMaroon', 'clGreen', 'clOlive', 'clNavy', 'clPurple', 'clTeal', 'clGray', 'clSilver', 'clRed', 'clLime', 'clYellow', 'clBlue', 'clFuchsia', 'clAqua', 'clTransparent'); {$WARNINGS OFF} procedure TInterpretator.GetValue(const Name: String; var Value: Variant); var t : TfrObject; Prop : String; PropInfo : PPropInfo; St : String; i : Integer; begin {$IFDEF DebugLR} DebugLn('TInterpretator.GetValue(',Name,') INIT'); {$ENDIF} //Value := 0; t := CurView; Prop := Name; if frVariables.IndexOf(Name) <> -1 then begin Value := frVariables[Name]; Exit; end; if Name = 'FREESPACE' then begin Value:=IntToStr(CurPage.CurBottomY-CurPage.CurY); Exit; end; if Pos('.', Name) <> 0 then begin //Find Object t := CurPage.FindRTObject(Copy(Name, 1, Pos('.', Name) - 1)); //Property of object Prop:=Copy(Name, Pos('.',Name)+1,255); end; if not Assigned(t) then frParser.OnGetValue(Name, Value) else begin //Retreive property informations PropInfo:=GetPropInfo(t,Prop); if Assigned(PropInfo) then begin {$IFDEF DebugLR} DebugLn('TInterpretator.GetValue(',Name,') Prop=',Prop, ' Kind=',InttoStr(Ord(PropInfo^.PropType^.Kind))); {$ENDIF} Case PropInfo^.PropType^.Kind of tkChar,tkAString,tkWString, tkSString,tkLString : begin St:=GetStrProp(t,Prop); {$IFDEF DebugLR} DebugLn('St=',St); {$ENDIF} Value:=St; end; tkBool,tkInt64,tkQWord, tkInteger : Value:=GetOrdProp(t,PropInfo); tkSet : begin St:=GetSetProp(t,Prop); {$IFDEF DebugLR} DebugLn('St=',St); {$ENDIF} Value:=St; end; tkFloat : Value:=GetFloatProp(t,Prop); tkEnumeration : begin St:=GetEnumProp(t,Prop); {$IFDEF DebugLR} DebugLn('St=',St); {$ENDIF} Value:=St; end; end; end else begin // it's not a property of t, try with known color names first for i := 0 to 16 do if AnsiCompareText(ColNames[i], Prop) = 0 then begin // color constant found. if i <> 16 then Value := frColors[i] else Value := clNone; exit; end; // it's not a color name, try with customized properties // not included directly in t if not (t is TfrBandView) then begin for i:=0 to propcount-1 do if CompareText(PropNames[i], Prop)=0 then begin {$IFDEF DebugLR} DbgOut('A CustomField was found ', Prop); if i=0 then DbgOut(', t.memo.text=',DbgStr(t.Memo.Text)); DebugLn; {$ENDIF} case i of 0: Value := t.Memo.Text; 1: Value := TfrMemoView(t).Font.Name; 2: Value := TfrMemoView(t).Font.Size; 3: Value := frGetFontStyle(TfrMemoView(t).Font.Style); 4: Value := TfrMemoView(t).Font.Color; 5: Value := TfrMemoView(t).Adjust; end; exit; end; end; // no luck yet, try next if it's a custom variable if Assigned(frParser.OnGetValue) then frParser.OnGetValue(Name, Value); end; {$IFDEF DebugLR} DebugLn('TInterpretator.GetValue(',Name,') No Propinfo for Prop=',Prop); {$ENDIF} if VarIsNull(Value) or VarIsEmpty(Value) then begin {$IFDEF DebugLR} DebugLn('TInterpretator.GetValue(',Name,')=NULL >> Value="',Name,'"'); {$ENDIF} Value:=Name; end {$IFDEF DebugLR} else DebugLn('TInterpretator.GetValue(',Name,')=',VarToStr(Value)); {$ENDIF} end; end; {$WARNINGS ON} procedure TInterpretator.SetValue(const Name: String; Value: Variant); var t : TfrObject; Prop : String; PropInfo : PPropInfo; St : String; i : Integer; begin {$IFDEF DebugLR} DebugLn('TInterpretator.SetValue(',Name,',',Value,')'); if VarIsNull(Value) or VarIsEmpty(Value) then DebugLn('Value=NULL'); {$ENDIF} t := CurView; Prop := Name; if Pos('.', Name) <> 0 then begin St := Copy(Name, 1, Pos('.', Name) - 1); {$IFDEF DebugLR} DebugLn('Trying to find RT Object "',St,'"'); {$ENDIF} t := CurPage.FindRTObject(St); Prop := Copy(Name, Pos('.', Name) + 1, 255); end; {$IFDEF DebugLR} DebugLn('t=', dbgsName(t),' Prop=',Prop); {$ENDIF} //Retreive property informations PropInfo:=GetPropInfo(t,Prop); if Assigned(PropInfo) then begin St:=VarToStr(Value); {$IFDEF DebugLR} DebugLn('PropInfo for ',prop,' found, Setting Value=',St); {$ENDIF} Case PropInfo^.PropType^.Kind of tkChar,tkAString,tkWString, tkSString,tkLString : SetStrProp(t,Prop,St); tkBool,tkInt64,tkQWord, tkInteger : begin if AnsiCompareText(PropInfo^.PropType^.Name,'TGraphicsColor')=0 then SetOrdProp(t,PropInfo,StringToColor(St)) else SetOrdProp(t,PropInfo,Value) end; tkSet : SetSetProp(t,Prop,St); tkFloat : SetFloatProp(t,Prop,Value); tkEnumeration : SetEnumProp(t,Prop,St); end; end else begin if not (t is TfrBandView) then begin // try with customized properties not included directly in t for i:=0 to propcount-1 do if CompareText(PropNames[i], Prop)=0 then begin {$IFDEF DebugLR} DbgOut('A CustomField was found ', Prop); if i=0 then DbgOut(', t.memo.text=',DbgStr(t.Memo.Text),' nuevo valor=',VarToStr(Value)); DebugLn; {$ENDIF} case i of 0: t.Memo.Text := Value; 1: TfrMemoView(t).Font.Name := Value; 2: TfrMemoView(t).Font.Size := Value; 3: TfrMemoView(t).Font.Style := frSetFontStyle(Value); 4: TfrMemoView(t).Font.Color := Value; 5: TfrMemoView(t).Adjust := Value; end; exit; end; end; // not found, treat it as a variable {$IFDEF DebugLR} DebugLn('frVariables[',Name,'] := ',Value); {$ENDIF} frVariables[Name] := Value; Exit; end; end; procedure TInterpretator.DoFunction(const Name: String; p1, p2, p3: Variant; var val: Variant); begin if Name = 'NEWPAGE' then begin CurBand.ForceNewPage := True; Val := '0'; end else if Name = 'NEWCOLUMN' then begin CurBand.ForceNewColumn := True; Val := '0'; end else frParser.OnFunction(Name, p1, p2, p3, val); end; {----------------------------------------------------------------------------} procedure TfrCompressor.Compress(StreamIn, StreamOut: TStream); begin // abstract method end; procedure TfrCompressor.DeCompress(StreamIn, StreamOut: TStream); begin // abstract method end; {----------------------------------------------------------------------------} procedure DoInit; begin RegisterClasses([TfrPageReport,TfrPageDialog]); frDesigner:=nil; SMemo := TStringList.Create; frRegisterFunctionLibrary(TfrStdFunctionLibrary); frCharset := StrToInt(sCharset); frBandNames[btReportTitle] := sBand1; frBandNames[btReportSummary] := sBand2; frBandNames[btPageHeader] := sBand3; frBandNames[btPageFooter] := sBand4; frBandNames[btMasterHeader] := sBand5; frBandNames[btMasterData] := sBand6; frBandNames[btMasterFooter] := sBand7; frBandNames[btDetailHeader] := sBand8; frBandNames[btDetailData] := sBand9; frBandNames[btDetailFooter] := sBand10; frBandNames[btSubDetailHeader] := sBand11; frBandNames[btSubDetailData] := sBand12; frBandNames[btSubDetailFooter] := sBand13; frBandNames[btOverlay] := sBand14; frBandNames[btColumnHeader] := sBand15; frBandNames[btColumnFooter] := sBand16; frBandNames[btGroupHeader] := sBand17; frBandNames[btGroupFooter] := sBand18; frBandNames[btCrossHeader] := sBand19; frBandNames[btCrossData] := sBand20; frBandNames[btCrossFooter] := sBand21; frBandNames[btNone] := sBand22; frSpecArr[0] := sVar1; frSpecArr[1] := sVar2; frSpecArr[2] := sVar3; frSpecArr[3] := sVar4; frSpecArr[4] := sVar5; frSpecArr[5] := sVar6; frSpecArr[6] := sVar7; frSpecArr[7] := sVar8; frSpecArr[8] := sVar9; BoolStr[0] :=SFormat51; BoolStr[1] :=SFormat52; BoolStr[2] :=SFormat53; BoolStr[3] :=SFormat54; frDateFormats[0] :=sDateFormat1; frDateFormats[1] :=sDateFormat2; frDateFormats[2] :=sDateFormat3; frDateFormats[3] :=sDateFormat4; frTimeFormats[0] :=sTimeFormat1; frTimeFormats[1] :=sTimeFormat2; frTimeFormats[2] :=sTimeFormat3; frTimeFormats[3] :=sTimeFormat4; frParser := TfrParser.Create; frInterpretator := TInterpretator.Create; frVariables := TfrVariables.Create; frCompressor := TfrCompressor.Create; HookList := TList.Create; end; procedure DoExit; var i: Integer; begin SBmp.Free; TempBmp.Free; SMemo.Free; frProgressForm.Free; for i := 0 to frFunctionsCount - 1 do frFunctions[i].FunctionLibrary.Free; frParser.Free; frInterpretator.Free; frVariables.Free; frCompressor.Free; HookList.Free; end; { TfrObject } procedure TfrObject.SetMemo(const AValue: TfrMemoStrings); begin if fMemo=AValue then exit; fMemo.Assign(AValue); end; procedure TfrObject.SetName(const AValue: string); var i : Integer; Flg : Boolean; begin if fName=AValue then exit; Flg:=False; {if Assigned(Objects) then begin for i:=0 to Objects.Count-1 do begin if (TfrView(Objects[i]).Name=aValue) then begin Flg:=True; MessageDlg('This name it''s already exists.',mtError,[mbOk],0); Break; end; end; end; } if not Flg then fName:=AValue; end; procedure TfrObject.SetScript(const AValue: TfrScriptStrings); begin if fScript=AValue then exit; fScript.Assign(AValue); end; //Code from FormStorage function TfrObject.GetSaveProperty(Prop: String; aObj : TPersistent=nil): string; Var PropInfo : PPropInfo; Obj : TObject; OldSep : char; begin Result:=''; if not Assigned(aObj) then aObj:=Self; Try PropInfo:=GetPropInfo(aObj,Prop); if Assigned(PropInfo) then begin Case PropInfo^.PropType^.Kind of tkChar,tkAString,tkWString, tkSString,tkLString : Result:=GetStrProp(aObj,Prop); tkBool,tkInt64,tkQWord, tkInteger : begin if PropInfo^.PropType^.Name='TGraphicsColor' then Result:=ColorToString(GetOrdProp(aObj,PropInfo)) else Result:=IntToStr(GetOrdProp(aObj,PropInfo)); end; tkSet : Result:=GetSetProp(aObj,Prop); tkFloat : begin OldSep := DecimalSeparator; DecimalSeparator := '.'; Result := FloatToStr(GetFloatProp(aObj,Prop)); DecimalSeparator := OldSep; end; tkEnumeration : Result:=GetEnumProp(aObj,Prop); tkClass : Begin Obj:=GetObjectProp(aObj,Prop); if Obj Is TStrings then Result:=TStrings(Obj).CommaText else Result:=Format('Object "%s" not implemented',[PropInfo^.PropType^.Name]); end; end; end else Result:='??'; Except End; end; //Code from formStorage procedure TfrObject.RestoreProperty(Prop, aValue: String; aObj : TPersistent=nil); Var PropInfo : PPropInfo; Obj : TObject; begin Try if not Assigned(aObj) then aObj:=Self; PropInfo:=GetPropInfo(aObj,Prop); if Assigned(PropInfo) then begin Case PropInfo^.PropType^.Kind of tkChar,tkAString,tkWString, tkSString,tkLString : SetStrProp(aObj,Prop,aValue); tkBool,tkInt64,tkQWord, tkInteger : begin if PropInfo^.PropType^.Name='TGraphicsColor' then SetOrdProp(aObj,PropInfo,StringToColor(aValue)) else SetOrdProp(aObj,PropInfo,StrToInt(aValue)) end; tkSet : SetSetProp(aObj,Prop,aValue); tkFloat : SetFloatProp(aObj,Prop,StrToFloat(aValue)); tkEnumeration : SetEnumProp(aObj,Prop,aValue); tkClass : Begin Obj:=GetObjectProp(aObj,Prop); if Obj Is TStrings then TStrings(Obj).CommaText:=aValue; end; end; end; Except End; end; constructor TfrObject.Create; begin inherited Create; fUpdate:=0; BaseName:='LRObj'; fVisible:=True; fMemo:=TfrMemoStrings.Create; fScript:=TfrScriptStrings.Create; end; destructor TfrObject.Destroy; begin fmemo.Free; fScript.Free; inherited Destroy; end; procedure TfrObject.Assign(From: TfrView); begin x := From.x; y := From.y; dx := From.dx; dy := From.dy; Memo.Assign(From.Memo); Script.Assign(From.Script); Visible:=From.Visible; end; procedure TfrObject.BeginUpdate; begin Inc(fUpdate) end; procedure TfrObject.EndUpdate; begin if fUpdate>0 then Dec(fUpdate) end; procedure TfrObject.CreateUniqueName; var i: Integer; begin fName := ''; if Assigned(CurReport) then begin for i := 1 to 10000 do begin if CurReport.FindObject(BaseName + IntToStr(i)) = nil then begin fName := BaseName + IntToStr(i); Exit; end; end; end else fName := BaseName + '1'; end; procedure TfrObject.LoadFromXML(XML: TXMLConfig; Path: String); begin //ClassName not read here. Name:=XML.GetValue(Path+'Name/Value',''); if Name='' then CreateUniqueName; Visible:=XML.GetValue(Path+'Visible/Value', true); end; procedure TfrObject.SaveToXML(XML: TXMLConfig; Path: String); begin XML.SetValue(Path+'Name/Value', GetSaveProperty('Name')); XML.SetValue(Path+'ClassName/Value', self.Classname); XML.SetValue(Path+'Visible/Value', GetSaveProperty('Visible')); end; { TfrRect } function TfrRect.GetRect: TRect; begin Result:=Rect(Left,Top,Right,Bottom); end; procedure TfrRect.SetRect(const AValue: TRect); begin fLeft:=aValue.Left; fRight:=aValue.Right; fBottom:=aValue.Bottom; fTop:=aValue.Top; end; { TfrPageReport } procedure TfrPageReport.LoadFromXML(XML: TXMLConfig; Path: String); var Rc : TRect; begin inherited LoadFromXML(XML, Path); pgSize := XML.GetValue(Path+'PgSize/Value', 0); // TODO chk rc.left := XML.GetValue(Path+'Margins/left/Value', 0); // TODO chk rc.top := XML.GetValue(Path+'Margins/Top/Value', 0); // TODO chk rc.Right := XML.GetValue(Path+'Margins/Right/Value', 0); // TODO chk rc.Bottom := XML.GetValue(Path+'Margins/Bottom/Value', 0); // TODO chk Margins.AsRect := rc; RestoreProperty('Orientation',XML.GetValue(Path+'Orientation/Value','')); UseMargins := XML.GetValue(Path+'UseMargins/Value', True); // TODO chk PrintToPrevPage := XML.GetValue(Path+'PrintToPrevPage/Value', True); // TODO chk ColCount := XML.GetValue(Path+'ColCount/Value', 1); // TODO chk ColGap := XML.GetValue(Path+'ColGap/Value', 0); RestoreProperty('LayoutOrder',XML.GetValue(Path+'LayoutOrder/Value','')); ChangePaper(pgSize, Width, Height, Orientation); end; procedure TfrPageReport.SavetoXML(XML: TXMLConfig; Path: String); var Rc : TRect; begin inherited SavetoXML(XML, Path); Rc:=Margins.AsRect; XML.SetValue(Path+'PgSize/Value', PgSize); XML.SetValue(Path+'Margins/left/Value', Rc.Left); XML.SetValue(Path+'Margins/Top/Value', Rc.Top); XML.SetValue(Path+'Margins/Right/Value', Rc. Right); XML.SetValue(Path+'Margins/Bottom/Value', Rc.Bottom); XML.SetValue(Path+'Orientation/Value', GetSaveProperty('Orientation')); XML.SetValue(Path+'UseMargins/Value', UseMargins); XML.SetValue(Path+'PrintToPrevPage/Value', PrintToPrevPage); XML.SetValue(Path+'ColCount/Value', ColCount); XML.SetValue(Path+'ColGap/Value', ColGap); XML.SetValue(Path+'LayoutOrder/Value', GetSaveProperty('LayoutOrder')); end; constructor TfrPageReport.CreatePage; begin self.Create(prn.DefaultPageSize, 0, 0, poPortrait); end; { TfrPageDialog } procedure TfrPageDialog.PrepareObjects; begin //Do nothing end; procedure TfrPageDialog.InitReport; var i : Integer; begin //inherited InitReport; fHasVisibleControls:=False; end; constructor TfrPageDialog.Create; begin inherited Create; fForm :=nil; BaseName:='Dialog'; Width :=200; Height:=150; PageType:=ptDialog; end; procedure TfrPageDialog.LoadFromXML(XML: TXMLConfig; Path: String); begin inherited LoadFromXML(XML, Path); XML.GetValue(Path+'Caption/Value', ''); end; procedure TfrPageDialog.SavetoXML(XML: TXMLConfig; Path: String); begin inherited SavetoXML(XML, Path); XML.SetValue(Path+'Caption/Value', Caption); end; initialization DoInit; finalization DoExit; end.