/Source/FR_Class.pas
Pascal | 7335 lines | 6646 code | 487 blank | 202 comment | 865 complexity | 52e74cfa96e31edbea7bd9f745adfb88 MD5 | raw file
-
- {*****************************************}
- { }
- { FastReport v2.3 }
- { Report classes }
- { }
- { Copyright (c) 1998-99 by Tzyganenko A. }
- { }
- {*****************************************}
-
- unit FR_Class;
-
- interface
-
- {$I FR.inc}
-
- uses
- SysUtils, Windows, Messages, Classes, Graphics, Printers, Controls,
- Forms, StdCtrls, ComCtrls, Dialogs, Menus, Buttons,
- FR_View, FR_Pars, FR_Intrp, FR_DSet, FR_DBSet, FR_DBRel
- {$IFDEF Delphi6}
- , Variants
- {$ENDIF}
- {$IFDEF IBO}
- , IB_Components
- {$ELSE}
- , DB
- {$ENDIF};
-
-
- 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;
-
- // frame types
- frftNone = 0;
- frftRight = 1;
- frftDown = 2;
- frftLeft = 4;
- frftUp = 8;
-
- // text align
- frtaLeft = 0;
- frtaRight = 1;
- frtaCenter = 2;
- frtaVertical = 4;
- frtaMiddle = 8;
- frtaDown = 16;
-
- 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);
-
- 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;
- TProgressEvent = 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;
-
- TfrPrnInfo = record // print info about page size, margins e.t.c
- 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, 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;
-
- TfrView = class(TObject)
- private
- procedure P1Click(Sender: TObject);
- protected
- SaveX, SaveY, SaveDX, SaveDY: Integer;
- SaveFW: Single;
- BaseName: String;
- Canvas: TCanvas;
- DRect: TRect;
- gapx, gapy: Integer;
- Memo1: TStringList;
- FDataSet: TfrTDataSet;
- FField: String;
- olddy: Integer;
- StreamMode: (smDesigning, smPrinting);
- procedure ShowBackGround; virtual;
- procedure ShowFrame; virtual;
- procedure BeginDraw(ACanvas: TCanvas);
- procedure GetBlob(b: TfrTField); virtual;
- procedure OnHook(View: TfrView); virtual;
- public
- Parent: TfrBand;
- Name: String;
- ID: Integer;
- Typ: Byte;
- Selected: Boolean;
- OriginalRect: TRect;
- ScaleX, ScaleY: Double; // used for scaling objects in preview
- OffsX, OffsY: Integer; //
- IsPrinting: Boolean;
- x, y, dx, dy: Integer;
- Flags: Word;
- FrameTyp: Word;
- FrameWidth: Single;
- FrameColor: TColor;
- FrameStyle: Word;
- FillColor: TColor;
- Format: Integer;
- FormatStr: String;
- Visible: WordBool;
- Memo, Script: TStringList;
- constructor Create; virtual;
- destructor Destroy; override;
- procedure Assign(From: TfrView); virtual;
- procedure CalcGaps; virtual;
- procedure RestoreCoord; virtual;
- procedure Draw(Canvas: TCanvas); virtual; abstract;
- procedure Print(Stream: TStream); virtual;
- procedure ExportData; virtual;
- procedure LoadFromStream(Stream: TStream); virtual;
- procedure SaveToStream(Stream: TStream); virtual;
- procedure SaveToFR3Stream(Stream: TStream); virtual;
- procedure Resized; virtual;
- procedure DefinePopupMenu(Popup: TPopupMenu); virtual;
- function GetClipRgn(rt: TfrRgnType): HRGN; virtual;
- procedure CreateUniqueName;
- procedure SetBounds(Left, Top, Width, Height: Integer);
- end;
-
- TfrStretcheable = class(TfrView)
- protected
- ActualHeight: Integer;
- DrawMode: TfrDrawMode;
- function CalcHeight: Integer; virtual; abstract;
- function MinHeight: Integer; virtual; abstract;
- function RemainHeight: Integer; virtual; abstract;
- end;
-
- TfrMemoView = class(TfrStretcheable)
- private
- FFont: TFont;
- procedure P1Click(Sender: TObject);
- procedure P2Click(Sender: TObject);
- procedure P3Click(Sender: TObject);
- procedure P4Click(Sender: TObject);
- procedure P5Click(Sender: TObject);
- procedure SetFont(Value: TFont);
- protected
- Streaming: Boolean;
- TextHeight: Integer;
- CurStrNo: Integer;
- Exporting: Boolean;
- procedure ExpandVariables;
- procedure AssignFont(Canvas: TCanvas);
- procedure WrapMemo;
- procedure ShowMemo;
- function CalcWidth(Memo: TStringList): Integer;
- function CalcHeight: Integer; override;
- function MinHeight: Integer; override;
- function RemainHeight: Integer; override;
- procedure GetBlob(b: TfrTField); override;
- public
- Adjust: Integer;
- Highlight: TfrHighlightAttr;
- HighlightStr: String;
- LineSpacing, CharacterSpacing: Integer;
- constructor Create; override;
- destructor Destroy; override;
- procedure Assign(From: TfrView); override;
- procedure Draw(Canvas: TCanvas); override;
- procedure Print(Stream: TStream); override;
- procedure ExportData; override;
- procedure LoadFromStream(Stream: TStream); override;
- procedure SaveToStream(Stream: TStream); override;
- procedure SaveToFR3Stream(Stream: TStream); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- property Font: TFont read FFont write SetFont;
- end;
-
- TfrBandView = class(TfrView)
- private
- procedure P1Click(Sender: TObject);
- procedure P2Click(Sender: TObject);
- procedure P3Click(Sender: TObject);
- procedure P4Click(Sender: TObject);
- procedure P5Click(Sender: TObject);
- procedure P6Click(Sender: TObject);
- function GetBandType: TfrBandType;
- procedure SetBandType(const Value: TfrBandType);
- public
- constructor Create; override;
- procedure Draw(Canvas: TCanvas); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- function GetClipRgn(rt: TfrRgnType): HRGN; override;
- procedure SaveToFR3Stream(Stream: TStream); override;
- property BandType: TfrBandType read GetBandType write SetBandType;
- property DataSet: String read FormatStr write FormatStr;
- property GroupCondition: String read FormatStr write FormatStr;
- end;
-
- TfrSubReportView = class(TfrView)
- public
- SubPage: Integer;
- constructor Create; override;
- procedure Assign(From: TfrView); override;
- procedure Draw(Canvas: TCanvas); override;
- procedure LoadFromStream(Stream: TStream); override;
- procedure SaveToStream(Stream: TStream); override;
- procedure SaveToFR3Stream(Stream: TStream); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- end;
-
- TfrPictureView = class(TfrView)
- private
- procedure P1Click(Sender: TObject);
- procedure P2Click(Sender: TObject);
- protected
- procedure GetBlob(b: TfrTField); override;
- public
- Picture: TPicture;
- constructor Create; override;
- destructor Destroy; override;
- procedure Assign(From: TfrView); override;
- procedure Draw(Canvas: TCanvas); override;
- procedure LoadFromStream(Stream: TStream); override;
- procedure SaveToStream(Stream: TStream); override;
- procedure SaveToFR3Stream(Stream: TStream); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- end;
-
- TfrLineView = class(TfrView)
- public
- constructor Create; override;
- procedure Draw(Canvas: TCanvas); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- function GetClipRgn(rt: TfrRgnType): HRGN; override;
- procedure SaveToFR3Stream(Stream: TStream); override;
- end;
-
- TfrBand = class(TObject)
- 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(y, dy: Integer; PBreak: Boolean): Boolean;
- procedure DrawPageBreak;
- function HasCross: Boolean;
- function DoCalcHeight: Integer;
- procedure DoDraw;
- function Draw: Boolean;
- procedure InitValues;
- procedure DoAggregate;
- public
- x, y, dx, dy, maxdy: Integer;
- Typ: TfrBandType;
- PrintIfSubsetEmpty, NewPageAfter, Stretched, PageBreak, Visible: Boolean;
- Objects: TList;
- Memo, Script: TStringList;
- DataSet: TfrDataSet;
- IsVirtualDS: Boolean;
- VCDataSet: TfrDataSet;
- IsVirtualVCDS: Boolean;
- GroupCondition: String;
- ForceNewPage, ForceNewColumn: Boolean;
- constructor Create(ATyp: TfrBandType; AParent: TfrPage);
- 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 = 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 WriteBinaryData(Stream: TStream);
- procedure Clear;
- property Items: TStringList read FItems write FItems;
- property Objects[Index: Integer]: TfrValue read GetValue;
- end;
-
- TfrPage = class(TObject)
- private
- Bands: Array[TfrBandType] of TfrBand;
- Skip, InitFlag: Boolean;
- CurColumn, LastStaticColumnY, XAdjust: Integer;
- List: TList;
- Mode: TfrPageMode;
- PlayFrom: Integer;
- LastBand: TfrBand;
- ColPos, CurPos: Integer;
- procedure InitReport;
- procedure DoneReport;
- procedure TossObjects;
- procedure PrepareObjects;
- procedure FormPage;
- 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 AfterPrint;
- procedure LoadFromStream(Stream: TStream);
- procedure SaveToStream(Stream: TStream);
- procedure ShowBand(b: TfrBand);
- public
- pgSize, pgWidth, pgHeight: Integer;
- pgMargins: TRect;
- pgOr: TPrinterOrientation;
- PrintToPrevPage, UseMargins: WordBool;
- PrnInfo: TfrPrnInfo;
- ColCount, ColWidth, ColGap: Integer;
- Objects, RTObjects: TList;
- CurY, CurBottomY: Integer;
- constructor Create(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation);
- destructor Destroy; 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(Name: String): TfrView;
- function FindRTObject(Name: String): TfrView;
- procedure ChangePaper(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation);
- procedure ShowBandByName(s: String);
- procedure ShowBandByType(bt: TfrBandType);
- procedure NewPage;
- procedure NewColumn(Band: TfrBand);
- end;
-
- 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;
- procedure Delete(Index: Integer);
- procedure LoadFromStream(Stream: TStream);
- procedure SaveToStream(Stream: TStream);
- property Pages[Index: Integer]: TfrPage read GetPages; default;
- property Count: Integer read GetCount;
- end;
-
- 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 SaveToStream(AStream: TStream);
- property Pages[Index: Integer]: PfrPageInfo read GetPages; default;
- property Count: Integer read GetCount;
- end;
-
- TfrReport = class(TComponent)
- private
- FPages: TfrPages;
- FEMFPages: TfrEMFPages;
- FVars: TStrings;
- FVal: TfrValues;
- FDataset: TfrDataset;
- FGrayedButtons: Boolean;
- FReportType: TfrReportType;
- FTitle: String;
- 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: TProgressEvent;
- FOnFunction: TFunctionEvent;
- FOnBeginColumn: TBeginColumnEvent;
- FOnPrintColumn: TPrintColumnEvent;
- FOnManualBuild: TManualBuildEvent;
- FCurrentFilter: TfrExportFilter;
- FPageNumbers: String;
- FCopies: Integer;
- FCurPage: TfrPage;
- function FormatValue(V: Variant; Format: Integer;
- const FormatStr: String): String;
- procedure OnGetParsFunction(const name: String; p1, p2, p3: Variant;
- var val: String);
- 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 SetPrinterTo(PrnName: String);
- procedure SetVars(Value: TStrings);
- 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;
- FR3Stream: Boolean;
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- // service methods
- function FindVariable(Variable: String): Integer;
- procedure GetVariableValue(const s: String; var v: Variant);
- procedure GetVarList(CatNo: Integer; List: TStrings);
- procedure GetCategoryList(List: TStrings);
- function FindObject(Name: String): TfrView;
- // 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 SaveToStream(Stream: TStream);
- procedure LoadFromFile(FName: String);
- procedure SaveToFile(FName: String);
- procedure SaveToFR3File(FName: String);
- {$IFDEF IBO}
- procedure LoadFromDB(Table: TIB_DataSet; DocN: Integer);
- procedure SaveToDB(Table: TIB_DataSet; DocN: Integer);
- {$ELSE}
- procedure LoadFromDB(Table: TDataSet; DocN: Integer);
- procedure SaveToDB(Table: TDataSet; DocN: Integer);
- {$ENDIF}
- 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; FileName: String);
- procedure ShowReport;
- procedure ShowPreparedReport;
- procedure PrintPreparedReport(PageNumbers: String; Copies: Integer);
- function ChangePrinter(OldIndex, NewIndex: Integer): Boolean;
- procedure EditPreparedReport(PageIndex: Integer);
- //
- 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 FDataset;
- 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 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: TProgressEvent 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;
- OnClick: TNotifyEvent); virtual; abstract;
- procedure BeforeChange; virtual; abstract;
- procedure AfterChange; virtual; abstract;
- procedure RedrawPage; virtual; abstract;
- end;
-
- TfrDataManager = class(TObject)
- public
- procedure LoadFromStream(Stream: TStream); virtual; abstract;
- procedure SaveToStream(Stream: TStream); 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;
-
- TfrFunctionLibrary = class(TObject)
- public
- List: TStringList;
- constructor Create; virtual;
- destructor Destroy; override;
- function OnFunction(const FName: String; p1, p2, p3: Variant;
- var val: String): Boolean;
- procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: String);
- virtual; abstract;
- 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: TClass; 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;
-
-
- const
- frCurrentVersion = 23; // this is current version (2.3)
- 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);
-
- 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: TClass;
- 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[0..21] 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;
- (*
- 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
- FR_Fmted, FR_Prntr, FR_Progr, FR_Utils, FR_Const
- {$IFDEF JPEG}, JPEG {$ENDIF};
-
- {$R FR_Lng1.RES}
-
- type
- TfrStdFunctionLibrary = class(TfrFunctionLibrary)
- public
- constructor Create; override;
- procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: String); 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: String); 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;
-
- // variables used through report building
- PrevY, PrevBottomY, ColumnXAdjust: Integer;
- Append, WasPF: Boolean;
- CompositeMode: Boolean;
-
- {----------------------------------------------------------------------------}
- 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
- if frAddIns[i].ClassRef.ClassName = ClassName then
- begin
- Result := TfrView(frAddIns[i].ClassRef.NewInstance);
- Result.Create;
- Result.Typ := gtAddIn;
- break;
- end;
- if Result = nil then
- raise EClassNotFound.Create('Íå íàéäåí êëàññ ' + ClassName);
- end;
- end;
- if Result <> nil then
- begin
- Result.ID := ObjID;
- Inc(ObjID);
- end;
- end;
-
- procedure frRegisterObject(ClassRef: TClass; 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 := frReadString2217(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;
-
- {----------------------------------------------------------------------------}
- constructor TfrView.Create;
- begin
- inherited Create;
- Parent := nil;
- Memo := TStringList.Create;
- Memo1 := TStringList.Create;
- Script := TStringList.Create;
- FrameWidth := 1;
- FrameColor := clBlack;
- FillColor := clNone;
- Format := 2*256 + Ord(DecimalSeparator);
- BaseName := 'View';
- Visible := True;
- StreamMode := smDesigning;
- ScaleX := 1; ScaleY := 1;
- OffsX := 0; OffsY := 0;
- Flags := flStretched;
- end;
-
- destructor TfrView.Destroy;
- begin
- Memo.Free;
- Memo1.Free;
- Script.Free;
- inherited Destroy;
- end;
-
- procedure TfrView.Assign(From: TfrView);
- begin
- Name := From.Name;
- Typ := From.Typ;
- Selected := From.Selected;
- x := From.x; y := From.y; dx := From.dx; dy := From.dy;
- Flags := From.Flags;
- FrameTyp := From.FrameTyp;
- FrameWidth := From.FrameWidth;
- FrameColor := From.FrameColor;
- FrameStyle := From.FrameStyle;
- FillColor := From.FillColor;
- Format := From.Format;
- FormatStr := From.FormatStr;
- Visible := From.Visible;
- Memo.Assign(From.Memo);
- Script.Assign(From.Script);
- 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);
- FrameWidth := 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 (FrameTyp and $1) <> 0 then Dec(bx1, wx2);
- if (FrameTyp and $2) <> 0 then Dec(by1, wy2);
- if (FrameTyp and $4) <> 0 then Inc(bx, wx1);
- if (FrameTyp and $8) <> 0 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;
- FrameWidth := 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.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 Line(x, y, dx, dy: Integer);
- begin
- Canvas.MoveTo(x, y);
- Canvas.LineTo(x + dx, y + dy);
- end;
- procedure Line1(x, y, x1, y1: Integer);
- var
- i, w: Integer;
- begin
- if Canvas.Pen.Style = psSolid then
- begin
- if FrameStyle <> 5 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
- 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
- else
- 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;
- Canvas.Pen.Width := w;
- end;
- end;
- begin
- if DisableDrawing then Exit;
- if (DocMode = dmPrinting) and ((FrameTyp and $F) = 0) 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;
- Line(x, y + 3, 0, -3); Line(x, y, 4, 0);
- Line(x, y + dy - 3, 0, 3); Line(x, y + dy, 4, 0);
- Line(x + dx - 3, y, 3, 0); Line(x + dx, y, 0, 4);
- Line(x + dx - 3, y + dy, 3, 0); Line(x + dx, y + dy, 0, -4);
- end;
- Pen.Color := FrameColor;
- Pen.Width := Round(FrameWidth);
- if FrameStyle <> 5 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);
- if ((FrameTyp and $F) = $F) and (FrameStyle = 0) then
- Rectangle(x, y, x1 + 1, y1 + 1)
- else
- begin
- if (FrameTyp and $1) <> 0 then Line1(x1, y, x1, y1);
- if (FrameTyp and $4) <> 0 then Line1(x, y, x, y1);
- if (FrameTyp and $2) <> 0 then Line1(x, y1, x1, y1);
- if (FrameTyp and $8) <> 0 then Line1(x, y, x1, y);
- end;
- end;
- end;
-
- procedure TfrView.BeginDraw(ACanvas: TCanvas);
- begin
- Canvas := ACanvas;
- CurView := Self;
- end;
-
- procedure TfrView.Print(Stream: TStream);
- begin
- 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);
- end;
-
- procedure TfrView.ExportData;
- begin
- CurReport.InternalOnExportData(Self);
- end;
-
- procedure TfrView.LoadFromStream(Stream: TStream);
- var
- w: Integer;
- begin
- with Stream do
- begin
- if StreamMode = smDesigning then
- if frVersion >= 23 then
- Name := ReadString(Stream) else
- CreateUniqueName;
- Read(x, 30); // this is equal to, but much faster:
- { Read(x, 4); Read(y, 4); Read(dx, 4); Read(dy, 4);
- Read(Flags, 2);
- Read(FrameTyp, 2);
- Read(FrameWidth, 4);
- Read(FrameColor, 4);
- Read(FrameStyle, 2);}
- Read(FillColor, 4);
- if StreamMode = smDesigning then
- begin
- Read(Format, 4);
- FormatStr := ReadString(Stream);
- end;
- ReadMemo(Stream, Memo);
- if (frVersion >= 23) and (StreamMode = smDesigning) then
- begin
- ReadMemo(Stream, Script);
- Read(Visible, 2);
- end;
- w := PInteger(@FrameWidth)^;
- if w <= 10 then
- w := w * 1000;
- FrameWidth := w / 1000;
- end;
- end;
-
- procedure TfrView.SaveToStream(Stream: TStream);
- var
- w: Integer;
- f: Single;
- begin
- f := FrameWidth;
- if f <> Int(f) then
- w := Round(FrameWidth * 1000) else
- w := Round(f);
- PInteger(@FrameWidth)^ := w;
- with Stream do
- begin
- if StreamMode = smDesigning then
- frWriteString(Stream, Name);
- Write(x, 30); // this is equal to, but much faster:
- { Write(x, 4); Write(y, 4); Write(dx, 4); Write(dy, 4);
- Write(Flags, 2);
- Write(FrameTyp, 2);
- Write(FrameWidth, 4);
- Write(FrameColor, 4);
- Write(FrameStyle, 2);}
- Write(FillColor, 4);
- if StreamMode = smDesigning then
- begin
- Write(Format, 4);
- frWriteString(Stream, FormatStr);
- frWriteMemo(Stream, Memo);
- end
- else
- frWriteMemo(Stream, Memo1);
- if StreamMode = smDesigning then
- begin
- frWriteMemo(Stream, Script);
- Write(Visible, 2);
- end;
- end;
- FrameWidth := f;
- end;
-
- procedure TfrView.SaveToFR3Stream(Stream: TStream);
- var
- FTyp: Integer;
- s: String;
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- s := ClassName;
- if Pos('Tfr', s) = 1 then
- begin
- Delete(s, 1, 3);
- s := 'Tfrx' + s;
- if CompareText(s, 'TfrxSubreportView') = 0 then
- s := 'TfrxSubreport';
- end;
- WriteStr('<' + s + ' ');
- WriteStr('Name="' + Name +
- '" Left="' + IntToStr(x) + '" Top="' + IntToStr(y) +
- '" Width="' + IntToStr(dx) + '" Height="' + IntToStr(dy) +
- '" Color="' + IntToStr(FillColor) + '"');
- if not Visible then
- WriteStr(' Visible="False"');
-
- FTyp := 0;
- if (FrameTyp and frftLeft) <> 0 then
- FTyp := FTyp or 1;
- if (FrameTyp and frftRight) <> 0 then
- FTyp := FTyp or 2;
- if (FrameTyp and frftUp) <> 0 then
- FTyp := FTyp or 4;
- if (FrameTyp and frftDown) <> 0 then
- FTyp := FTyp or 8;
-
- WriteStr(' Frame.Typ="' + IntToStr(FTyp) +
- '" Frame.Width="' + FloatToStr(FrameWidth) +
- '" Frame.Color="' + IntToStr(FrameColor) +
- '" Frame.Style="' + IntToStr(FrameStyle) +
- '" GapX="' + IntToStr(gapx) + '" GapY="' + IntToStr(gapy) +
- {'" TagStr="' + StrToXML(Tag) + }'" Memo.text="' + StrToXML(Memo.Text) + '"');
-
- { ba := BandAlign;
- if ba = baRest then
- ba := baWidth
- else if ba = baTop then
- ba := baNone;
- WriteStr(' Align="' + IntToStr(ba) + '"');}
-
- if Script.Count > 0 then
- WriteStr(' OnBeforePrint="' + Name + 'OnBeforePrint' +
- '" OnClick="' + Name + 'OnBeforePrint' +
- '" OnActivate="' + Name + 'OnBeforePrint"');
-
- { RTyp := 0;
- if ((Restrictions and frrfDontEditMemo) <> 0) or
- ((Restrictions and frrfDontEditScript) <> 0) or
- ((Restrictions and frrfDontEditContents) <> 0) or
- ((Restrictions and frrfDontModify) <> 0) then
- RTyp := RTyp or 1;
- if (Restrictions and frrfDontSize) <> 0 then
- RTyp := RTyp or 2;
- if (Restrictions and frrfDontMove) <> 0 then
- RTyp := RTyp or 4;
- if (Restrictions and frrfDontDelete) <> 0 then
- RTyp := RTyp or 8;
- WriteStr(' Restrictions="' + IntToStr(RTyp) + '"');}
- end;
-
- procedure TfrView.Resized;
- begin
- end;
-
- procedure TfrView.GetBlob(b: TfrTField);
- begin
- end;
-
- procedure TfrView.OnHook(View: TfrView);
- begin
- end;
-
- function TfrView.GetClipRgn(rt: TfrRgnType): HRGN;
- var
- bx, by, bx1, by1, w1, w2: Integer;
- begin
- if FrameStyle = 5 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 (FrameTyp and $1) <> 0 then Inc(bx1, w2);
- if (FrameTyp and $2) <> 0 then Inc(by1, w2);
- if (FrameTyp and $4) <> 0 then Dec(bx, w1);
- if (FrameTyp and $8) <> 0 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.CreateUniqueName;
- var
- i: Integer;
- begin
- Name := '';
- for i := 1 to 10000 do
- if CurReport.FindObject(BaseName + IntToStr(i)) = nil then
- begin
- Name := BaseName + IntToStr(i);
- Exit;
- end;
- end;
-
- procedure TfrView.SetBounds(Left, Top, Width, Height: Integer);
- begin
- x := Left;
- y := Top;
- dx := Width;
- dy := Height;
- 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 := LoadStr(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 := frDesigner.Page.Objects[i];
- if t.Selected then
- t.Flags := (t.Flags and not flStretched) + Word(Checked);
- end;
- end;
- frDesigner.AfterChange;
- end;
-
- {----------------------------------------------------------------------------}
- constructor TfrMemoView.Create;
- begin
- inherited Create;
- Typ := gtMemo;
- FFont := TFont.Create;
- FFont.Name := 'Arial';
- FFont.Size := 10;
- FFont.Color := clBlack;
- {$IFNDEF Delphi2}
- FFont.Charset := frCharset;
- {$ENDIF}
- Highlight.FontColor := clBlack;
- Highlight.FillColor := clWhite;
- Highlight.FontStyle := 2; // fsBold
- BaseName := 'Memo';
- Flags := flStretched + flWordWrap;
- LineSpacing := 2;
- CharacterSpacing := 0;
- end;
-
- destructor TfrMemoView.Destroy;
- begin
- FFont.Free;
- inherited Destroy;
- end;
-
- procedure TfrMemoView.SetFont(Value: TFont);
- begin
- FFont.Assign(Value);
- end;
-
- procedure TfrMemoView.Assign(From: TfrView);
- begin
- inherited Assign(From);
- Font := 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;
- s: String;
- 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;
- begin
- Memo1.Clear;
- for i := 0 to Memo.Count - 1 do
- begin
- s := Memo[i];
- if Length(s) > 0 then
- begin
- GetData(s);
- Memo1.Text := Memo1.Text + s;
- end
- else
- Memo1.Add('');
- end;
- end;
-
- procedure TfrMemoView.AssignFont(Canvas: TCanvas);
- begin
- with Canvas do
- begin
- Brush.Style := bsClear;
- Font := Self.Font;
- if not IsPrinting then
- Font.Height := -Round(Font.Size * 96 / 72 * ScaleY);
- end;
- end;
-
-
- type
- TWordBreaks = string;
-
- const
- gl: set of Char = ['À', 'Å', '¨', 'È', 'Î', 'Ó', 'Û', 'Ý', 'Þ', 'ß'];
- r_sogl: set of Char = ['Ú', 'Ü'];
- spaces: set of Char = [' ', '.', ',', '-'];
-
- function BreakWord(s: String): TWordBreaks;
- var
- i: Integer;
- CanBreak: Boolean;
- begin
- Result := '';
- s := AnsiUpperCase(s);
- if Length(s) > 4 then
- begin
- i := 2;
- repeat
- CanBreak := False;
- if s[i] in gl then
- begin
- if (s[i + 1] in gl) or (s[i + 2] in gl) then CanBreak := True;
- end
- else
- begin
- if not (s[i + 1] in gl) and not (s[i + 1] in r_sogl) and
- (s[i + 2] in gl) then
- CanBreak := True;
- end;
- if CanBreak then
- Result := Result + Chr(i);
- Inc(i);
- until i > Length(s) - 2;
- end;
- 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);
- 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
- if s[i] in [#10, #13] then
- begin
- CRLF := True;
- break;
- end;
- last := 1; beg := 1;
- if not CRLF and ((Length(s) <= 1) or (WCanvas.TextWidth(s) <= maxwidth)) then
- OutLine(s + #1)
- else
- begin
- cur := 1;
- while cur <= Length(s) do
- begin
- if s[cur] in [#10, #13] then
- begin
- 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
- Exit 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);
- 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
- OutLine(Copy(s, beg, last - beg + 1) + '-')
- else if s[last] = ' ' then
- OutLine(Copy(s, beg, last - beg)) else
- OutLine(Copy(s, beg, last - beg + 1));
- 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
- if last = cur then
- begin
- beg := cur;
- break;
- end;
- beg := last + 1; last := beg;
- end;
- if s[cur] in spaces then last := cur;
- Inc(cur);
- end;
- if beg <> cur then OutLine(Copy(s, beg, cur - beg + 1) + #1);
- end;
- end;
-
- procedure OutMemo;
- var
- i: Integer;
- begin
- size := y + gapy;
- size1 := -WCanvas.Font.Height + LineSpacing;
- maxwidth := dx - gapx - gapx;
- for i := 0 to Memo1.Count - 1 do
- if (Flags and flWordWrap) <> 0 then
- WrapLine(Memo1[i]) else
- OutLine(Memo1[i] + #1);
- 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
- if (Flags and flWordWrap) <> 0 then
- WrapLine(Memo1[i]) else
- OutLine(Memo1[i]);
- 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);
- SetTextCharacterExtra(WCanvas.Handle, CharacterSpacing);
- SMemo.Clear;
- if (Adjust and $4) <> 0 then OutMemo90 else OutMemo;
- end;
-
-
- var
- DxArray: Array[0..2047] of Integer;
-
- procedure TfrMemoView.ShowMemo;
- var
- DR: TRect;
- ad, ox, oy: Integer;
- GCP: TGCPRESULTS;
-
- procedure OutMemo;
- var
- i, cury, th: Integer;
-
- function OutLine(str: String): Boolean;
- var
- i, n, aw, nw, w, curx: Integer;
- ParaEnd: Boolean;
- begin
- if not Streaming or (cury + th <= DR.Bottom) then
- begin
- n := Length(str);
- w := Ord(str[n - 1]) * 256 + Ord(str[n]);
- SetLength(str, n - 2);
- ParaEnd := True;
- if Length(str) > 0 then
- if str[Length(str)] = #1 then
- SetLength(str, Length(str) - 1) else
- ParaEnd := False;
-
- if Adjust <> 3 then
- begin
- FillChar(GCP, SizeOf(TGCPRESULTS), 0);
- GCP.lStructSize := SizeOf(TGCPRESULTS);
- GCP.lpDx := @DxArray[0];
- GCP.nGlyphs := Length(str);
- AssignFont(Canvas);
-
- nw := Round(w * ScaleX); // needed width
- while (Canvas.TextWidth(str) > nw) and
- (Canvas.Font.Height < -1) do
- Canvas.Font.Height := Canvas.Font.Height + 1;
-
- aw := Canvas.TextWidth(str); // actual width
-
- // preventing Win32 error when printing
- if (aw <> nw) and not Exporting then
- {$IFDEF VER180}
- GetCharacterPlacement(Canvas.Handle, PChar(str), Length(str), nw, GCP, GCP_JUSTIFY + GCP_MAXEXTENT)
- {$ELSE}
- {$IFDEF VER150}
- GetCharacterPlacement(Canvas.Handle, PChar(str), Length(str), nw, GCP, GCP_JUSTIFY + GCP_MAXEXTENT)
- {$ELSE}
- GetCharacterPlacement(Canvas.Handle, PChar(str), BOOL(Length(str)), BOOL(nw), GCP, GCP_JUSTIFY + GCP_MAXEXTENT)
- {$ENDIF}
- {$ENDIF}
- else
- GCP.lpDx := nil;
-
- if Adjust = 0 then
- curx := x + gapx
- else if Adjust = 1 then
- curx := x + dx - 1 - gapx - nw
- else
- curx := x + gapx + (dx - gapx - gapx - nw) div 2;
-
- if not Exporting then
- ExtTextOut(Canvas.Handle, curx, cury, ETO_CLIPPED, @DR,
- PChar(str), Length(str), PInteger(GCP.lpDx))
- end
- else
- begin
- curx := x + gapx;
- if not Exporting then
- begin
- 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,
- dx - gapx - gapx - Canvas.TextWidth(str), n);
-
- ExtTextOut(Canvas.Handle, curx, cury, ETO_CLIPPED, @DR,
- PChar(str), Length(str), nil);
- SetTextJustification(Canvas.Handle, 0, 0);
- end;
- end;
- if Exporting then CurReport.InternalOnExportText(curx, cury, str, Self);
- Inc(CurStrNo);
- Result := False;
- end
- else Result := True;
- cury := cury + th;
- end;
-
- begin
- cury := y + gapy;
- th := -Canvas.Font.Height + Round(LineSpacing * ScaleY);
- 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
- 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);
- SetTextCharacterExtra(Canvas.Handle, Round(CharacterSpacing * ScaleX));
- DR := Rect(DRect.Left + 1, DRect.Top, DRect.Right - 2, DRect.Bottom - 1);
- VHeight := Round(VHeight * ScaleY);
- 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(Memo: TStringList): Integer;
- var
- CalcRect: TRect;
- s: String;
- n: Integer;
- begin
- CalcRect := Rect(0, 0, dx, dy);
- Canvas.Font.Assign(Font);
- Canvas.Font.Height := -Round(Font.Size * 96 / 72);
- s := Memo.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;
- end;
-
- procedure TfrMemoView.Draw(Canvas: TCanvas);
- var
- NeedWrap: Boolean;
- newdx: Integer;
- OldScaleX, OldScaleY: Double;
- begin
- BeginDraw(Canvas);
- if ((Flags and flAutoSize) <> 0) and (Memo.Count > 0) and
- (DocMode <> dmDesigning) then
- begin
- newdx := CalcWidth(Memo);
- if (Adjust and frtaRight) <> 0 then
- begin
- x := x + dx - newdx;
- dx := newdx;
- end
- else
- dx := newdx;
- end;
-
- 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;
- 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
- s: String;
- CanExpandVar: Boolean;
- OldFont: TFont;
- OldFill: Integer;
- i: Integer;
- begin
- 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);
- s := Memo1.Text;
- CurReport.InternalOnEnterRect(Memo1, Self);
- if s <> 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
- if frParser.Calc(HighlightStr) <> 0 then
- begin
- Font.Style := frSetFontStyle(Highlight.FontStyle);
- Font.Color := Highlight.FontColor;
- FillColor := Highlight.FillColor;
- end;
-
- if DrawMode = drPart then
- begin
- CalcGaps;
- 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;
- FillColor := 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;
- FillColor := 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;
- FillColor := 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;
- begin
- 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(Adjust, 4);
- Read(w, 2);
- if frVersion < 23 then
- w := frCharset;
- {$IFNDEF Delphi2}
- Font.Charset := w;
- {$ENDIF}
- if StreamMode = smDesigning then
- begin
- Read(Highlight, 10);
- HighlightStr := ReadString(Stream);
- end;
- end;
- if frVersion = 21 then
- Flags := Flags or flWordWrap;
- end;
-
- procedure TfrMemoView.SaveToStream(Stream: TStream);
- var
- i: Integer;
- w: Word;
- 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);
- Write(Adjust, 4);
- {$IFDEF Delphi2}
- w := frCharset;
- {$ELSE}
- w := Font.Charset;
- {$ENDIF}
- Write(w, 2);
- if StreamMode = smDesigning then
- begin
- Write(Highlight, 10);
- frWriteString(Stream, HighlightStr);
- end;
- end;
- end;
-
- procedure TfrMemoView.SaveToFR3Stream(Stream: TStream);
- var
- fs: Integer;
- f1, f2: Integer;
- s: String;
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- inherited;
-
- if (Flags and flStretched) <> 0 then
- WriteStr(' StretchMode="smMaxHeight"');
- if (Flags and flWordWrap) = 0 then
- WriteStr(' WordWrap="False"');
- if (Flags and flAutoSize) <> 0 then
- WriteStr(' AutoWidth="True"');
- // if (Flags and flTextOnly) <> 0 then
- // WriteStr(' AllowExpressions="False"');
- // if (Flags and flSuppressRepeated) <> 0 then
- // WriteStr(' SuppressRepeated="True"');
- // if (Flags and flHideZeros) <> 0 then
- // WriteStr(' HideZeros="True"');
- // if (Flags and flUnderlines) <> 0 then
- // WriteStr(' Underlines="True"');
- // if (Flags and flRTLReading) <> 0 then
- // WriteStr(' RTLReading="True"');
-
- fs := 0;
- if fsBold in Font.Style then
- fs := fs or 1;
- if fsItalic in Font.Style then
- fs := fs or 2;
- if fsUnderline in Font.Style then
- fs := fs or 4;
- if fsStrikeout in Font.Style then
- fs := fs or 8;
-
- WriteStr(' Font.Name="' + Font.Name +
- '" Font.Height="' + IntToStr(Font.Height) +
- '" Font.Color="' + IntToStr(Font.Color) +
- '" Font.Style="' + IntToStr(fs) + '"');
-
- WriteStr(' LineSpacing="' + IntToStr(LineSpacing) +
- '" CharSpacing="' + IntToStr(CharacterSpacing) + '"');
-
- if HighlightStr <> '' then
- WriteStr(' Highlight.Condition="' + StrToXML(HighlightStr) +
- '" Highlight.Font.Style="' + IntToStr(Highlight.FontStyle) +
- '" Highlight.Font.Color="' + IntToStr(Highlight.FontColor) +
- '" Highlight.Color="' + IntToStr(Highlight.FillColor) + '"');
-
- { al := 0;
- if ((Alignment and frtaRight) <> 0) and ((Alignment and frtaCenter) <> 0) then
- al := 3
- else if (Alignment and frtaRight) <> 0 then
- al := 1
- else if (Alignment and frtaCenter) <> 0 then
- al := 2;
- WriteStr(' HAlign="' + IntToStr(al) + '"');
-
- al := 0;
- if (Alignment and frtaMiddle) <> 0 then
- al := 2
- else if (Alignment and frtaDown) <> 0 then
- al := 1;
- WriteStr(' VAlign="' + IntToStr(al) + '"');
-
- if (Alignment and frtaVertical) <> 0 then
- WriteStr(' Rotation="90"');}
-
- f1 := (Format div $01000000) and $0F;
- f2 := (Format div $00010000) and $FF;
- s := '';
- case f1 of
- 0: ;
- 1:
- begin
- s := ' DisplayFormat.Kind="fkNumeric"';
- s := s + ' DisplayFormat.DecimalSeparator="' + Chr(Format and $FF) + '"';
- case f2 of
- 0: s := s + ' DisplayFormat.FormatStr="%g"';
- 1: s := s + ' DisplayFormat.FormatStr="%2.2f"';
- 2: s := s + ' DisplayFormat.FormatStr="%2.2n"';
- 3: s := s + ' DisplayFormat.FormatStr="%2.2m"';
- 4: s := s + ' DisplayFormat.FormatStr="' + StrToXML(FormatStr) + '"';
- end;
- end;
- 2:
- begin
- s := ' DisplayFormat.Kind="fkDateTime"';
- if f2 = 4 then
- s := s + ' DisplayFormat.FormatStr="' + StrToXML(FormatStr) + '"'
- else if f2 = 3 then
- s := s + ' DisplayFormat.FormatStr="dd mmmm yyyy"'
- else
- s := s + ' DisplayFormat.FormatStr="' + frDateFormats[f2] + '"'
- end;
- 3:
- begin
- s := ' DisplayFormat.Kind="fkDateTime"';
- if f2 = 4 then
- s := s + ' DisplayFormat.FormatStr="' + StrToXML(FormatStr) + '"' else
- s := s + ' DisplayFormat.FormatStr="' + frTimeFormats[f2] + '"'
- end;
- 4:
- begin
- s := ' DisplayFormat.Kind="fkBoolean"';
- if f2 = 4 then
- s := s + ' DisplayFormat.FormatStr="' + StrToXML(FormatStr) + '"' else
- s := s + ' DisplayFormat.FormatStr="' + BoolStr[f2] + '"'
- end;
- end;
- if s <> '' then
- WriteStr(s);
- end;
-
- procedure TfrMemoView.GetBlob(b: TfrTField);
- begin
- {$IFDEF IBO}
- b.AssignTo(Memo1);
- {$ELSE}
- Memo1.Assign(b);
- {$ENDIF}
- end;
-
- procedure TfrMemoView.DefinePopupMenu(Popup: TPopupMenu);
- var
- m: TMenuItem;
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SVarFormat);
- m.OnClick := P1Click;
- Popup.Items.Add(m);
-
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SFont);
- m.OnClick := P4Click;
- Popup.Items.Add(m);
- inherited DefinePopupMenu(Popup);
-
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SWordWrap);
- m.OnClick := P2Click;
- m.Checked := (Flags and flWordWrap) <> 0;
- Popup.Items.Add(m);
-
- if LoadStr(SWordBreak) <> '' then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SWordBreak);
- m.OnClick := P3Click;
- m.Enabled := (Flags and flWordWrap) <> 0;
- if m.Enabled then
- m.Checked := (Flags and flWordBreak) <> 0;
- Popup.Items.Add(m);
- end;
-
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SAutoSize);
- m.OnClick := P5Click;
- m.Checked := (Flags and flAutoSize) <> 0;
- Popup.Items.Add(m);
- end;
-
- procedure TfrMemoView.P1Click(Sender: TObject);
- var
- t: TfrView;
- i: Integer;
- begin
- frDesigner.BeforeChange;
- frFmtForm := TfrFmtForm.Create(nil);
- with frFmtForm do
- begin
- Format := Self.Format;
- Edit1.Text := Self.FormatStr;
- if ShowModal = mrOk then
- for i := 0 to frDesigner.Page.Objects.Count - 1 do
- begin
- t := frDesigner.Page.Objects[i];
- if t.Selected then
- begin
- (t as TfrMemoView).Format := Format;
- (t as TfrMemoView).FormatStr := Edit1.Text;
- end;
- end;
- end;
- frFmtForm.Free;
- 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 := frDesigner.Page.Objects[i];
- if t.Selected then
- t.Flags := (t.Flags and not flWordWrap) + Word(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 := 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 := 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;
- {$IFNDEF Delphi2}
- if Font.Charset <> Self.Font.Charset then
- TfrMemoView(t).Font.Charset := Font.Charset;
- {$ENDIF}
- 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 := frDesigner.Page.Objects[i];
- if t.Selected then
- t.Flags := (t.Flags and not flAutoSize) + Word(Checked) * flAutoSize;
- end;
- end;
- frDesigner.AfterChange;
- end;
-
- {----------------------------------------------------------------------------}
- constructor TfrBandView.Create;
- begin
- inherited Create;
- Typ := gtBand;
- Format := 0;
- BaseName := 'Band';
- Flags := flBandOnFirstPage + flBandOnLastPage;
- end;
-
- procedure TfrBandView.Draw(Canvas: TCanvas);
- var
- h, oldh: HFont;
- begin
- FrameWidth := 1;
- if TfrBandType(FrameTyp) in [btCrossHeader..btCrossFooter] then
- begin
- y := 0; dy := frDesigner.Page.PrnInfo.Pgh;
- end
- else
- begin
- x := 0; dx := frDesigner.Page.PrnInfo.Pgw;
- end;
- BeginDraw(Canvas);
- CalcGaps;
- with Canvas do
- begin
- Brush.Bitmap := SBmp;
- FillRect(DRect);
- Font.Name := 'Arial';
- Font.Style := [];
- Font.Size := 8;
- Font.Color := clBlack;
- Pen.Width := 1;
- Pen.Color := clBtnFace;
- Pen.Style := psSolid;
- Brush.Style := bsClear;
- Rectangle(x, y, x + dx + 1, y + dy + 1);
- Brush.Color := clBtnFace;
- if ShowBandTitles then
- if TfrBandType(FrameTyp) 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);
- TextOut(x - 15, y + 94, frBandNames[FrameTyp]);
- 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);
- TextOut(x + 4, y - 17, frBandNames[FrameTyp]);
- end
- else
- begin
- Brush.Style := bsClear;
- if TfrBandType(FrameTyp) in [btCrossHeader..btCrossFooter] then
- begin
- h := Create90Font(Font);
- oldh := SelectObject(Handle, h);
- TextOut(x + 2, y + 94, frBandNames[FrameTyp]);
- SelectObject(Handle, oldh);
- DeleteObject(h);
- end
- else
- TextOut(x + 4, y + 2, frBandNames[FrameTyp]);
- end;
- end;
- end;
-
- function TfrBandView.GetClipRgn(rt: TfrRgnType): HRGN;
- var
- R: HRGN;
- begin
- if not ShowBandTitles then
- begin
- Result := inherited GetClipRgn(rt);
- Exit;
- end;
- if rt = rtNormal then
- Result := CreateRectRgn(x, y, x + dx + 1, y + dy + 1) else
- Result := CreateRectRgn(x - 10, y - 10, x + dx + 10, y + dy + 10);
- if TfrBandType(FrameTyp) in [btCrossHeader..btCrossFooter] then
- R := CreateRectRgn(x - 18, y, x, y + 100)
- else
- R := CreateRectRgn(x, y - 18, x + 100, y);
- CombineRgn(Result, Result, R, RGN_OR);
- DeleteObject(R);
- end;
-
- procedure TfrBandView.SaveToFR3Stream(Stream: TStream);
- const
- BandNames: array[TfrBandType] of String =
- ('TfrxReportTitle', 'TfrxReportSummary',
- 'TfrxPageHeader', 'TfrxPageFooter',
- 'TfrxHeader', 'TfrxMasterData', 'TfrxFooter',
- 'TfrxHeader', 'TfrxDetailData', 'TfrxFooter',
- 'TfrxHeader', 'TfrxSubDetailData', 'TfrxFooter',
- 'TfrxOverlay', 'TfrxColumnHeader', 'TfrxColumnFooter',
- 'TfrxGroupHeader', 'TfrxGroupFooter',
- '', '', '', '');
- var
- ds: TfrDataset;
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- if BandNames[BandType] = '' then Exit;
-
- WriteStr('<' + BandNames[BandType] + ' ');
- WriteStr('Name="' + Name +
- '" Top="' + IntToStr(y) +
- '" Height="' + IntToStr(dy) +
- // '" Columns="' + IntToStr(Columns) +
- // '" ColumnWidth="' + IntToStr(ColumnWidth) +
- // '" ColumnGap="' + IntToStr(ColumnGap) +
- '"');
- if not Visible then
- WriteStr(' Visible="False"');
- // if ChildBand <> '' then
- // WriteStr(' Child="' + ChildBand + '"');
-
- if (Flags and flStretched) <> 0 then
- WriteStr(' Stretched="True"');
- if (Flags and flBandNewPageAfter) <> 0 then
- WriteStr(' StartNewPage="True"');
- if (Flags and flBandPrintifSubsetEmpty) <> 0 then
- WriteStr(' PrintIfDetailEmpty="True"');
- if (Flags and flBandPageBreak) <> 0 then
- WriteStr(' AllowSplit="True"');
- if (Flags and flBandOnFirstPage) = 0 then
- WriteStr(' PrintOnFirstPage="False"');
- if (Flags and flBandOnLastPage) = 0 then
- WriteStr(' PrintOnLastPage="False"');
- if (Flags and flBandRepeatHeader) <> 0 then
- WriteStr(' ReprintOnNewPage="True"');
- if (Flags and flBandRepeatHeader) <> 0 then
- WriteStr(' ReprintOnNewPage="True"');
- // if (Flags and flBandPrintChildIfInvisible) <> 0 then
- // WriteStr(' PrintChildIfInvisible="True"');
-
- if Script.Count > 0 then
- WriteStr(' OnBeforePrint="' + Name + 'OnBeforePrint"');
- if BandType in [btMasterData, btDetailData, btSubDetailData] then
- begin
- ds := frFindComponent(CurReport.Owner, DataSet) as TfrDataSet;
- if ds <> nil then
- WriteStr(' DataSetName="' + StrToXML(ds.Name) + '"');
- end;
- if BandType = btGroupHeader then
- WriteStr(' Condition="' + StrToXML(GroupCondition) + '"');
- end;
-
- procedure TfrBandView.DefinePopupMenu(Popup: TPopupMenu);
- var
- m: TMenuItem;
- b: TfrBandType;
- begin
- b := TfrBandType(FrameTyp);
- if b in [btReportTitle, btReportSummary, btPageHeader, btCrossHeader,
- btMasterHeader..btSubDetailFooter, btGroupHeader, btGroupFooter] then
- inherited DefinePopupMenu(Popup);
-
- if b in [btReportTitle, btReportSummary, btMasterData, btDetailData,
- btSubDetailData, btMasterFooter, btDetailFooter,
- btSubDetailFooter, btGroupHeader] then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SFormNewPage);
- m.OnClick := P1Click;
- m.Checked := (Flags and flBandNewPageAfter) <> 0;
- Popup.Items.Add(m);
- end;
-
- if b in [btMasterData, btDetailData] then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SPrintIfSubsetEmpty);
- m.OnClick := P2Click;
- m.Checked := (Flags and flBandPrintIfSubsetEmpty) <> 0;
- Popup.Items.Add(m);
- end;
-
- if b in [btReportTitle, btReportSummary, btMasterHeader..btSubDetailFooter,
- btGroupHeader, btGroupFooter] then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SBreaked);
- m.OnClick := P3Click;
- m.Checked := (Flags and flBandPageBreak) <> 0;
- Popup.Items.Add(m);
- end;
-
- if b in [btPageHeader, btPageFooter] then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SOnFirstPage);
- m.OnClick := P4Click;
- m.Checked := (Flags and flBandOnFirstPage) <> 0;
- Popup.Items.Add(m);
- end;
-
- if b = btPageFooter then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SOnLastPage);
- m.OnClick := P5Click;
- m.Checked := (Flags and flBandOnLastPage) <> 0;
- Popup.Items.Add(m);
- end;
-
- if b in [btMasterHeader, btDetailHeader, btSubDetailHeader,
- btCrossHeader, btGroupHeader] then
- begin
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(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 := 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 := 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 := 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;
-
- function TfrBandView.GetBandType: TfrBandType;
- begin
- Result := TfrBandType(FrameTyp);
- end;
-
- procedure TfrBandView.SetBandType(const Value: TfrBandType);
- begin
- FrameTyp := Integer(Value);
- 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(Canvas: TCanvas);
- begin
- BeginDraw(Canvas);
- FrameWidth := 1;
- CalcGaps;
- with Canvas do
- begin
- Font.Name := 'Arial';
- Font.Style := [];
- Font.Size := 8;
- Font.Color := clBlack;
- {$IFNDEF Delphi2}
- Font.Charset := frCharset;
- {$ENDIF}
- 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, LoadStr(SSubReportOnPage) + ' ' +
- IntToStr(SubPage + 1));
- end;
- RestoreCoord;
- end;
-
- procedure TfrSubReportView.SaveToFR3Stream(Stream: TStream);
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- inherited;
- WriteStr(' Page="Page' + IntToStr(SubPage + 1) + '"');
- 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.SaveToStream(Stream: TStream);
- begin
- inherited SaveToStream(Stream);
- Stream.Write(SubPage, 4);
- end;
-
- {----------------------------------------------------------------------------}
- constructor TfrPictureView.Create;
- begin
- inherited Create;
- Typ := gtPicture;
- Picture := 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(Canvas: 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
- GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
- GetMem(BitmapHeader, HeaderSize);
- GetMem(BitmapImage, ImageSize);
- try
- GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
- StretchDIBits(
- Canvas.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(Canvas);
- CalcGaps;
- with Canvas 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;
- {$IFNDEF Delphi2}
- Font.Charset := frCharset;
- {$ENDIF}
- TextOut(x + 2, y + 2, LoadStr(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;
-
- 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 := nil;
- case b of
- pkBitmap: Graphic := TBitmap.Create;
- pkMetafile: Graphic := TMetafile.Create;
- pkIcon: Graphic := TIcon.Create;
- {$IFDEF JPEG}
- pkJPEG: Graphic := TJPEGImage.Create;
- {$ENDIF}
- end;
- Picture.Graphic := Graphic;
- if Graphic <> nil then
- begin
- Graphic.Free;
- Picture.Graphic.LoadFromStream(Stream);
- end;
- Stream.Seek(n, soFromBeginning);
- end;
-
- procedure TfrPictureView.SaveToStream(Stream: TStream);
- var
- b: Byte;
- n, o: Integer;
- begin
- inherited SaveToStream(Stream);
- b := pkNone;
- if Picture.Graphic <> nil then
- if Picture.Graphic is TBitmap then
- b := pkBitmap
- else if Picture.Graphic is TMetafile then
- b := pkMetafile
- else if Picture.Graphic is TIcon then
- b := pkIcon
- {$IFDEF JPEG}
- else if Picture.Graphic is TJPEGImage then
- b := pkJPEG
- {$ENDIF};
- 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.GetBlob(b: TfrTField);
- begin
- if b.IsNull then
- Picture.Assign(nil)
- else
- {$IFDEF IBO}
- b.AssignTo(Picture);
- {$ELSE}
- Picture.Assign(b);
- {$ENDIF}
- end;
-
- procedure TfrPictureView.SaveToFR3Stream(Stream: TStream);
- var
- ms: TMemoryStream;
- ds: TfrTDataSet;
- fld: TfrTField;
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- inherited;
-
- if Picture.Graphic <> nil then
- begin
- ms := TMemoryStream.Create;
- Picture.Graphic.SaveToStream(ms);
- WriteStr(' Picture.Propdata="' + frStreamToString(ms) + '"');
- ms.Free;
- end;
-
- if Memo.Count <> 0 then
- begin
- frGetDataSetAndField(Memo[0], ds, fld);
- if (ds <> nil) and (fld <> nil) then
- WriteStr(' DataSet="' + ds.Owner.Name + '.' + ds.Name +
- '" DataField="' + StrToXML(fld.FieldName) + '"');
- end;
-
- if (Flags and flStretched) = 0 then
- WriteStr(' Stretched="False"');
- if (Flags and flPictCenter) <> 0 then
- WriteStr(' Center="True"');
- if (Flags and flPictRatio) = 0 then
- WriteStr(' KeepAspectRatio="False"');
- end;
-
-
- procedure TfrPictureView.DefinePopupMenu(Popup: TPopupMenu);
- var
- m: TMenuItem;
- begin
- inherited DefinePopupMenu(Popup);
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(SPictureCenter);
- m.OnClick := P1Click;
- m.Checked := (Flags and flPictCenter) <> 0;
- Popup.Items.Add(m);
-
- m := TMenuItem.Create(Popup);
- m.Caption := LoadStr(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 := 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 := frDesigner.Page.Objects[i];
- if t.Selected then
- t.Flags := (t.Flags and not flPictRatio) + Word(Checked) * flPictRatio;
- end;
- end;
- frDesigner.AfterChange;
- end;
-
- {----------------------------------------------------------------------------}
- constructor TfrLineView.Create;
- begin
- inherited Create;
- Typ := gtLine;
- FrameTyp := 4;
- BaseName := 'Line';
- end;
-
- procedure TfrLineView.Draw(Canvas: TCanvas);
- begin
- BeginDraw(Canvas);
- if dx > dy then
- begin
- dy := 0;
- FrameTyp := 8;
- end
- else
- begin
- dx := 0;
- FrameTyp := 4;
- 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 <> 5 then
- dd := Round(FrameWidth / 2) else
- dd := Round(FrameWidth * 1.5);
- if FrameTyp = 4 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;
-
- procedure TfrLineView.SaveToFR3Stream(Stream: TStream);
-
- procedure WriteStr(const s: String);
- begin
- Stream.Write(s[1], Length(s));
- end;
-
- begin
- inherited;
- if (Flags and flStretched) = 0 then
- WriteStr(' Stretched="False"');
- end;
-
-
- {----------------------------------------------------------------------------}
- constructor TfrBand.Create(ATyp: TfrBandType; AParent: TfrPage);
- begin
- inherited Create;
- Typ := ATyp;
- Parent := AParent;
- Objects := TList.Create;
- Memo := TStringList.Create;
- Script := TStringList.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;
- Memo.Free;
- Script.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 := LoadStr(SErrorOccured);
- for i := 0 to CurView.Memo.Count - 1 do
- ErrorStr := ErrorStr + #13 + CurView.Memo[i];
- ErrorStr := ErrorStr + #13 + LoadStr(SDoc) + ' ' + CurReport.Name +
- #13 + LoadStr(SBand) + ' ' + frBandNames[Integer(CurView.Parent.Typ)];
- MasterReport.Terminated := True;
- end;
-
- function TfrBand.CalcHeight: Integer;
- var
- Bnd: TfrBand;
- DS: TfrDataSet;
- ddx: Integer;
-
- function DoCalcHeight(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 := 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;
- DS.First;
- while not DS.Eof do
- begin
- ddx := 0;
- CurReport.InternalOnPrintColumn(Parent.ColPos, ddx);
- CalculatedHeight := DoCalcHeight(True);
- if CalculatedHeight > Result then
- Result := CalculatedHeight;
- Inc(Parent.ColPos);
- DS.Next;
- if MasterReport.Terminated then break;
- end;
- end;
- end
- else
- Result := DoCalcHeight(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 := 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 := Objects[i];
- t.dy := t.olddy;
- end;
- end;
-
- procedure TfrBand.DrawObject(t: TfrView);
- var
- ox,oy: Integer;
- begin
- 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;
- end;
-
- procedure TfrBand.PrepareSubReports;
- var
- i: Integer;
- t: TfrView;
- Page: TfrPage;
- begin
- for i := SubIndex to Objects.Count - 1 do
- begin
- t := 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 := 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
- if not EOFArr[i - SubIndex] then
- begin
- t := 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;
- 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 := 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 := 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
- if DisableDrawing then Exit;
- try
- for i := 0 to Objects.Count - 1 do
- begin
- t := Objects[i];
- if Parnt.Objects.IndexOf(t) <> -1 then
- begin
- sfx := t.x; Inc(t.x, CurX);
- sfy := t.y; Inc(t.y, Parnt.y);
- t.Parent := Parnt;
- 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;
- end;
- except
- on exception do DoError;
- end;
- end;
-
- procedure TfrBand.DrawCross;
- var
- Bnd: TfrBand;
- sfpage: Integer;
- CurX, ddx: Integer;
- DS: TfrDataSet;
-
- 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
- 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;
- 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(y, dy: Integer; PBreak: Boolean): Boolean;
- begin
- Result := False;
- with Parent do
- if y + Bands[btColumnFooter].dy + dy > CurBottomY then
- begin
- if not PBreak then
- NewColumn(Self);
- Result := True;
- end;
- end;
-
- procedure TfrBand.DrawPageBreak;
- var
- i: Integer;
- dy, oldy, olddy, maxy: 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 := 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
- for i := 0 to Objects.Count - 1 do
- begin
- t := 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 := 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
- dy := Parent.CurBottomY - Parent.Bands[btColumnFooter].dy - y - 2;
- maxy := 0;
- for i := 0 to Objects.Count - 1 do
- begin
- t := Objects[i];
- if t.Selected then
- if (t.y >= 0) and (t.y < dy) then
- if (t.y + t.dy < dy) then
- begin
- if maxy < t.y + t.dy then maxy := t.y + t.dy;
- DrawObject(t);
- t.Selected := False;
- end
- else
- begin
- if t is TfrStretcheable then
- begin
- olddy := t.dy;
- t.dy := dy - 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 := dy
- 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 maxy < t.y + t.dy then
- maxy := 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 := dy;
- 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 := Objects[i];
- if t.Selected then Flag := True;
- Dec(t.y, dy);
- end;
- if Flag then CheckPageBreak(y, 10000, False);
- y := Parent.CurY;
- if MasterReport.Terminated then break;
- until not Flag;
- maxdy := maxy;
- end;
- for i := 0 to Objects.Count - 1 do
- begin
- t := Objects[i];
- t.y := t.OriginalRect.Top;
- t.dy := t.OriginalRect.Bottom;
- end;
- Inc(Parent.CurY, maxdy);
- end;
-
- function TfrBand.HasCross: Boolean;
- var
- i: Integer;
- t: TfrView;
- begin
- Result := False;
- for i := 0 to Objects.Count - 1 do
- begin
- t := 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;
- 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 Inc(Parent.CurY, dy);
- end;
- end;
- y := sfy;
- if Typ in [btMasterData, btDetailData, btSubDetailData] then
- Parent.DoAggregate([btPageFooter, btMasterFooter, btDetailFooter,
- btSubDetailFooter, btGroupFooter, btReportSummary]);
- 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
- 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);
- // 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;
- if Assigned(CurReport.FOnEndBand) then
- CurReport.FOnEndBand(Self);
- 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 := 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
- inherited Create;
- List := TList.Create;
- Objects := TList.Create;
- RTObjects := TList.Create;
- ChangePaper(ASize, AWidth, AHeight, AOr);
- PrintToPrevPage := False;
- UseMargins := True;
- end;
-
- destructor TfrPage.Destroy;
- begin
- Clear;
- Objects.Free;
- RTObjects.Free;
- List.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 exception do
- begin
- Prn.SetPrinterInfo($100, AWidth, AHeight, AOr);
- Prn.FillPrnInfo(PrnInfo);
- end;
- end;
- pgSize := Prn.PaperSize;
- pgWidth := Prn.PaperWidth;
- pgHeight := Prn.PaperHeight;
- pgOr := 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
- if TfrView(Objects[i]).ID = ID then
- begin
- Result := i;
- break;
- end;
- end;
-
- function TfrPage.FindObject(Name: String): TfrView;
- var
- i: Integer;
- begin
- Result := nil;
- for i := 0 to Objects.Count - 1 do
- if AnsiCompareText(TfrView(Objects[i]).Name, Name) = 0 then
- begin
- Result := Objects[i];
- Exit;
- end;
- end;
-
- function TfrPage.FindRTObject(Name: String): TfrView;
- var
- i: Integer;
- begin
- Result := nil;
- for i := 0 to RTObjects.Count - 1 do
- if AnsiCompareText(TfrView(RTObjects[i]).Name, Name) = 0 then
- begin
- Result := RTObjects[i];
- Exit;
- 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
- if pgMargins.Top = 0 then
- Result := PrnInfo.Ofy else
- Result := pgMargins.Top
- else
- Result := 0;
- end;
-
- function TfrPage.BottomMargin: Integer;
- begin
- with PrnInfo do
- if UseMargins then
- if pgMargins.Bottom = 0 then
- Result := Ofy + Ph else
- Result := Pgh - pgMargins.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
- if pgMargins.Left = 0 then
- Result := PrnInfo.Ofx else
- Result := pgMargins.Left
- else
- Result := 0;
- end;
-
- function TfrPage.RightMargin: Integer;
- begin
- with PrnInfo do
- if UseMargins then
- if pgMargins.Right = 0 then
- Result := Ofx + Pw else
- Result := Pgw - pgMargins.Right
- else
- Result := Pgw;
- 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 := 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 := 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 := RTObjects[i];
- if (bt.Typ = gtBand) and
- (TfrBandType(bt.FrameTyp) in [btCrossHeader..btCrossFooter]) then
- with Bands[TfrBandType(bt.FrameTyp)] do
- begin
- Memo.Assign(bt.Memo);
- Script.Assign(bt.Script);
- x := bt.x; dx := bt.dx;
- InitDataSet(bt.FormatStr);
- View := bt;
- Flags := bt.Flags;
- Visible := bt.Visible;
- bt.Parent := Bands[TfrBandType(bt.FrameTyp)];
- 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 := 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 := RTObjects[i];
- if (bt.Typ = gtBand) and (bt.FrameTyp = Integer(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
- InitDataSet(FormatStr);
- 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 := 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 := 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 := 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 := 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(';', Bands[btCrossData].View.FormatStr) <> 0) then
- begin
- s := Bands[btCrossData].View.FormatStr;
- 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
- CurPage := Self;
- for i := 0 to RTObjects.Count - 1 do
- begin
- t := 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
- if Mode = pmBuildList then
- AddRecord(b, rtShowBand) else
- b.Draw;
- 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
- 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);
- ShowBand(Bands[btPageFooter]);
- end;
- Inc(PageNo);
- end;
- PageNo := MasterReport.EMFPages.Count;
- end;
-
- procedure TfrPage.NewPage;
- begin
- CurReport.InternalOnProgress(PageNo + 1);
- ShowBand(Bands[btColumnFooter]);
- DrawPageFooters;
- CurBottomY := BottomMargin;
- MasterReport.EMFPages.Add(Self);
- Append := False;
- ShowBand(Bands[btOverlay]);
- CurY := TopMargin;
- ShowBand(Bands[btPageHeader]);
- ShowBand(Bands[btColumnHeader]);
- end;
-
- procedure TfrPage.NewColumn(Band: TfrBand);
- var
- b: TfrBand;
- begin
- 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);
- end;
-
- procedure TfrPage.DoAggregate(a: Array of TfrBandType);
- var
- i: Integer;
- procedure DoAggregate1(bt: TfrBandType);
- var
- b: TfrBand;
- begin
- b := Bands[bt];
- while b <> nil do
- begin
- b.DoAggregate;
- b := b.Next;
- end;
- end;
- begin
- for i := Low(a) to High(a) do
- DoAggregate1(a[i]);
- end;
-
- procedure TfrPage.FormPage;
- var
- BndStack: Array[1..MAXBNDS * 3] of TfrBand;
- MaxLevel, BndStackTop: Integer;
- i, sfPage: Integer;
- HasGroups: Boolean;
-
- procedure AddToStack(b: TfrBand);
- begin
- if b <> nil then
- begin
- Inc(BndStackTop);
- BndStack[BndStackTop] := b;
- end;
- end;
-
- procedure ShowStack;
- var
- i: Integer;
- begin
- for i := 1 to BndStackTop do
- if BandExists(BndStack[i]) then
- ShowBand(BndStack[i]);
- BndStackTop := 0;
- end;
-
- procedure DoLoop(Level: Integer);
- var
- WasPrinted: Boolean;
- b, b1, b2: TfrBand;
-
- 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
- b := Bands[Bnds[Level, bpData]];
- while (b <> nil) and (b.Dataset <> nil) do
- begin
- b.DataSet.First;
- if Mode = pmBuildList then
- AddRecord(b, rtFirst) else
- b.Positions[psLocal] := 1;
-
- b1 := Bands[btGroupHeader];
- while b1 <> nil do
- begin
- b1.Positions[psLocal] := 0;
- b1.Positions[psGlobal] := 0;
- b1 := b1.Next;
- end;
-
- if not b.DataSet.Eof then
- begin
- if (Level = 1) and HasGroups then
- InitGroups(Bands[btGroupHeader]);
- if b.HeaderBand <> nil then
- AddToStack(b.HeaderBand);
- if b.FooterBand <> nil then
- b.FooterBand.InitValues;
-
- while not b.DataSet.Eof do
- begin
- Application.ProcessMessages;
- if MasterReport.Terminated then break;
- AddToStack(b);
- WasPrinted := True;
- if Level < MaxLevel then
- begin
- DoLoop(Level + 1);
- if BndStackTop > 0 then
- if b.PrintIfSubsetEmpty then
- ShowStack
- else
- begin
- Dec(BndStackTop);
- WasPrinted := False;
- end;
- end
- else ShowStack;
-
- b.DataSet.Next;
-
- if (Level = 1) and HasGroups then
- begin
- b1 := Bands[btGroupHeader];
- while b1 <> nil do
- begin
- if (frParser.Calc(b1.GroupCondition) <> b1.LastGroupValue) or
- b.Dataset.Eof then
- begin
- ShowBand(b.FooterBand);
- b2 := Bands[btGroupHeader].LastBand;
- while b2 <> b1 do
- begin
- ShowBand(b2.FooterBand);
- b2.Positions[psLocal] := 0;
- b2 := b2.Prev;
- end;
- ShowBand(b1.FooterBand);
- if not b.DataSet.Eof then
- begin
- if b1.NewPageAfter then NewPage;
- InitGroups(b1);
- ShowBand(b.HeaderBand);
- b.Positions[psLocal] := 0;
- end;
- break;
- end;
- b1 := b1.Next;
- end;
- end;
-
- if Mode = pmBuildList then
- AddRecord(b, rtNext)
- else if WasPrinted then
- begin
- Inc(CurPos);
- Inc(b.Positions[psGlobal]);
- Inc(b.Positions[psLocal]);
- if not b.DataSet.Eof and b.NewPageAfter then NewPage;
- end;
- if MasterReport.Terminated then break;
- end;
- if BndStackTop = 0 then
- ShowBand(b.FooterBand) else
- Dec(BndStackTop);
- end;
- b := b.Next;
- end;
- end;
-
- begin
- if Mode = pmNormal then
- begin
- if Append then
- if PrevY = PrevBottomY then
- begin
- Append := False;
- WasPF := False;
- PageNo := MasterReport.EMFPages.Count;
- end;
- if Append and WasPF then
- CurBottomY := PrevBottomY else
- CurBottomY := BottomMargin;
- CurColumn := 0;
- XAdjust := LeftMargin;
- if not Append then
- begin
- MasterReport.EMFPages.Add(Self);
- CurY := TopMargin;
- ShowBand(Bands[btOverlay]);
- ShowBand(Bands[btNone]);
- end
- else
- CurY := PrevY;
- sfPage := PageNo;
- 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]);
- ShowBand(Bands[btColumnHeader]);
- end;
- end;
-
- BndStackTop := 0;
- for i := 1 to MAXBNDS do
- if BandExists(Bands[Bnds[i, bpData]]) then
- MaxLevel := i;
- HasGroups := Bands[btGroupHeader].Objects.Count > 0;
- DoLoop(1);
- if Mode = pmNormal then
- begin
- 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;
- 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];
- begin
- with Stream do
- begin
- Read(pgSize, 4);
- Read(pgWidth, 4);
- Read(pgHeight, 4);
- Read(pgMargins, Sizeof(pgMargins));
- Read(b, 1);
- pgOr := TPrinterOrientation(b);
- if frVersion < 23 then
- Read(s[1], 6);
- Read(PrintToPrevPage, 2);
- Read(UseMargins, 2);
- Read(ColCount, 4);
- Read(ColGap, 4);
- end;
- ChangePaper(pgSize, pgWidth, pgHeight, pgOr);
- end;
-
- procedure TfrPage.SaveToStream(Stream: TStream);
- var
- b: Byte;
- begin
- with Stream do
- begin
- Write(pgSize, 4);
- Write(pgWidth, 4);
- Write(pgHeight, 4);
- Write(pgMargins, Sizeof(pgMargins));
- b := Byte(pgOr);
- Write(b, 1);
- Write(PrintToPrevPage, 2);
- Write(UseMargins, 2);
- Write(ColCount, 4);
- Write(ColGap, 4);
- end;
- 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 := 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;
- begin
- FPages.Add(TfrPage.Create(9, 0, 0, poPortrait));
- 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 := 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
- Stream.Read(b, 1);
- if b = $FF then // page info
- begin
- 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.SaveToStream(Stream: TStream);
- var
- b: Byte;
- i, j: Integer;
- t: TfrView;
- begin
- if CurReport.FR3Stream then
- begin
- SaveToFR3Stream(CurReport, Stream);
- Exit;
- end;
- 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
- 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 := 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;
-
- {-----------------------------------------------------------------------}
- 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.Handle = Printer.Canvas.Handle);
- DocMode := dmPrinting;
- p := FPages[Index];
- with p^ do
- 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 := Page.Objects[i];
- v := True;
- if not IsPrinting then
- with t, DrawRect do
- 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));
- 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;
-
- 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 := TfrPage.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 := 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.pgWidth;
- pgHeight := APage.pgHeight;
- pgOr := APage.pgOr;
- 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.Metafile.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.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;
-
- {-----------------------------------------------------------------------}
- 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.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;
-
- 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);
- begin
- inherited Create(AOwner);
- 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 := LoadStr(SUntitled);
- end;
-
- destructor TfrReport.Destroy;
- begin
- FVal.Free;
- FVars.Free;
- FEMFPages.Free;
- FEMFPages := nil;
- FPages.Free;
- inherited Destroy;
- 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
- with frProgressForm do
- begin
- if (MasterReport.DoublePass and MasterReport.FinalPass) or
- (FCurrentFilter <> nil) then
- Label1.Caption := FirstCaption + ' ' + IntToStr(Percent) + ' ' +
- LoadStr(SFrom) + ' ' + IntToStr(SavedAllPages)
- else
- Label1.Caption := FirstCaption + ' ' + IntToStr(Percent);
- Application.ProcessMessages;
- end;
- end;
-
- procedure TfrReport.InternalOnGetValue(ParName: String; var ParValue: String);
- var
- i, j, Format: Integer;
- FormatStr: String;
- begin
- SubValue := '';
- Format := CurView.Format;
- FormatStr := CurView.FormatStr;
- i := Pos(' #', ParName);
- if i <> 0 then
- begin
- FormatStr := Copy(ParName, i + 2, Length(ParName) - i - 1);
- ParName := Copy(ParName, 1, i - 1);
-
- if FormatStr[1] in ['0'..'9', 'N', 'n'] then
- begin
- if FormatStr[1] in ['0'..'9'] then
- FormatStr := 'N' + FormatStr;
- Format := $01000000;
- if FormatStr[2] in ['0'..'9'] then
- Format := Format + $00010000;
- i := Length(FormatStr);
- while i > 1 do
- begin
- if FormatStr[i] in ['.', ',', '-'] then
- begin
- Format := Format + Ord(FormatStr[i]);
- FormatStr[i] := '.';
- if FormatStr[2] in ['0'..'9'] then
- begin
- Inc(i);
- j := i;
- while (i <= Length(FormatStr)) and (FormatStr[i] in ['0'..'9']) do
- Inc(i);
- Format := Format + 256 * StrToInt(Copy(FormatStr, j, i - j));
- end;
- break;
- end;
- Dec(i);
- end;
- if not (FormatStr[2] in ['0'..'9']) then
- begin
- FormatStr := Copy(FormatStr, 2, 255);
- Format := Format + $00040000;
- end;
- end
- else if FormatStr[1] in ['D', 'T', 'd', 't'] then
- begin
- Format := $02040000;
- FormatStr := Copy(FormatStr, 2, 255);
- end
- else if FormatStr[1] in ['B', 'b'] then
- begin
- Format := $04040000;
- FormatStr := Copy(FormatStr, 2, 255);
- end;
- end;
-
- CurVariable := ParName;
- CurValue := 0;
- GetVariableValue(ParName, CurValue);
- ParValue := FormatValue(CurValue, Format, FormatStr);
- 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; Format: Integer;
- const FormatStr: String): String;
- var
- f1, f2: Integer;
- c: Char;
- s: String;
- begin
- if (TVarData(v).VType = varEmpty) or (v = Null) then
- begin
- Result := ' ';
- Exit;
- end;
- c := DecimalSeparator;
- f1 := (Format div $01000000) and $0F;
- f2 := (Format div $00010000) and $FF;
- try
- case f1 of
- 0: Result := v;
- 1:
- begin
- DecimalSeparator := Chr(Format and $FF);
- case f2 of
- 0: Result := FormatFloat('###.##', v);
- 1: Result := FloatToStrF(v, ffFixed, 15, (Format div $0100) and $FF);
- 2: Result := FormatFloat('#,###.##', v);
- 3: Result := FloatToStrF(v, ffNumber, 15, (Format div $0100) and $FF);
- 4: Result := FormatFloat(FormatStr, v);
- end;
- end;
- 2: if f2 = 4 then
- Result := FormatDateTime(FormatStr, v) else
- Result := FormatDateTime(frDateFormats[f2], v);
- 3: if f2 = 4 then
- Result := FormatDateTime(FormatStr, v) else
- Result := FormatDateTime(frTimeFormats[f2], v);
- 4:
- begin
- if f2 = 4 then
- s := FormatStr 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 exception do Result := v;
- end;
- DecimalSeparator := c;
- end;
-
- procedure TfrReport.GetVariableValue(const s: String; var v: 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(v).VType := varEmpty;
- if Assigned(FOnGetValue) then FOnGetValue(s, v);
- if TVarData(v).VType = varEmpty then
- begin
- Value := Values.FindVariable(s);
- if Value <> nil then
- with Value do
- case Typ of
- vtNotAssigned:
- v := '';
- vtDBField:
- begin
- F := TfrTField(DSet.FindField(Field));
- if not F.DataSet.Active then
- F.DataSet.Open;
- if Assigned(F.OnGetText) then
- v := F.DisplayText else
- v := F.AsVariant;
- end;
- vtFRVar:
- v := frParser.Calc(Field);
- vtOther:
- if OtherKind = 1 then
- v := frParser.Calc(Field) else
- v := frParser.Calc(frSpecFuncs[OtherKind]);
- 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
- v := F.DisplayText else
- v := F.AsVariant
- end
- else if s = 'VALUE' then
- v := CurValue
- else if s = frSpecFuncs[0] then
- v := PageNo + 1
- else if s = frSpecFuncs[2] then
- v := CurDate
- else if s = frSpecFuncs[3] then
- v := CurTime
- else if s = frSpecFuncs[4] then
- v := MasterBand.Positions[psLocal]
- else if s = frSpecFuncs[5] then
- v := MasterBand.Positions[psGlobal]
- else if s = frSpecFuncs[6] then
- v := CurPage.ColPos
- else if s = frSpecFuncs[7] then
- v := CurPage.CurPos
- else if s = frSpecFuncs[8] then
- v := SavedAllPages
- else
- begin
- if frVariables.IndexOf(s) <> -1 then
- begin
- v := frVariables[s];
- Exit;
- end;
- if s <> SubValue then
- begin
- SubValue := s;
- v := frParser.Calc(s);
- SubValue := '';
- end
- else raise(EParserError.Create('Undefined symbol "' + SubValue + '"'));
- end;
- end;
- end;
- end;
-
- procedure TfrReport.OnGetParsFunction(const name: String; p1, p2, p3: Variant;
- var val: String);
- var
- i: Integer;
- begin
- val := '0';
- for i := 0 to frFunctionsCount - 1 do
- if frFunctions[i].FunctionLibrary.OnFunction(name, p1, p2, p3, val) then
- exit;
- if AggrBand.Visible then
- if Assigned(FOnFunction) then FOnFunction(name, 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;
- MessageBox(0, PChar(LoadStr(SFRFError)), PChar(LoadStr(SError)),
- mb_Ok + mb_IconError);
- end
- else
- MessageBox(0, PChar(SFRFError), PChar(LoadStr(SError)),
- mb_Ok + mb_IconError);
- end;
-
- procedure TfrReport.SaveToStream(Stream: TStream);
- begin
- CurReport := Self;
- if FR3Stream then
- begin
- Pages.SaveToStream(Stream);
- Exit;
- end;
- frVersion := frCurrentVersion;
- Stream.Write(frVersion, 1);
- Pages.SaveToStream(Stream);
- end;
-
- procedure TfrReport.LoadFromFile(FName: String);
- var
- Stream: TFileStream;
- begin
- Stream := TFileStream.Create(FName, fmOpenRead);
- LoadFromStream(Stream);
- Stream.Free;
- FileName := FName;
- end;
-
- procedure TfrReport.SaveToFile(FName: String);
- var
- Stream: TFileStream;
- begin
- Stream := TFileStream.Create(FName, fmCreate);
- SaveToStream(Stream);
- Stream.Free;
- end;
-
- procedure TfrReport.SaveToFR3File(FName: String);
- var
- Stream: TFileStream;
- begin
- Stream := TFileStream.Create(ChangeFileExt(FName, '.fr3'), fmCreate);
- try
- FR3Stream := True;
- SaveToStream(Stream);
- finally
- FR3Stream := False;
- Stream.Free;
- end;
- end;
-
- {$IFDEF IBO}
- procedure TfrReport.LoadFromDB(Table: TIB_DataSet; DocN: Integer);
- {$ELSE}
- procedure TfrReport.LoadFromDB(Table: TDataSet; DocN: Integer);
- {$ENDIF}
- var
- Stream: TMemoryStream;
- begin
- Table.First;
- while not Table.Eof do
- begin
- if Table.Fields[0].AsInteger = DocN then
- begin
- Stream := TMemoryStream.Create;
- {$IFDEF IBO}
- TfrTBlobField(Table.Fields[1]).AssignTo(Stream);
- {$ELSE}
- TfrTBlobField(Table.Fields[1]).SaveToStream(Stream);
- {$ENDIF}
- Stream.Position := 0;
- LoadFromStream(Stream);
- Stream.Free;
- Exit;
- end;
- Table.Next;
- end;
- end;
-
- {$IFDEF IBO}
- procedure TfrReport.SaveToDB(Table: TIB_DataSet; DocN: Integer);
- {$ELSE}
- procedure TfrReport.SaveToDB(Table: TDataSet; DocN: Integer);
- {$ENDIF}
- 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;
- {$IFDEF IBO}
- TfrTBlobField(Table.Fields[1]).Assign(Stream);
- {$ELSE}
- TfrTBlobField(Table.Fields[1]).LoadFromStream(Stream);
- {$ENDIF}
- Stream.Free;
- Table.Post;
- end;
-
- procedure TfrReport.LoadPreparedReport(FName: String);
- var
- Stream: TFileStream;
- begin
- Stream := TFileStream.Create(FName, fmOpenRead);
- EMFPages.LoadFromStream(Stream);
- Stream.Free;
- CanRebuild := False;
- end;
-
- procedure TfrReport.SavePreparedReport(FName: String);
- var
- Stream: TFileStream;
- begin
- Stream := TFileStream.Create(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(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(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
- if Pages.Count = 0 then Pages.Add;
- CurReport := Self;
- HF := Application.HelpFile;
- Application.HelpFile := 'FRuser.hlp';
- if frDesigner <> nil then
- frDesigner.ShowModal;
- Application.HelpFile := HF;
- end;
-
- var
- FirstPassTerminated, FirstTime: Boolean;
-
- procedure TfrReport.BuildBeforeModal(Sender: TObject);
- begin
- DoBuildReport;
- if FinalPass then
- if Terminated then
- frProgressForm.ModalResult := mrCancel else
- frProgressForm.ModalResult := mrOk
- else
- begin
- FirstPassTerminated := Terminated;
- SavedAllPages := EMFPages.Count;
- DoublePass := False;
- FirstTime := False;
- DoPrepareReport; // do final pass
- DoublePass := True;
- 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;
-
- s := LoadStr(SReportPreparing);
- if DoublePass then
- begin
- DisableDrawing := True;
- FinalPass := False;
- if not Assigned(FOnProgress) and FShowProgress then
- with frProgressForm do
- begin
- if Title = '' then
- Caption := s else
- Caption := s + ' - ' + Title;
- FirstCaption := LoadStr(SFirstPass);
- Label1.Caption := FirstCaption + ' 1';
- OnBeforeModal := BuildBeforeModal;
- Show_Modal(Self);
- end
- else
- BuildBeforeModal(nil);
- Exit;
- end;
- if not Assigned(FOnProgress) and FShowProgress then
- with frProgressForm do
- begin
- if Title = '' then
- Caption := s else
- Caption := s + ' - ' + Title;
- FirstCaption := LoadStr(SPagePreparing);
- Label1.Caption := FirstCaption + ' 1';
- OnBeforeModal := BuildBeforeModal;
- if Visible then
- begin
- if not FirstPassTerminated then DoublePass := True;
- BuildBeforeModal(nil);
- end
- else
- begin
- SavedAllPages := 0;
- if Show_Modal(Self) = mrCancel then
- Result := False;
- 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; FileName: String);
- var
- s: String;
- begin
- ExportStream := TFileStream.Create(FileName, fmCreate);
- FCurrentFilter := TfrExportFilter(Filter.NewInstance);
- FCurrentFilter.Create(ExportStream);
- FCurrentFilter.OnBeginDoc;
-
- CurReport := Self;
- MasterReport := Self;
- SavedAllPages := EMFPages.Count;
- with frProgressForm do
- begin
- s := LoadStr(SReportPreparing);
- if Title = '' then
- Caption := s else
- Caption := s + ' - ' + Title;
- FirstCaption := LoadStr(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 := Pages[i].Objects[j];
- if t is TfrBandView then
- PrepareDS(frFindComponent(CurReport.Owner, t.FormatStr) as TfrDataSet);
- end;
- frDataManager.AfterPreparing;
- end;
-
- procedure TfrReport.DoBuildReport;
- var
- i: Integer;
- b: Boolean;
- 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
- Dataset.Init;
- Dataset.First;
- end;
- 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
- Pages[i].PrepareObjects;
-
- repeat
- InternalOnProgress(PageNo + 1);
- for i := 0 to Pages.Count - 1 do
- begin
- FCurPage := Pages[i];
- if FCurPage.Skip then continue;
- FCurPage.Mode := pmNormal;
- if Assigned(FOnManualBuild) then
- FOnManualBuild(FCurPage) else
- FCurPage.FormPage;
-
- 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;
- 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;
- if b then
- Dataset.Exit;
- if (frDataManager <> nil) and FinalPass then
- frDataManager.AfterPreparing;
- Values.Items.Sorted := False;
- end;
-
- procedure TfrReport.ShowReport;
- begin
- PrepareReport;
- if ErrorFlag then
- begin
- MessageBox(0, PChar(ErrorStr), PChar(LoadStr(SError)),
- mb_Ok + mb_IconError);
- 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 := LoadStr(SPreview);
- if Title <> '' then s := s + ' - ' + Title;
- if not (csDesigning in ComponentState) and Assigned(Preview) then
- Preview.Connect(Self)
- else
- begin
- p := TfrPreviewForm.Create(nil);
- p.Caption := s;
- 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 := LoadStr(SReportPreparing);
- Terminated := False;
- FPageNumbers := PageNumbers;
- FCopies := Copies;
- if not Assigned(FOnProgress) and FShowProgress then
- with frProgressForm do
- begin
- if Title = '' then
- Caption := s else
- Caption := s + ' - ' + Title;
- FirstCaption := LoadStr(SPagePrinting);
- Label1.Caption := FirstCaption;
- OnBeforeModal := PrintBeforeModal;
- Show_Modal(Self);
- end
- else
- PrintBeforeModal(nil);
- Terminated := False;
- end;
-
- {$IFDEF Trial}
- {$HINTS OFF}
- 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
- while n1 <= n2 do
- begin
- pgList.Add(IntToStr(n1));
- Inc(n1);
- 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);
- var
- s: String[40];
- 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
- 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));
-
- Visible := False;
- EMFPages.Draw(n, Printer.Canvas, Rect(0, 0, 0, 0));
-
- s[0] := #25;
- s[1] := 'F';
- s[2] := 'a';
- s[3] := 's';
- s[4] := 't';
- s[5] := 'R';
- s[6] := 'e';
- s[7] := 'p';
- s[8] := 'o';
- s[9] := LowerCase(s[5])[1];
- s[10] := s[4];
- s[11] := ' ';
- s[12] := '-';
- s[13] := s[11];
- s[14] := 'u';
- s[15] := 'n';
- s[16] := s[9];
- s[17] := s[6];
- s[18] := 'g';
- s[19] := 'i';
- s[20] := s[3];
- s[21] := s[4];
- s[22] := s[6];
- s[23] := s[9];
- s[24] := s[6];
- s[25] := 'd';
- Canvas.TextOut(10, 10, s);
- end;
- InternalOnProgress(n + 1);
- Application.ProcessMessages;
- f := False;
- Printer.EndDoc;
- pgList.Free;
- end;
-
- begin
- 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;
- if Title <> '' then
- Printer.Title := 'FastReport: ' + Title else
- Printer.Title := 'FastReport: ' + LoadStr(SUntitled);
-
- Printer.BeginDoc;
- f := True;
- for i := 0 to EMFPages.Count - 1 do
- if (pgList.Count = 0) or (pgList.IndexOf(IntToStr(i + 1)) <> -1) then
- begin
- PrintPage(i);
- Exit;
- end;
- end;
- {$HINTS ON}
- {$ELSE}
- 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
- while n1 <= n2 do
- begin
- pgList.Add(IntToStr(n1));
- Inc(n1);
- 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
- 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));
-
- Visible := False;
- EMFPages.Draw(n, Printer.Canvas, Rect(0, 0, 0, 0));
- end;
- InternalOnProgress(n + 1);
- Application.ProcessMessages;
- f := False;
- end;
-
- begin
- 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;
- if Title <> '' then
- Printer.Title := 'FastReport: ' + Title else
- Printer.Title := 'FastReport: ' + LoadStr(SUntitled);
-
- Printer.BeginDoc;
- f := True;
- for i := 0 to EMFPages.Count - 1 do
- if (pgList.Count = 0) or (pgList.IndexOf(IntToStr(i + 1)) <> -1) then
- for j := 0 to Copies - 1 do
- begin
- PrintPage(i);
- if Terminated then
- begin
- Printer.Abort;
- pgList.Free;
- Exit;
- end;
- end;
- Printer.EndDoc;
- pgList.Free;
- end;
- {$ENDIF}
-
- // printer manipulation methods
-
- procedure TfrReport.SetPrinterTo(PrnName: String);
- begin
- if not PrintToDefault then
- if Prn.Printers.IndexOf(PrnName) <> -1 then
- Prn.PrinterIndex := Prn.Printers.IndexOf(PrnName);
- end;
-
- function TfrReport.ChangePrinter(OldIndex, NewIndex: Integer): Boolean;
- procedure ChangePages;
- var
- i: Integer;
- begin
- for i := 0 to Pages.Count - 1 do
- with Pages[i] do
- ChangePaper(pgSize, pgWidth, pgHeight, pgOr);
- end;
- begin
- Result := True;
- try
- Prn.PrinterIndex := NewIndex;
- Prn.PaperSize := -1;
- ChangePages;
- except
- on Exception do
- begin
- MessageBox(0, PChar(LoadStr(SPrinterError)),
- PChar(LoadStr(SError)), mb_IconError + mb_Ok);
- 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 MessageBox(0, PChar(LoadStr(SSaveChanges) + '?'),
- PChar(LoadStr(SConfirm)), mb_YesNo + mb_IconQuestion) = 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.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 (s <> '') 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(Name: String): TfrView;
- var
- i, j: Integer;
- begin
- Result := nil;
- for i := 0 to Pages.Count - 1 do
- for j := 0 to Pages[i].Objects.Count - 1 do
- if AnsiCompareText(TfrView(Pages[i].Objects[j]).Name, Name) = 0 then
- begin
- Result := Pages[i].Objects[j];
- Exit;
- 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;
- begin
- List.Free;
- inherited Destroy;
- end;
-
- function TfrFunctionLibrary.OnFunction(const FName: String; p1, p2, p3: Variant;
- var val: String): Boolean;
- var
- i: Integer;
- begin
- Result := False;
- if List.Find(FName, i) then
- begin
- DoFunction(i, p1, p2, p3, val);
- Result := True;
- end;
- end;
-
-
- {----------------------------------------------------------------------------}
- constructor TfrStdFunctionLibrary.Create;
- begin
- inherited Create;
- with List do
- begin
- Add('AVG');
- Add('COUNT');
- Add('FORMATDATETIME');
- Add('FORMATFLOAT');
- Add('INPUT');
- Add('LOWERCASE');
- Add('MAX');
- Add('MIN');
- Add('NAMECASE');
- Add('STRTODATE');
- Add('STRTOTIME');
- Add('SUM');
- Add('UPPERCASE');
- end;
- end;
-
- procedure TfrStdFunctionLibrary.DoFunction(FNo: Integer; p1, p2, p3: Variant;
- var val: String);
- var
- DataSet: TfrTDataSet;
- Field: TfrTField;
- s1, s2, VarName: String;
- min, max, avg, sum, count, d, v: Double;
- dk: (dkNone, dkSum, dkMin, dkMax, dkAvg, dkCount);
- vv: Variant;
- begin
- dk := dkNone;
- val := '0';
- case FNo of
- 0: dk := dkAvg;
- 1: dk := dkCount;
- 2: val := '''' + FormatDateTime(frParser.Calc(p1), frParser.Calc(p2)) + '''';
- 3: val := '''' + FormatFloat(frParser.Calc(p1), frParser.Calc(p2)) + '''';
- 4:
- begin
- s1 := InputBox('', frParser.Calc(p1), frParser.Calc(p2));
- val := '''' + s1 + '''';
- end;
- 5: val := '''' + AnsiLowerCase(frParser.Calc(p1)) + '''';
- 6: dk := dkMax;
- 7: dk := dkMin;
- 8:
- begin
- s1 := AnsiLowerCase(frParser.Calc(p1));
- if Length(s1) > 0 then
- val := '''' + AnsiUpperCase(s1[1]) + Copy(s1, 2, Length(s1) - 1) + ''''
- else
- val := '''' + '''';
- end;
- 9: val := '%d''' + frParser.Calc(p1) + '''';
- 10: val := '%t''' + frParser.Calc(p1) + '''';
- 11: dk := dkSum;
- 12: val := '''' + AnsiUpperCase(frParser.Calc(p1)) + '''';
- end;
- if dk <> dkNone then
- begin
- if dk = dkCount then
- DataSet := frGetDataSet(p1) else
- frGetDataSetAndField(p1, DataSet, Field);
- if (DataSet <> nil) and AggrBand.Visible then
- begin
- min := 1e200; max := -1e200; sum := 0; count := 0; avg := 0;
- DataSet.First;
- while not DataSet.Eof do
- begin
- v := 0;
- if dk <> dkCount then
- if Field.Value <> Null then
- v := Field.AsFloat else
- v := 0;
- if v > max then max := v;
- if v < min then min := v;
- sum := sum + v;
- count := count + 1;
- DataSet.Next;
- 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(p2);
- if s1 = '' then
- s1 := CurBand.View.Name;
- if dk <> dkCount then
- s2 := Trim(p3) else
- s2 := Trim(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 vv = Null 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 = 16;
- PropNames: Array[0..PropCount - 1] of String =
- ('Left', 'Top', 'Width', 'Height', 'Flags', 'Visible', 'FrameTyp',
- 'FrameWidth', 'FrameColor', 'FillColor', '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
- i: Integer;
- t: TfrView;
- b: TfrBand;
- Prop: String;
- Flag: Boolean;
- begin
- 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
- t := CurPage.FindRTObject(Copy(Name, 1, Pos('.', Name) - 1));
- Prop := Copy(Name, Pos('.', Name) + 1, 255);
- end;
- if t = nil then
- begin
- frParser.OnGetValue(Name, Value);
- Exit;
- end;
- Flag := False;
- for i := 0 to PropCount - 1 do
- if AnsiCompareText(PropNames[i], Prop) = 0 then
- begin
- Flag := True;
- break;
- end;
- if not Flag then
- for i := 0 to 16 do
- if AnsiCompareText(ColNames[i], Prop) = 0 then
- begin
- if i <> 16 then
- Value := frColors[i] else
- Value := clNone;
- Exit;
- end;
-
- if not Flag or ((i >= 11) and not (t is TfrMemoView)) then
- begin
- frParser.OnGetValue(Name, Value);
- Exit;
- end;
- if t is TfrBandView then
- begin
- b := t.Parent;
- case i of
- 0: Value := b.x;
- 1: Value := b.y;
- 2: Value := b.dx;
- 3: Value := b.dy;
- 5: Value := b.Visible;
- end;
- end
- else
- case i of
- 0: Value := t.x;
- 1: Value := t.y;
- 2: Value := t.dx;
- 3: Value := t.dy;
- 4: Value := t.Flags;
- 5: Value := t.Visible;
- 6: Value := t.FrameTyp;
- 7: Value := t.FrameWidth;
- 8: Value := t.FrameColor;
- 9: Value := t.FillColor;
- 10: Value := t.Memo.Text;
- 11: Value := TfrMemoView(t).Font.Name;
- 12: Value := TfrMemoView(t).Font.Size;
- 13: Value := frGetFontStyle(TfrMemoView(t).Font.Style);
- 14: Value := TfrMemoView(t).Font.Color;
- 15: Value := TfrMemoView(t).Adjust;
- end;
- end;
- {$WARNINGS ON}
-
- procedure TInterpretator.SetValue(const Name: String; Value: Variant);
- var
- i: Integer;
- t: TfrView;
- b: TfrBand;
- Prop: String;
- Flag: Boolean;
- begin
- t := CurView;
- Prop := Name;
- if Pos('.', Name) <> 0 then
- begin
- t := CurPage.FindRTObject(Copy(Name, 1, Pos('.', Name) - 1));
- Prop := Copy(Name, Pos('.', Name) + 1, 255);
- end;
- // if t = nil then Exit;
- Flag := False;
- for i := 0 to PropCount - 1 do
- if AnsiCompareText(PropNames[i], Prop) = 0 then
- begin
- Flag := True;
- break;
- end;
- if not Flag then
- begin
- frVariables[Name] := Value;
- Exit;
- end;
- if (i >= 11) and not (t is TfrMemoView) then Exit;
- if t is TfrBandView then
- begin
- b := t.Parent;
- case i of
- 0: b.x := Value;
- 1: b.y := Value;
- 2: b.dx := Value;
- 3: b.dy := Value;
- 5: b.Visible := Value;
- end;
- end
- else
- case i of
- 0: t.x := Value;
- 1: t.y := Value;
- 2: t.dx := Value;
- 3: t.dy := Value;
- 4: t.Flags := Value;
- 5: t.Visible := Value;
- 6: t.FrameTyp := Value;
- 7: t.FrameWidth := Value;
- 8: t.FrameColor := Value;
- 9: t.FillColor := Value;
- 10: t.Memo.Text := Value;
- 11: TfrMemoView(t).Font.Name := Value;
- 12: TfrMemoView(t).Font.Size := Value;
- 13: TfrMemoView(t).Font.Style := frSetFontStyle(Value);
- 14: TfrMemoView(t).Font.Color := Value;
- 15: TfrMemoView(t).Adjust := Value;
- end;
- end;
-
- procedure TInterpretator.DoFunction(const Name: String; p1, p2, p3: Variant;
- var val: String);
- 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;
- const
- Clr: Array[0..1] of TColor = (clWhite, clSilver);
- var
- i, j: Integer;
- begin
- SMemo := TStringList.Create;
- SBmp := TBitmap.Create;
- TempBmp := TBitmap.Create;
- SBmp.Width := 8; SBmp.Height := 8;
- TempBmp.Width := 8; TempBmp.Height := 8;
- for j := 0 to 7 do
- for i := 0 to 7 do
- SBmp.Canvas.Pixels[i, j] := Clr[(j + i) mod 2];
- frRegisterFunctionLibrary(TfrStdFunctionLibrary);
- frProgressForm := TfrProgressForm.Create(nil);
- frCharset := StrToInt(LoadStr(SCharset));
-
- for i := 0 to 21 do
- frBandNames[i] := LoadStr(SBand1 + i);
- for i := 0 to frSpecCount - 1 do
- frSpecArr[i] := LoadStr(SVar1 + i);
- for i := 0 to 3 do
- BoolStr[i] := LoadStr(SFormat51 + i);
- for i := 0 to 3 do
- begin
- frDateFormats[i] := LoadStr(SDateFormat1 + i);
- frTimeFormats[i] := LoadStr(STimeFormat1 + i);
- end;
- 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;
-
-
- initialization
- DoInit;
-
- finalization
- DoExit;
-
- end.
-