paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-04 08:03:56 +02:00
Code Issues Packages Projects Releases Wiki Activity
993bd7b87d
lazarus/components/lazreport/source/lr_class.pas
jesus 993bd7b87d LazReport, fix compilation win 64, issue #12798 
git-svn-id: trunk@17834 -
2008-12-14 18:27:04 +00:00

9776 lines
252 KiB
ObjectPascal
Raw Blame History

{*****************************************}
{ }
{ 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,XMLConf,
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);
{ TLrXMLConfig }
TLrXMLConfig = class (TXMLConfig)
public
procedure SetValue(const APath: string; const AValue: string); overload;
function GetValue(const APath: string; const ADefault: string): string; overload;
end;
{ 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: TLrXMLConfig; Path: String); virtual;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String);
procedure WriteBinaryData(Stream: TStream);
procedure WriteBinaryDataToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SavetoXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SavetoXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String); override;
procedure SavetoXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String);
procedure SaveToStream(Stream: TStream);
procedure SavetoXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String);
procedure SaveToStream(AStream: TStream);
procedure SaveToXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String);
procedure SaveToStream(Stream: TStream);
procedure LoadFromFile(FName: String);
procedure LoadFromXMLFile(Fname: String);
procedure SaveToFile(FName: String);
procedure SavetoXML(XML: TLrXMLConfig; 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;
end;
TfrDataManager = class(TObject)
public
procedure Clear; virtual; abstract;
procedure LoadFromStream(Stream: TStream); virtual; abstract;
procedure LoadFromXML(XML:TLrXMLConfig; Path: String); virtual; abstract;
procedure SaveToStream(Stream: TStream); virtual; abstract;
procedure SaveToXML(XML:TLrXMLConfig; 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];
frUnwrapRead: boolean = false; // TODO: remove this for 0.9.28
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: TLrXMLConfig; 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: TLrXMLConfig; 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 (aX<Rc.Right) and (aY>Rc.Top) and (aY<Rc.Bottom));
end;
procedure TfrView.Invalidate;
begin
if Assigned(Canvas) and (fUpdate=0) then
Draw(Canvas);
end;
procedure TfrView.DefinePopupMenu(Popup: TPopupMenu);
var
m: TMenuItem;
begin
m := TMenuItem.Create(Popup);
m.Caption := '-';
Popup.Items.Add(m);
m := TMenuItem.Create(Popup);
m.Caption := sStretched;
m.OnClick := @P1Click;
m.Checked := (Flags and flStretched) <> 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);
begin
if frDesigner<>nil then begin
BeforeChange;
dy := frDesigner.UnitsToPoints(AValue);
AfterChange;
end else
dy := round(Avalue);
end;
procedure TfrView.SetLeft(const AValue: Double);
begin
if frDesigner<>nil then begin
BeforeChange;
x := frDesigner.UnitsToPoints(AValue);
AfterChange;
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);
begin
if frDesigner<>nil then begin
BeforeChange;
y := frDesigner.UnitsToPoints(AValue);
AfterChange;
end else
y := round(AValue);
end;
procedure TfrView.SetWidth(const AValue: Double);
begin
if frDesigner<>nil then begin
BeforeChange;
dx := frDesigner.UnitsToPoints(AValue);
AfterChange;
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 = ['<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>', '<27>'];
r_sogl: set of Char = ['<27>', '<27>'];
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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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 (aX<Rc.Right) and (aY>Rc.Top) and (aY<Rc.Bottom));
{$IFDEF DebugLR}
DbgOut('(',IntToStr(aX),'>',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 (aX<Rc.Right) and (aY>Rc.Top) and (aY<Rc.Bottom));
{$IFDEF DebugLR}
DbgOut('(',InttoStr(aX),'>',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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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;
type
TBookRecord = record
Dataset: TfrDataset;
Bookmark: Pointer;
end;
var
BndStack: Array[1..MAXBNDS * 3] of TfrBand;
MaxLevel, BndStackTop: Integer;
i, sfPage : Integer;
HasGroups : Boolean;
DetailCount : Integer;
BooksBkUp : array of TBookRecord;
procedure AddToStack(b: TfrBand);
begin
if b <> nil then
begin
Inc(BndStackTop);
BndStack[BndStackTop] := b;
end;
end;
procedure BackupBookmark(b: TfrBand);
var
n: Integer;
begin
n := Length(BooksBkUp);
SetLength(BooksBkUp, n+1);
BooksBkUp[n].Dataset := b.Dataset;
BooksBkUp[n].Bookmark := b.Dataset.GetBookmark;
if b.Typ in [btDetailData,btSubDetailData] then
inc(DetailCount);
end;
procedure RestoreBookmarks;
var
n: Integer;
begin
for n:=0 to Length(BooksBkUp)-1 do
with BooksBkUp[n] do begin
Dataset.GotoBookMark(Bookmark);
Dataset.FreeBookMark(Bookmark);
if DetailCount=0 then
Dataset.EnableControls;
end;
SetLength(BooksBkUp, 0);
end;
procedure DisableControls;
var
n: Integer;
begin
if DetailCount=0 then
for n:=0 to Length(BooksBkUp)-1 do
BooksBkUp[n].Dataset.DisableControls;
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
try
b.DataSet.First;
//if Level<>1 then begin
// b.Dataset.Refresh;
//end;
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
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;
SetLength(BooksBkUp, 0);
DetailCount := 0;
for i := 1 to MAXBNDS do
begin
if BandExists(Bands[Bnds[i, bpData]]) then
begin
MaxLevel := i;
BackupBookmark(Bands[Bnds[i, bpData]]);
end;
end;
HasGroups := Bands[btGroupHeader].Objects.Count > 0;
{$IFDEF DebugLR}
DebugLn('%sMaxLevel=%d doing DoLoop(1)',[sspc,MaxLevel]);
{$ENDIF}
DisableControls;
DoLoop(1);
RestoreBookmarks; // this also enablecontrols
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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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
if VarIsType(v, varDate) and (trunc(Extended(v))=0) then
Result := TimeToStr(v)
else
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: TLrXMLConfig; 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: TLrXMLConfig;
begin
{$IFDEF ver2_0_0}
XML := TLrXMLConfig.Create(FName);
{$ELSE}
XML := TLrXMLConfig.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: TLrXMLConfig; 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: TLrXMLConfig;
begin
{$IFDEF ver2_0_0}
XML := TLrXMLConfig.CreateClean(FName);
{$ELSE}
XML := TLrXMLConfig.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
{$ifdef dbgPrinter}
DebugLn('TfrReport.SetPrinterTo PrnName=%s PrintToDefault=%d PrnExist?=%d PrnIndex=%d PrinterIndex=%d Name=%s',
[prnName, Ord(PrintToDefault), Ord(Prn.Printers.IndexOf(PrnName)>=0),
prn.PrinterIndex, Prn.Printer.PrinterIndex, prn.Printer.Printers[prn.Printer.PrinterIndex]]);
{$endif}
if not PrintToDefault then
begin
if Prn.Printers.IndexOf(PrnName) <> -1 then
Prn.PrinterIndex := Prn.Printers.IndexOf(PrnName)
else
if Prn.Printers.Count>0 then
Prn.PrinterIndex := 0 // either the system default or
// own virtual default printer
end;
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
{$ifdef dbgPrinter}
DebugLn('TfrReport.ChangePrinter CurIndex=%d OldIndex=%d NewIndex=%d',
[Prn.PrinterIndex,OldIndex,NewIndex]);
{$endif}
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: TLrXMLConfig; 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: TLrXMLConfig; 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: TLrXMLConfig; 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','loColumns'));
ChangePaper(pgSize, Width, Height, Orientation);
end;
procedure TfrPageReport.SavetoXML(XML: TLrXMLConfig; 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: TLrXMLConfig; Path: String);
begin
inherited LoadFromXML(XML, Path);
XML.GetValue(Path+'Caption/Value', '');
end;
procedure TfrPageDialog.SavetoXML(XML: TLrXMLConfig; Path: String);
begin
inherited SavetoXML(XML, Path);
XML.SetValue(Path+'Caption/Value', Caption);
end;
{ TLrXMLConfig }
procedure TLrXMLConfig.SetValue(const APath: string; const AValue: string);
begin
inherited SetValue(UTF8Decode(APath), UTF8Decode(AValue));
end;
function TLrXMLConfig.GetValue(const APath: string; const ADefault: string
): string;
var
wValue: widestring;
begin
if frUnWrapRead then
result := inherited GetValue(APath, ADefault)
else
begin
WValue := inherited GetValue(UTF8Decode(APath), UTF8Decode(ADefault));
Result := UTF8Encode(WValue);
end;
end;
initialization
DoInit;
finalization
DoExit;
end.
Reference in New Issue View Git Blame Copy Permalink