fr_class.pas

FASTREPORT报表工具,可以迅速制作报表.

{******************************************}
{                                          }
{             FastReport v2.4              }
{             Report classes               }
{                                          }
{ Copyright (c) 1998-2001 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_Progr, FR_View, FR_Pars, FR_Intrp, FR_DSet, FR_DBSet, FR_DBRel
{$IFDEF IBO}
, IB_Components, IB_Header
{$ELSE}
, DB
{$ENDIF}
{$IFDEF Delphi6}
, Variants
{$ENDIF};


const
// object flags
  flStretched = 1;
  flWordWrap = 2;
  flWordBreak = 4;
  flAutoSize = 8;
  flTextOnly = $10;
  flSuppressRepeated = $20;
  flHideZeros = $40;
  flUnderlines = $80;
  flRTLReading = $100;
  flBandNewPageAfter = 2;
  flBandPrintifSubsetEmpty = 4;
  flBandBreaked = 8;
  flBandOnFirstPage = $10;
  flBandOnLastPage = $20;
  flBandRepeatHeader = $40;
  flBandPrintChildIfInvisible = $80;
  flPictCenter = 2;
  flPictRatio = 4;
  flWantHook = $8000;
  flDontUndo = $4000;
  flOnePerPage = $2000;

// object types
  gtMemo = 0;
  gtPicture = 1;
  gtBand = 2;
  gtSubReport = 3;
  gtLine = 4;
  gtCross = 5;
  gtAddIn = 10;

// frame types
  frftNone = 0;
  frftRight = 1;
  frftBottom = 2;
  frftLeft = 4;
  frftTop = 8;

// text align
  frtaLeft = 0;
  frtaRight = 1;
  frtaCenter = 2;
  frtaVertical = 4;
  frtaMiddle = 8;
  frtaDown = 16;

// band align
  baNone = 0;
  baLeft = 1;
  baRight = 2;
  baCenter = 3;
  baWidth = 4;
  baBottom = 5;
  baTop = 6;
  baRest = 7;

// restriction flags
  frrfDontEditMemo = 1;
  frrfDontEditScript = 2;
  frrfDontEditContents = 4;
  frrfDontModify = 8;
  frrfDontSize = 16;
  frrfDontMove = 32;
  frrfDontDelete = 64;

  psDouble = 5;

type
  TfrDocMode = (dmDesigning, dmPrinting);
  TfrDrawMode = (drAll, drAfterCalcHeight, drPart);
  TfrBandType = (btReportTitle, btReportSummary,
                 btPageHeader, btPageFooter,
                 btMasterHeader, btMasterData, btMasterFooter,
                 btDetailHeader, btDetailData, btDetailFooter,
                 btSubDetailHeader, btSubDetailData, btSubDetailFooter,
                 btOverlay, btColumnHeader, btColumnFooter,
                 btGroupHeader, btGroupFooter,
                 btCrossHeader, btCrossData, btCrossFooter,
                 btChild, btNone);
  TfrPageType = (ptReport, ptDialog);
  TfrDataSetPosition = (psLocal, psGlobal);
  TfrPageMode = (pmNormal, pmBuildList);
  TfrBandRecType = (rtShowBand, rtFirst, rtNext);
  TfrRgnType = (rtNormal, rtExtended);
  TfrReportType = (rtSimple, rtMultiple);
  TfrDataType = (frdtString, frdtInteger, frdtFloat, frdtBoolean,
                 frdtColor, frdtEnum, frdtHasEditor, frdtSize,
                 frdtOneObject);
  TfrDataTypes = set of TfrDataType;
  TfrPrintPages = (frAll, frOdd, frEven);

  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;
  TObjectClickEvent = procedure(View: TfrView) of object;
  TMouseOverObjectEvent = procedure(View: TfrView; var Cursor: TCursor) of object;
  TBeforeExportEvent = procedure(var FileName: String; var bContinue: Boolean) of object;
  TAfterExportEvent = procedure(const FileName: String) of object;
  TPrintReportEvent = procedure of object;
  TLocalizeEvent = procedure(StringID: Integer; var ResultString: String) 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;
    pgBin: Integer;
    UseMargins: Boolean;
    pgMargins: TRect;
    PrnInfo: TfrPrnInfo;
    Visible: Boolean;
    Stream: TMemoryStream;
    Page: TfrPage;
  end;

  PfrBandRec = ^TfrBandRec;
  TfrBandRec = packed record
    Band: TfrBand;
    Action: TfrBandRecType;
  end;

  PfrPropRec = ^TfrPropRec;
  TfrPropRec = record
    PropName: String[32];
    PropType: TfrDataTypes;
    Enum: TStringList;
    EnumValues: Variant;
    PropEditor: TNotifyEvent;
  end;

  TfrObject = class(TObject)
  protected
    PropList: TList;
    procedure ClearPropList;
    procedure AddProperty(PropName: String; PropType: TfrDataTypes;
      PropEditor: TNotifyEvent);
    procedure AddEnumProperty(PropName: String; Enum: String;
      const EnumValues: array of Variant);
    procedure DelProperty(PropName: String);
    procedure SetPropValue(Index: String; Value: Variant); virtual;
    function GetPropValue(Index: String): Variant; virtual;
    function GetPropRec(Index: String): PfrPropRec;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; virtual;
// helper methods
    procedure SetFontProp(Font: TFont; Prop: String; Value: Variant);
    function GetFontProp(Font: TFont; Prop: String): Variant;
    function LinesMethod(Lines: TStrings; MethodName, LinesName: String;
      Par1, Par2, Par3: Variant): Variant;
  public
    constructor Create;
    destructor Destroy; override;
    procedure DefineProperties; virtual;
    property Prop[Index: String]: Variant read GetPropValue write SetPropValue;
    property PropRec[Index: String]: PfrPropRec read GetPropRec;
  end;

  TfrView = class(TfrObject)
  private
    Flag1: Boolean;
    olddy: Integer;
    procedure P1Click(Sender: TObject);
  protected
    SaveX, SaveY, SaveDX, SaveDY, SaveGX, SaveGY: Integer;
    SaveFW: Single;
    BaseName: String;
    Canvas: TCanvas;
    DRect: TRect;
    Memo1: TStringList;
    FDataSet: TfrTDataSet;
    FField: String;
    StreamMode: (smFRF, smFRP);
    procedure ShowBackground; virtual;
    procedure ShowFrame; virtual;
    procedure BeginDraw(ACanvas: TCanvas);
    procedure GetBlob(b: TfrTField); virtual;
    procedure OnHook(View: TfrView); virtual;
    procedure ExpandVariables(var s: String);
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    procedure Loaded; virtual;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
    function ParentBand: TfrView;
  public
    Name: String;
    Typ: Byte;                // One of gtXXX constants
    HVersion, LVersion: Byte;
    ID: Integer;              // UID - used in designer (undo support)
    Selected: Boolean;        // used in designer
    OriginalRect: TRect;
    ScaleX, ScaleY: Double;   // used for scaling objects in preview
    OffsX, OffsY: Integer;    //
    IsPrinting: Boolean;      // True if printing on printer canvas
    x, y, dx, dy: Integer;
    Flags: Word;
    FrameTyp: Word;
    FrameWidth: Single;
    FrameColor: TColor;
    FrameStyle: Word;
    FillColor: TColor;
    Format: Integer;
    FormatStr: String;
    Visible: WordBool;
    gapx, gapy: Integer;
    Restrictions: Word;
    Tag: String;
    Memo, Script: TStringList;
    BandAlign: Byte;
    Parent: TfrBand;
    ParentPage: TfrPage;
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Assign(From: TfrView);
    procedure CalcGaps; virtual;
    procedure RestoreCoord; virtual;
    procedure Draw(Canvas: TCanvas); virtual; abstract;
    procedure StreamOut(Stream: TStream); virtual;
    procedure ExportData; virtual;
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure SaveToStream(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);
    procedure DefineProperties; override;
    procedure ShowEditor; virtual;
  end;

  TfrControl = class(TfrView)
  protected
    FControl: TControl;
    procedure PaintDesignControl; virtual;
    procedure SetPropValue(Index: String; Value: Variant); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure DefineProperties; override;
    procedure PlaceControl(Form: TForm);
    procedure Draw(Canvas: TCanvas); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    property Control: TControl read FControl;
  end;

  TfrNonVisualControl = class(TfrControl)
  protected
    Bmp: TBitmap;
    Component: TComponent;
    FFixupList: TfrVariables;
    procedure SetPropValue(Index: String; Value: Variant); override;
    procedure PaintDesignControl; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure DefineProperties; override;
    procedure PlaceControl(Form: TForm);
    procedure Draw(Canvas: TCanvas); override;
  end;

  TfrStretcheable = class(TfrView)
  protected
    DrawMode: TfrDrawMode;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
    function CalcHeight: Integer; virtual; abstract;
    function MinHeight: Integer; virtual; abstract;
    function LostSpace: Integer; virtual; abstract;
  end;

  TfrMemoView = class(TfrStretcheable)
  private
    FFont: TFont;
    LastValue: String;
    FWrapped: Boolean;
    procedure P1Click(Sender: TObject);
    procedure P2Click(Sender: TObject);
    procedure P3Click(Sender: TObject);
    procedure P5Click(Sender: TObject);
    procedure P6Click(Sender: TObject);
    procedure P8Click(Sender: TObject);
    procedure P9Click(Sender: TObject);
    procedure P10Click(Sender: TObject);
    procedure P11Click(Sender: TObject);
    procedure SetFont(Value: TFont);
  protected
    Streaming: Boolean;
    TextHeight: Integer;
    CurStrNo: Integer;
    Exporting: Boolean;
    procedure ExpandMemoVariables;
    procedure AssignFont(Canvas: TCanvas);
    procedure WrapMemo;
    procedure ShowMemo;
    procedure ShowUnderLines;
    function CalcWidth(Memo: TStringList): Integer;
    function CalcHeight: Integer; override;
    function MinHeight: Integer; override;
    function LostSpace: Integer; override;
    procedure GetBlob(b: TfrTField); override;
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public
    Alignment: Integer;
    Highlight: TfrHighlightAttr;
    HighlightStr: String;
    LineSpacing, CharacterSpacing: Integer;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure ExportData; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; 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);
    procedure P7Click(Sender: TObject);
    function GetBandType: TfrBandType;
    procedure SetBandType(const Value: TfrBandType);
    function GetRectangleWidth: Integer;
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
    function DoMethod(MethodName: String; Par1, Par2, Par3: Variant): Variant; override;
  public