PageRenderTime 67ms CodeModel.GetById 20ms app.highlight 14ms RepoModel.GetById 2ms app.codeStats 4ms

/Source/FR_Class.pas

http://github.com/FastReports/FreeReport
Pascal | 7335 lines | 6646 code | 487 blank | 202 comment | 865 complexity | 52e74cfa96e31edbea7bd9f745adfb88 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1
   2{*****************************************}
   3{                                         }
   4{             FastReport v2.3             }
   5{             Report classes              }
   6{                                         }
   7{  Copyright (c) 1998-99 by Tzyganenko A. }
   8{                                         }
   9{*****************************************}
  10
  11unit FR_Class;
  12
  13interface
  14
  15{$I FR.inc}
  16
  17uses
  18  SysUtils, Windows, Messages, Classes, Graphics, Printers, Controls,
  19  Forms, StdCtrls, ComCtrls, Dialogs, Menus, Buttons,
  20  FR_View, FR_Pars, FR_Intrp, FR_DSet, FR_DBSet, FR_DBRel
  21{$IFDEF Delphi6}
  22  , Variants
  23{$ENDIF}
  24{$IFDEF IBO}
  25 , IB_Components
  26{$ELSE}
  27 , DB
  28{$ENDIF};
  29
  30
  31const
  32// object flags
  33  flStretched = 1;
  34  flWordWrap = 2;
  35  flWordBreak = 4;
  36  flAutoSize = 8;
  37  flBandNewPageAfter = 2;
  38  flBandPrintifSubsetEmpty = 4;
  39  flBandPageBreak = 8;
  40  flBandOnFirstPage = $10;
  41  flBandOnLastPage = $20;
  42  flBandRepeatHeader = $40;
  43  flPictCenter = 2;
  44  flPictRatio = 4;
  45  flWantHook = $8000;
  46
  47// object types
  48  gtMemo = 0;
  49  gtPicture = 1;
  50  gtBand = 2;
  51  gtSubReport = 3;
  52  gtLine = 4;
  53  gtAddIn = 10;
  54
  55// frame types
  56  frftNone = 0;
  57  frftRight = 1;
  58  frftDown = 2;
  59  frftLeft = 4;
  60  frftUp = 8;
  61
  62// text align
  63  frtaLeft = 0;
  64  frtaRight = 1;
  65  frtaCenter = 2;
  66  frtaVertical = 4;
  67  frtaMiddle = 8;
  68  frtaDown = 16;
  69
  70type
  71  TfrDrawMode = (drAll, drCalcHeight, drAfterCalcHeight, drPart);
  72  TfrBandType = (btReportTitle, btReportSummary,
  73                 btPageHeader, btPageFooter,
  74                 btMasterHeader, btMasterData, btMasterFooter,
  75                 btDetailHeader, btDetailData, btDetailFooter,
  76                 btSubDetailHeader, btSubDetailData, btSubDetailFooter,
  77                 btOverlay, btColumnHeader, btColumnFooter,
  78                 btGroupHeader, btGroupFooter,
  79                 btCrossHeader, btCrossData, btCrossFooter, btNone);
  80  TfrDataSetPosition = (psLocal, psGlobal);
  81  TfrValueType = (vtNotAssigned, vtDBField, vtOther, vtFRVar);
  82  TfrPageMode = (pmNormal, pmBuildList);
  83  TfrBandRecType = (rtShowBand, rtFirst, rtNext);
  84  TfrRgnType = (rtNormal, rtExtended);
  85  TfrReportType = (rtSimple, rtMultiple);
  86
  87  TfrView = class;
  88  TfrBand = class;
  89  TfrPage = class;
  90  TfrReport = class;
  91  TfrExportFilter = class;
  92
  93  TDetailEvent = procedure(const ParName: String; var ParValue: Variant) of object;
  94  TEnterRectEvent = procedure(Memo: TStringList; View: TfrView) of object;
  95  TBeginDocEvent = procedure of object;
  96  TEndDocEvent = procedure of object;
  97  TBeginPageEvent = procedure(pgNo: Integer) of object;
  98  TEndPageEvent = procedure(pgNo: Integer) of object;
  99  TBeginBandEvent = procedure(Band: TfrBand) of object;
 100  TEndBandEvent = procedure(Band: TfrBand) of object;
 101  TProgressEvent = procedure(n: Integer) of object;
 102  TBeginColumnEvent = procedure(Band: TfrBand) of object;
 103  TPrintColumnEvent = procedure(ColNo: Integer; var Width: Integer) of object;
 104  TManualBuildEvent = procedure(Page: TfrPage) of object;
 105
 106  TfrHighlightAttr = packed record
 107    FontStyle: Word;
 108    FontColor, FillColor: TColor;
 109  end;
 110
 111  TfrPrnInfo = record // print info about page size, margins e.t.c
 112    PPgw, PPgh, Pgw, Pgh: Integer; // page width/height (printer/screen)
 113    POfx, POfy, Ofx, Ofy: Integer; // offset x/y
 114    PPw, PPh, Pw, Ph: Integer;     // printable width/height
 115  end;
 116
 117  PfrPageInfo = ^TfrPageInfo;
 118  TfrPageInfo = packed record // pages of a preview
 119    R: TRect;
 120    pgSize: Word;
 121    pgWidth, pgHeight: Integer;
 122    pgOr: TPrinterOrientation;
 123    pgMargins: Boolean;
 124    PrnInfo: TfrPrnInfo;
 125    Visible: Boolean;
 126    Stream: TMemoryStream;
 127    Page: TfrPage;
 128  end;
 129
 130  PfrBandRec = ^TfrBandRec;
 131  TfrBandRec = packed record
 132    Band: TfrBand;
 133    Action: TfrBandRecType;
 134  end;
 135
 136  TfrView = class(TObject)
 137  private
 138    procedure P1Click(Sender: TObject);
 139  protected
 140    SaveX, SaveY, SaveDX, SaveDY: Integer;
 141    SaveFW: Single;
 142    BaseName: String;
 143    Canvas: TCanvas;
 144    DRect: TRect;
 145    gapx, gapy: Integer;
 146    Memo1: TStringList;
 147    FDataSet: TfrTDataSet;
 148    FField: String;
 149    olddy: Integer;
 150    StreamMode: (smDesigning, smPrinting);
 151    procedure ShowBackGround; virtual;
 152    procedure ShowFrame; virtual;
 153    procedure BeginDraw(ACanvas: TCanvas);
 154    procedure GetBlob(b: TfrTField); virtual;
 155    procedure OnHook(View: TfrView); virtual;
 156  public
 157    Parent: TfrBand;
 158    Name: String;
 159    ID: Integer;
 160    Typ: Byte;
 161    Selected: Boolean;
 162    OriginalRect: TRect;
 163    ScaleX, ScaleY: Double;   // used for scaling objects in preview
 164    OffsX, OffsY: Integer;    //
 165    IsPrinting: Boolean;
 166    x, y, dx, dy: Integer;
 167    Flags: Word;
 168    FrameTyp: Word;
 169    FrameWidth: Single;
 170    FrameColor: TColor;
 171    FrameStyle: Word;
 172    FillColor: TColor;
 173    Format: Integer;
 174    FormatStr: String;
 175    Visible: WordBool;
 176    Memo, Script: TStringList;
 177    constructor Create; virtual;
 178    destructor Destroy; override;
 179    procedure Assign(From: TfrView); virtual;
 180    procedure CalcGaps; virtual;
 181    procedure RestoreCoord; virtual;
 182    procedure Draw(Canvas: TCanvas); virtual; abstract;
 183    procedure Print(Stream: TStream); virtual;
 184    procedure ExportData; virtual;
 185    procedure LoadFromStream(Stream: TStream); virtual;
 186    procedure SaveToStream(Stream: TStream); virtual;
 187    procedure SaveToFR3Stream(Stream: TStream); virtual;
 188    procedure Resized; virtual;
 189    procedure DefinePopupMenu(Popup: TPopupMenu); virtual;
 190    function GetClipRgn(rt: TfrRgnType): HRGN; virtual;
 191    procedure CreateUniqueName;
 192    procedure SetBounds(Left, Top, Width, Height: Integer);
 193  end;
 194
 195  TfrStretcheable = class(TfrView)
 196  protected
 197    ActualHeight: Integer;
 198    DrawMode: TfrDrawMode;
 199    function CalcHeight: Integer; virtual; abstract;
 200    function MinHeight: Integer; virtual; abstract;
 201    function RemainHeight: Integer; virtual; abstract;
 202  end;
 203
 204  TfrMemoView = class(TfrStretcheable)
 205  private
 206    FFont: TFont;
 207    procedure P1Click(Sender: TObject);
 208    procedure P2Click(Sender: TObject);
 209    procedure P3Click(Sender: TObject);
 210    procedure P4Click(Sender: TObject);
 211    procedure P5Click(Sender: TObject);
 212    procedure SetFont(Value: TFont);
 213  protected
 214    Streaming: Boolean;
 215    TextHeight: Integer;
 216    CurStrNo: Integer;
 217    Exporting: Boolean;
 218    procedure ExpandVariables;
 219    procedure AssignFont(Canvas: TCanvas);
 220    procedure WrapMemo;
 221    procedure ShowMemo;
 222    function CalcWidth(Memo: TStringList): Integer;
 223    function CalcHeight: Integer; override;
 224    function MinHeight: Integer; override;
 225    function RemainHeight: Integer; override;
 226    procedure GetBlob(b: TfrTField); override;
 227  public
 228    Adjust: Integer;
 229    Highlight: TfrHighlightAttr;
 230    HighlightStr: String;
 231    LineSpacing, CharacterSpacing: Integer;
 232    constructor Create; override;
 233    destructor Destroy; override;
 234    procedure Assign(From: TfrView); override;
 235    procedure Draw(Canvas: TCanvas); override;
 236    procedure Print(Stream: TStream); override;
 237    procedure ExportData; override;
 238    procedure LoadFromStream(Stream: TStream); override;
 239    procedure SaveToStream(Stream: TStream); override;
 240    procedure SaveToFR3Stream(Stream: TStream); override;
 241    procedure DefinePopupMenu(Popup: TPopupMenu); override;
 242    property Font: TFont read FFont write SetFont;
 243  end;
 244
 245  TfrBandView = class(TfrView)
 246  private
 247    procedure P1Click(Sender: TObject);
 248    procedure P2Click(Sender: TObject);
 249    procedure P3Click(Sender: TObject);
 250    procedure P4Click(Sender: TObject);
 251    procedure P5Click(Sender: TObject);
 252    procedure P6Click(Sender: TObject);
 253    function GetBandType: TfrBandType;
 254    procedure SetBandType(const Value: TfrBandType);
 255  public
 256    constructor Create; override;
 257    procedure Draw(Canvas: TCanvas); override;
 258    procedure DefinePopupMenu(Popup: TPopupMenu); override;
 259    function GetClipRgn(rt: TfrRgnType): HRGN; override;
 260    procedure SaveToFR3Stream(Stream: TStream); override;
 261    property BandType: TfrBandType read GetBandType write SetBandType;
 262    property DataSet: String read FormatStr write FormatStr;
 263    property GroupCondition: String read FormatStr write FormatStr;
 264  end;
 265
 266  TfrSubReportView = class(TfrView)
 267  public
 268    SubPage: Integer;
 269    constructor Create; override;
 270    procedure Assign(From: TfrView); override;
 271    procedure Draw(Canvas: TCanvas); override;
 272    procedure LoadFromStream(Stream: TStream); override;
 273    procedure SaveToStream(Stream: TStream); override;
 274    procedure SaveToFR3Stream(Stream: TStream); override;
 275    procedure DefinePopupMenu(Popup: TPopupMenu); override;
 276  end;
 277
 278  TfrPictureView = class(TfrView)
 279  private
 280    procedure P1Click(Sender: TObject);
 281    procedure P2Click(Sender: TObject);
 282  protected
 283    procedure GetBlob(b: TfrTField); override;
 284  public
 285    Picture: TPicture;
 286    constructor Create; override;
 287    destructor Destroy; override;
 288    procedure Assign(From: TfrView); override;
 289    procedure Draw(Canvas: TCanvas); override;
 290    procedure LoadFromStream(Stream: TStream); override;
 291    procedure SaveToStream(Stream: TStream); override;
 292    procedure SaveToFR3Stream(Stream: TStream); override;
 293    procedure DefinePopupMenu(Popup: TPopupMenu); override;
 294  end;
 295
 296  TfrLineView = class(TfrView)
 297  public
 298    constructor Create; override;
 299    procedure Draw(Canvas: TCanvas); override;
 300    procedure DefinePopupMenu(Popup: TPopupMenu); override;
 301    function GetClipRgn(rt: TfrRgnType): HRGN; override;
 302    procedure SaveToFR3Stream(Stream: TStream); override;
 303  end;
 304
 305  TfrBand = class(TObject)
 306  private
 307    Parent: TfrPage;
 308    View: TfrView;
 309    Flags: Word;
 310    Next, Prev: TfrBand;
 311    SubIndex, MaxY: Integer;
 312    EOFReached: Boolean;
 313    EOFArr: Array[0..31] of Boolean;
 314    Positions: Array[TfrDatasetPosition] of Integer;
 315    LastGroupValue: Variant;
 316    HeaderBand, FooterBand, LastBand: TfrBand;
 317    Values: TStringList;
 318    Count: Integer;
 319    DisableInit: Boolean;
 320    CalculatedHeight: Integer;
 321    procedure InitDataSet(Desc: String);
 322    procedure DoError;
 323    function CalcHeight: Integer;
 324    procedure StretchObjects(MaxHeight: Integer);
 325    procedure UnStretchObjects;
 326    procedure DrawObject(t: TfrView);
 327    procedure PrepareSubReports;
 328    procedure DoSubReports;
 329    function DrawObjects: Boolean;
 330    procedure DrawCrossCell(Parnt: TfrBand; CurX: Integer);
 331    procedure DrawCross;
 332    function CheckPageBreak(y, dy: Integer; PBreak: Boolean): Boolean;
 333    procedure DrawPageBreak;
 334    function HasCross: Boolean;
 335    function DoCalcHeight: Integer;
 336    procedure DoDraw;
 337    function Draw: Boolean;
 338    procedure InitValues;
 339    procedure DoAggregate;
 340  public
 341    x, y, dx, dy, maxdy: Integer;
 342    Typ: TfrBandType;
 343    PrintIfSubsetEmpty, NewPageAfter, Stretched, PageBreak, Visible: Boolean;
 344    Objects: TList;
 345    Memo, Script: TStringList;
 346    DataSet: TfrDataSet;
 347    IsVirtualDS: Boolean;
 348    VCDataSet: TfrDataSet;
 349    IsVirtualVCDS: Boolean;
 350    GroupCondition: String;
 351    ForceNewPage, ForceNewColumn: Boolean;
 352    constructor Create(ATyp: TfrBandType; AParent: TfrPage);
 353    destructor Destroy; override;
 354  end;
 355
 356  TfrValue = class
 357  public
 358    Typ: TfrValueType;
 359    OtherKind: Integer;   // for vtOther - typ, for vtDBField - format
 360    DataSet: String;      // for vtDBField
 361    Field: String;        // here is an expression for vtOther
 362    DSet: TfrTDataSet;
 363  end;
 364
 365  TfrValues = class(TPersistent)
 366  private
 367    FItems: TStringList;
 368    function GetValue(Index: Integer): TfrValue;
 369  public
 370    constructor Create; virtual;
 371    destructor Destroy; override;
 372    function AddValue: Integer;
 373    function FindVariable(const s: String): TfrValue;
 374    procedure ReadBinaryData(Stream: TStream);
 375    procedure WriteBinaryData(Stream: TStream);
 376    procedure Clear;
 377    property Items: TStringList read FItems write FItems;
 378    property Objects[Index: Integer]: TfrValue read GetValue;
 379  end;
 380
 381  TfrPage = class(TObject)
 382  private
 383    Bands: Array[TfrBandType] of TfrBand;
 384    Skip, InitFlag: Boolean;
 385    CurColumn, LastStaticColumnY, XAdjust: Integer;
 386    List: TList;
 387    Mode: TfrPageMode;
 388    PlayFrom: Integer;
 389    LastBand: TfrBand;
 390    ColPos, CurPos: Integer;
 391    procedure InitReport;
 392    procedure DoneReport;
 393    procedure TossObjects;
 394    procedure PrepareObjects;
 395    procedure FormPage;
 396    procedure DoAggregate(a: Array of TfrBandType);
 397    procedure AddRecord(b: TfrBand; rt: TfrBandRecType);
 398    procedure ClearRecList;
 399    function PlayRecList: Boolean;
 400    procedure DrawPageFooters;
 401    function BandExists(b: TfrBand): Boolean;
 402    procedure AfterPrint;
 403    procedure LoadFromStream(Stream: TStream);
 404    procedure SaveToStream(Stream: TStream);
 405    procedure ShowBand(b: TfrBand);
 406  public
 407    pgSize, pgWidth, pgHeight: Integer;
 408    pgMargins: TRect;
 409    pgOr: TPrinterOrientation;
 410    PrintToPrevPage, UseMargins: WordBool;
 411    PrnInfo: TfrPrnInfo;
 412    ColCount, ColWidth, ColGap: Integer;
 413    Objects, RTObjects: TList;
 414    CurY, CurBottomY: Integer;
 415    constructor Create(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation);
 416    destructor Destroy; override;
 417    function TopMargin: Integer;
 418    function BottomMargin: Integer;
 419    function LeftMargin: Integer;
 420    function RightMargin: Integer;
 421    procedure Clear;
 422    procedure Delete(Index: Integer);
 423    function FindObjectByID(ID: Integer): Integer;
 424    function FindObject(Name: String): TfrView;
 425    function FindRTObject(Name: String): TfrView;
 426    procedure ChangePaper(ASize, AWidth, AHeight: Integer; AOr: TPrinterOrientation);
 427    procedure ShowBandByName(s: String);
 428    procedure ShowBandByType(bt: TfrBandType);
 429    procedure NewPage;
 430    procedure NewColumn(Band: TfrBand);
 431  end;
 432
 433  TfrPages = class(TObject)
 434  private
 435    FPages: TList;
 436    Parent: TfrReport;
 437    function GetCount: Integer;
 438    function GetPages(Index: Integer): TfrPage;
 439  public
 440    constructor Create(AParent: TfrReport);
 441    destructor Destroy; override;
 442    procedure Clear;
 443    procedure Add;
 444    procedure Delete(Index: Integer);
 445    procedure LoadFromStream(Stream: TStream);
 446    procedure SaveToStream(Stream: TStream);
 447    property Pages[Index: Integer]: TfrPage read GetPages; default;
 448    property Count: Integer read GetCount;
 449  end;
 450
 451  TfrEMFPages = class(TObject)
 452  private
 453    FPages: TList;
 454    Parent: TfrReport;
 455    function GetCount: Integer;
 456    function GetPages(Index: Integer): PfrPageInfo;
 457    procedure ExportData(Index: Integer);
 458    procedure PageToObjects(Index: Integer);
 459    procedure ObjectsToPage(Index: Integer);
 460  public
 461    constructor Create(AParent: TfrReport);
 462    destructor Destroy; override;
 463    procedure Clear;
 464    procedure Draw(Index: Integer; Canvas: TCanvas; DrawRect: TRect);
 465    procedure Add(APage: TfrPage);
 466    procedure Insert(Index: Integer; APage: TfrPage);
 467    procedure Delete(Index: Integer);
 468    procedure LoadFromStream(AStream: TStream);
 469    procedure SaveToStream(AStream: TStream);
 470    property Pages[Index: Integer]: PfrPageInfo read GetPages; default;
 471    property Count: Integer read GetCount;
 472  end;
 473
 474  TfrReport = class(TComponent)
 475  private
 476    FPages: TfrPages;
 477    FEMFPages: TfrEMFPages;
 478    FVars: TStrings;
 479    FVal: TfrValues;
 480    FDataset: TfrDataset;
 481    FGrayedButtons: Boolean;
 482    FReportType: TfrReportType;
 483    FTitle: String;
 484    FShowProgress: Boolean;
 485    FModalPreview: Boolean;
 486    FModifyPrepared: Boolean;
 487    FStoreInDFM: Boolean;
 488    FPreview: TfrPreview;
 489    FPreviewButtons: TfrPreviewButtons;
 490    FInitialZoom: TfrPreviewZoom;
 491    FOnBeginDoc: TBeginDocEvent;
 492    FOnEndDoc: TEndDocEvent;
 493    FOnBeginPage: TBeginPageEvent;
 494    FOnEndPage: TEndPageEvent;
 495    FOnBeginBand: TBeginBandEvent;
 496    FOnEndBand: TEndBandEvent;
 497    FOnGetValue: TDetailEvent;
 498    FOnEnterRect: TEnterRectEvent;
 499    FOnProgress: TProgressEvent;
 500    FOnFunction: TFunctionEvent;
 501    FOnBeginColumn: TBeginColumnEvent;
 502    FOnPrintColumn: TPrintColumnEvent;
 503    FOnManualBuild: TManualBuildEvent;
 504    FCurrentFilter: TfrExportFilter;
 505    FPageNumbers: String;
 506    FCopies: Integer;
 507    FCurPage: TfrPage;
 508    function FormatValue(V: Variant; Format: Integer;
 509      const FormatStr: String): String;
 510    procedure OnGetParsFunction(const name: String; p1, p2, p3: Variant;
 511                                var val: String);
 512    procedure PrepareDataSets;
 513    procedure BuildBeforeModal(Sender: TObject);
 514    procedure ExportBeforeModal(Sender: TObject);
 515    procedure PrintBeforeModal(Sender: TObject);
 516    function DoPrepareReport: Boolean;
 517    procedure DoBuildReport; virtual;
 518    procedure DoPrintReport(PageNumbers: String; Copies: Integer);
 519    procedure SetPrinterTo(PrnName: String);
 520    procedure SetVars(Value: TStrings);
 521  protected
 522    procedure DefineProperties(Filer: TFiler); override;
 523    procedure ReadBinaryData(Stream: TStream);
 524    procedure WriteBinaryData(Stream: TStream);
 525    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
 526  public
 527    CanRebuild: Boolean;            // true, if report can be rebuilded
 528    Terminated: Boolean;
 529    PrintToDefault, DoublePass: WordBool;
 530    FinalPass: Boolean;
 531    FileName: String;
 532    FR3Stream: Boolean;
 533    constructor Create(AOwner: TComponent); override;
 534    destructor Destroy; override;
 535    // service methods
 536    function FindVariable(Variable: String): Integer;
 537    procedure GetVariableValue(const s: String; var v: Variant);
 538    procedure GetVarList(CatNo: Integer; List: TStrings);
 539    procedure GetCategoryList(List: TStrings);
 540    function FindObject(Name: String): TfrView;
 541    // internal events used through report building
 542    procedure InternalOnEnterRect(Memo: TStringList; View: TfrView);
 543    procedure InternalOnExportData(View: TfrView);
 544    procedure InternalOnExportText(x, y: Integer; const text: String; View: TfrView);
 545    procedure InternalOnGetValue(ParName: String; var ParValue: String);
 546    procedure InternalOnProgress(Percent: Integer);
 547    procedure InternalOnBeginColumn(Band: TfrBand);
 548    procedure InternalOnPrintColumn(ColNo: Integer; var ColWidth: Integer);
 549    procedure FillQueryParams;
 550    // load/save methods
 551    procedure LoadFromStream(Stream: TStream);
 552    procedure SaveToStream(Stream: TStream);
 553    procedure LoadFromFile(FName: String);
 554    procedure SaveToFile(FName: String);
 555    procedure SaveToFR3File(FName: String);
 556{$IFDEF IBO}
 557    procedure LoadFromDB(Table: TIB_DataSet; DocN: Integer);
 558    procedure SaveToDB(Table: TIB_DataSet; DocN: Integer);
 559{$ELSE}
 560    procedure LoadFromDB(Table: TDataSet; DocN: Integer);
 561    procedure SaveToDB(Table: TDataSet; DocN: Integer);
 562{$ENDIF}
 563    procedure LoadTemplate(fname: String; comm: TStrings;
 564      Bmp: TBitmap; Load: Boolean);
 565    procedure SaveTemplate(fname: String; comm: TStrings; Bmp: TBitmap);
 566    procedure LoadPreparedReport(FName: String);
 567    procedure SavePreparedReport(FName: String);
 568    // report manipulation methods
 569    procedure DesignReport;
 570    function PrepareReport: Boolean;
 571    procedure ExportTo(Filter: TClass; FileName: String);
 572    procedure ShowReport;
 573    procedure ShowPreparedReport;
 574    procedure PrintPreparedReport(PageNumbers: String; Copies: Integer);
 575    function ChangePrinter(OldIndex, NewIndex: Integer): Boolean;
 576    procedure EditPreparedReport(PageIndex: Integer);
 577    //
 578    property Pages: TfrPages read FPages;
 579    property EMFPages: TfrEMFPages read FEMFPages write FEMFPages;
 580    property Variables: TStrings read FVars write SetVars;
 581    property Values: TfrValues read FVal write FVal;
 582  published
 583    property Dataset: TfrDataset read FDataset write FDataset;
 584    property GrayedButtons: Boolean read FGrayedButtons write FGrayedButtons default False;
 585    property InitialZoom: TfrPreviewZoom read FInitialZoom write FInitialZoom;
 586    property ModalPreview: Boolean read FModalPreview write FModalPreview default True;
 587    property ModifyPrepared: Boolean read FModifyPrepared write FModifyPrepared default True;
 588    property Preview: TfrPreview read FPreview write FPreview;
 589    property PreviewButtons: TfrPreviewButtons read FPreviewButtons write FPreviewButtons;
 590    property ReportType: TfrReportType read FReportType write FReportType default rtSimple;
 591    property ShowProgress: Boolean read FShowProgress write FShowProgress default True;
 592    property StoreInDFM: Boolean read FStoreInDFM write FStoreInDFM default False;
 593    property Title: String read FTitle write FTitle;
 594    property OnBeginDoc: TBeginDocEvent read FOnBeginDoc write FOnBeginDoc;
 595    property OnEndDoc: TEndDocEvent read FOnEndDoc write FOnEndDoc;
 596    property OnBeginPage: TBeginPageEvent read FOnBeginPage write FOnBeginPage;
 597    property OnEndPage: TEndPageEvent read FOnEndPage write FOnEndPage;
 598    property OnBeginBand: TBeginBandEvent read FOnBeginBand write FOnBeginBand;
 599    property OnEndBand: TEndBandEvent read FOnEndBand write FOnEndBand;
 600    property OnGetValue: TDetailEvent read FOnGetValue write FOnGetValue;
 601    property OnEnterRect: TEnterRectEvent read FOnEnterRect write FOnEnterRect;
 602    property OnUserFunction: TFunctionEvent read FOnFunction write FOnFunction;
 603    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
 604    property OnBeginColumn: TBeginColumnEvent read FOnBeginColumn write FOnBeginColumn;
 605    property OnPrintColumn: TPrintColumnEvent read FOnPrintColumn write FOnPrintColumn;
 606    property OnManualBuild: TManualBuildEvent read FOnManualBuild write FOnManualBuild;
 607  end;
 608
 609  TfrCompositeReport = class(TfrReport)
 610  private
 611    procedure DoBuildReport; override;
 612  public
 613    Reports: TList;
 614    constructor Create(AOwner: TComponent); override;
 615    destructor Destroy; override;
 616  end;
 617
 618  TfrReportDesigner = class(TForm)
 619  public
 620    Page: TfrPage;
 621    Modified: Boolean;
 622    procedure RegisterObject(ButtonBmp: TBitmap; const ButtonHint: String;
 623      ButtonTag: Integer); virtual; abstract;
 624    procedure RegisterTool(MenuCaption: String; ButtonBmp: TBitmap;
 625      OnClick: TNotifyEvent); virtual; abstract;
 626    procedure BeforeChange; virtual; abstract;
 627    procedure AfterChange; virtual; abstract;
 628    procedure RedrawPage; virtual; abstract;
 629  end;
 630
 631  TfrDataManager = class(TObject)
 632  public
 633    procedure LoadFromStream(Stream: TStream); virtual; abstract;
 634    procedure SaveToStream(Stream: TStream); virtual; abstract;
 635    procedure BeforePreparing; virtual; abstract;
 636    procedure AfterPreparing; virtual; abstract;
 637    procedure PrepareDataSet(ds: TfrTDataSet); virtual; abstract;
 638    function ShowParamsDialog: Boolean; virtual; abstract;
 639    procedure AfterParamsDialog; virtual; abstract;
 640  end;
 641
 642  TfrObjEditorForm = class(TForm)
 643  public
 644    procedure ShowEditor(t: TfrView); virtual;
 645  end;
 646
 647  TfrExportFilter = class(TObject)
 648  protected
 649    Stream: TStream;
 650    Lines: TList;
 651    procedure ClearLines;
 652  public
 653    constructor Create(AStream: TStream); virtual;
 654    destructor Destroy; override;
 655    procedure OnBeginDoc; virtual;
 656    procedure OnEndDoc; virtual;
 657    procedure OnBeginPage; virtual;
 658    procedure OnEndPage; virtual;
 659    procedure OnData(x, y: Integer; View: TfrView); virtual;
 660    procedure OnText(x, y: Integer; const text: String; View: TfrView); virtual;
 661  end;
 662
 663  TfrFunctionLibrary = class(TObject)
 664  public
 665    List: TStringList;
 666    constructor Create; virtual;
 667    destructor Destroy; override;
 668    function OnFunction(const FName: String; p1, p2, p3: Variant;
 669      var val: String): Boolean;
 670    procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: String);
 671      virtual; abstract;
 672  end;
 673
 674  TfrCompressor = class(TObject)
 675  public
 676    Enabled: Boolean;
 677    procedure Compress(StreamIn, StreamOut: TStream); virtual;
 678    procedure DeCompress(StreamIn, StreamOut: TStream); virtual;
 679  end;
 680
 681
 682function frCreateObject(Typ: Byte; const ClassName: String): TfrView;
 683procedure frRegisterObject(ClassRef: TClass; ButtonBmp: TBitmap;
 684  const ButtonHint: String; EditorForm: TfrObjEditorForm);
 685procedure frRegisterExportFilter(ClassRef: TClass;
 686  const FilterDesc, FilterExt: String);
 687procedure frRegisterFunctionLibrary(ClassRef: TClass);
 688procedure frRegisterTool(MenuCaption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent);
 689function GetDefaultDataSet: TfrTDataSet;
 690
 691
 692const
 693  frCurrentVersion = 23; // this is current version (2.3)
 694  frSpecCount = 9;
 695  frSpecFuncs: Array[0..frSpecCount - 1] of String = ('PAGE#', '',
 696    'DATE', 'TIME', 'LINE#', 'LINETHROUGH#', 'COLUMN#', 'CURRENT#', 'TOTALPAGES');
 697  frColors: Array[0..15] of TColor =
 698    (clWhite, clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal,
 699     clGray, clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua);
 700
 701type
 702  PfrTextRec = ^TfrTextRec;
 703  TfrTextRec = record
 704    Next: PfrTextRec;
 705    X: Integer;
 706    Text: String[255];
 707    FontName: String[32];
 708    FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer;
 709  end;
 710
 711  TfrAddInObjectInfo = record
 712    ClassRef: TClass;
 713    EditorForm: TfrObjEditorForm;
 714    ButtonBmp: TBitmap;
 715    ButtonHint: String;
 716  end;
 717
 718  TfrExportFilterInfo = record
 719    ClassRef: TClass;
 720    FilterDesc, FilterExt: String;
 721  end;
 722
 723  TfrFunctionInfo = record
 724    FunctionLibrary: TfrFunctionLibrary;
 725  end;
 726
 727  TfrToolsInfo = record
 728    Caption: String;
 729    ButtonBmp: TBitmap;
 730    OnClick: TNotifyEvent;
 731  end;
 732
 733var
 734  frDesigner: TfrReportDesigner;                  // designer reference
 735  frDataManager: TfrDataManager;                  // data manager reference
 736  frParser: TfrParser;                            // parser reference
 737  frInterpretator: TfrInterpretator;              // interpretator reference
 738  frVariables: TfrVariables;                      // report variables reference
 739  frCompressor: TfrCompressor;                    // compressor reference
 740  CurReport: TfrReport;                           // currently proceeded report
 741  MasterReport: TfrReport;               // reference to main composite report
 742  CurView: TfrView;                               // currently proceeded view
 743  CurBand: TfrBand;                               // currently proceeded band
 744  CurPage: TfrPage;                               // currently proceeded page
 745  DocMode: (dmDesigning, dmPrinting);             // current mode
 746  DisableDrawing: Boolean;
 747  frAddIns: Array[0..31] of TfrAddInObjectInfo;   // add-in objects
 748  frAddInsCount: Integer;
 749  frFilters: Array[0..31] of TfrExportFilterInfo; // export filters
 750  frFiltersCount: Integer;
 751  frFunctions: Array[0..31] of TfrFunctionInfo;   // function libraries
 752  frFunctionsCount: Integer;
 753  frTools: Array[0..31] of TfrToolsInfo;          // tools
 754  frToolsCount: Integer;
 755  PageNo: Integer;                       // current page number in Building mode
 756  frCharset: 0..255;
 757  frBandNames: Array[0..21] of String;
 758  frSpecArr: Array[0..frSpecCount - 1] of String;
 759  frDateFormats, frTimeFormats: Array[0..3] of String;
 760  frVersion: Byte;                       // version of currently loaded report
 761  SMemo: TStringList;          // temporary memo used during TfrView drawing
 762  ShowBandTitles: Boolean = True;
 763(*
 764  FRE_COMPATIBLEREAD variable added for migrating from older versions 
 765  of FreeReport and will be removed in next releases as soon as possible.
 766*)
 767{$IFDEF FREEREP2217READ}
 768  FRE_COMPATIBLE_READ: Boolean = False;
 769{$ENDIF}
 770
 771implementation
 772
 773uses
 774  FR_Fmted, FR_Prntr, FR_Progr, FR_Utils, FR_Const
 775  {$IFDEF JPEG}, JPEG {$ENDIF};
 776
 777{$R FR_Lng1.RES}
 778
 779type
 780  TfrStdFunctionLibrary = class(TfrFunctionLibrary)
 781  public
 782    constructor Create; override;
 783    procedure DoFunction(FNo: Integer; p1, p2, p3: Variant; var val: String); override;
 784  end;
 785
 786  TInterpretator = class(TfrInterpretator)
 787  public
 788    procedure GetValue(const Name: String; var Value: Variant); override;
 789    procedure SetValue(const Name: String; Value: Variant); override;
 790    procedure DoFunction(const name: String; p1, p2, p3: Variant;
 791                         var val: String); override;
 792  end;
 793
 794
 795var
 796  VHeight: Integer;            // used for height calculation of TfrMemoView
 797  SBmp: TBitmap;               // small bitmap used by TfrBandView drawing
 798  TempBmp: TBitmap;            // temporary bitmap used by TfrMemoView
 799  CurDate, CurTime: TDateTime; // date/time of report starting
 800  CurValue: Variant;           // used for highlighting
 801  AggrBand: TfrBand;           // used for aggregate functions
 802  CurVariable: String;
 803  IsColumns: Boolean;
 804  SavedAllPages: Integer;      // number of pages in entire report
 805  ErrorFlag: Boolean;          // error occured through TfrView drawing
 806  ErrorStr: String;            // error description
 807  SubValue: String;            // used in GetValue event handler
 808  ObjID: Integer = 0;
 809  BoolStr: Array[0..3] of String;
 810  HookList: TList;
 811
 812  // variables used through report building
 813  PrevY, PrevBottomY, ColumnXAdjust: Integer;
 814  Append, WasPF: Boolean;
 815  CompositeMode: Boolean;
 816
 817{----------------------------------------------------------------------------}
 818function frCreateObject(Typ: Byte; const ClassName: String): TfrView;
 819var
 820  i: Integer;
 821begin
 822  Result := nil;
 823  case Typ of
 824    gtMemo:      Result := TfrMemoView.Create;
 825    gtPicture:   Result := TfrPictureView.Create;
 826    gtBand:      Result := TfrBandView.Create;
 827    gtSubReport: Result := TfrSubReportView.Create;
 828    gtLine:      Result := TfrLineView.Create;
 829    gtAddIn:
 830      begin
 831        for i := 0 to frAddInsCount - 1 do
 832          if frAddIns[i].ClassRef.ClassName = ClassName then
 833          begin
 834            Result := TfrView(frAddIns[i].ClassRef.NewInstance);
 835            Result.Create;
 836            Result.Typ := gtAddIn;
 837            break;
 838          end;
 839        if Result = nil then
 840          raise EClassNotFound.Create('�� ������ ����� ' + ClassName);
 841      end;
 842  end;
 843  if Result <> nil then
 844  begin
 845    Result.ID := ObjID;
 846    Inc(ObjID);
 847  end;
 848end;
 849
 850procedure frRegisterObject(ClassRef: TClass; ButtonBmp: TBitmap;
 851  const ButtonHint: String; EditorForm: TfrObjEditorForm);
 852begin
 853  frAddIns[frAddInsCount].ClassRef := ClassRef;
 854  frAddIns[frAddInsCount].EditorForm := EditorForm;
 855  frAddIns[frAddInsCount].ButtonBmp := ButtonBmp;
 856  frAddIns[frAddInsCount].ButtonHint := ButtonHint;
 857  if frDesigner <> nil then
 858    frDesigner.RegisterObject(ButtonBmp, ButtonHint,
 859      Integer(gtAddIn) + frAddInsCount);
 860  Inc(frAddInsCount);
 861end;
 862
 863procedure frRegisterExportFilter(ClassRef: TClass;
 864  const FilterDesc, FilterExt: String);
 865begin
 866  frFilters[frFiltersCount].ClassRef := ClassRef;
 867  frFilters[frFiltersCount].FilterDesc := FilterDesc;
 868  frFilters[frFiltersCount].FilterExt := FilterExt;
 869  Inc(frFiltersCount);
 870end;
 871
 872procedure frRegisterFunctionLibrary(ClassRef: TClass);
 873begin
 874  frFunctions[frFunctionsCount].FunctionLibrary :=
 875    TfrFunctionLibrary(ClassRef.NewInstance);
 876  frFunctions[frFunctionsCount].FunctionLibrary.Create;
 877  Inc(frFunctionsCount);
 878end;
 879
 880procedure frRegisterTool(MenuCaption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent);
 881begin
 882  frTools[frToolsCount].Caption := MenuCaption;
 883  frTools[frToolsCount].ButtonBmp := ButtonBmp;
 884  frTools[frToolsCount].OnClick := OnClick;
 885  if frDesigner <> nil then
 886    frDesigner.RegisterTool(MenuCaption, ButtonBmp, OnClick);
 887  Inc(frToolsCount);
 888end;
 889
 890function Create90Font(Font: TFont): HFont;
 891var
 892  F: TLogFont;
 893begin
 894  GetObject(Font.Handle, SizeOf(TLogFont), @F);
 895  F.lfEscapement := 900;
 896  F.lfOrientation := 900;
 897  Result := CreateFontIndirect(F);
 898end;
 899
 900function GetDefaultDataSet: TfrTDataSet;
 901var
 902  Res: TfrDataset;
 903begin
 904  Result := nil; Res := nil;
 905  if CurBand <> nil then
 906    case CurBand.Typ of
 907      btMasterData, btReportSummary, btMasterFooter,
 908      btGroupHeader, btGroupFooter:
 909        Res := CurPage.Bands[btMasterData].DataSet;
 910      btDetailData, btDetailFooter:
 911        Res := CurPage.Bands[btDetailData].DataSet;
 912      btSubDetailData, btSubDetailFooter:
 913        Res := CurPage.Bands[btSubDetailData].DataSet;
 914      btCrossData, btCrossFooter:
 915        Res := CurPage.Bands[btCrossData].DataSet;
 916    end;
 917  if (Res <> nil) and (Res is TfrDBDataset) then
 918    Result := TfrDBDataSet(Res).GetDataSet;
 919end;
 920
 921function ReadString(Stream: TStream): String;
 922begin
 923  if frVersion >= 23 then
 924{$IFDEF FREEREP2217READ}
 925      Result := frReadString(Stream) // load in current format
 926  else
 927    if (frVersion = 22) and FRE_COMPATIBLE_READ then
 928      Result := frReadString2217(Stream) // load in bad format
 929    else
 930{$ELSE}
 931    Result := frReadString(Stream) else
 932{$ENDIF}
 933    Result := frReadString22(Stream);
 934end;
 935
 936procedure ReadMemo(Stream: TStream; Memo: TStrings);
 937begin
 938  if frVersion >= 23 then
 939{$IFDEF FREEREP2217READ}
 940      frReadMemo(Stream, Memo) // load in current format
 941  else
 942    if (frVersion = 22) and FRE_COMPATIBLE_READ then
 943      Memo.Text := frReadString2217(Stream) // load in bad format
 944    else
 945{$ELSE}
 946    frReadMemo(Stream, Memo) else
 947{$ENDIF}
 948    frReadMemo22(Stream, Memo);
 949end;
 950
 951procedure CreateDS(Desc: String; var DataSet: TfrDataSet; var IsVirtualDS: Boolean);
 952begin
 953  if (Desc <> '') and (Desc[1] in ['1'..'9']) then
 954  begin
 955    DataSet := TfrUserDataSet.Create(nil);
 956    DataSet.RangeEnd := reCount;
 957    DataSet.RangeEndCount := StrToInt(Desc);
 958    IsVirtualDS := True;
 959  end
 960  else
 961    DataSet := frFindComponent(CurReport.Owner, Desc) as TfrDataSet;
 962  if DataSet <> nil then
 963    DataSet.Init;
 964end;
 965
 966{----------------------------------------------------------------------------}
 967constructor TfrView.Create;
 968begin
 969  inherited Create;
 970  Parent := nil;
 971  Memo := TStringList.Create;
 972  Memo1 := TStringList.Create;
 973  Script := TStringList.Create;
 974  FrameWidth := 1;
 975  FrameColor := clBlack;
 976  FillColor := clNone;
 977  Format := 2*256 + Ord(DecimalSeparator);
 978  BaseName := 'View';
 979  Visible := True;
 980  StreamMode := smDesigning;
 981  ScaleX := 1; ScaleY := 1;
 982  OffsX := 0; OffsY := 0;
 983  Flags := flStretched;
 984end;
 985
 986destructor TfrView.Destroy;
 987begin
 988  Memo.Free;
 989  Memo1.Free;
 990  Script.Free;
 991  inherited Destroy;
 992end;
 993
 994procedure TfrView.Assign(From: TfrView);
 995begin
 996  Name := From.Name;
 997  Typ := From.Typ;
 998  Selected := From.Selected;
 999  x := From.x; y := From.y; dx := From.dx; dy := From.dy;
1000  Flags := From.Flags;
1001  FrameTyp := From.FrameTyp;
1002  FrameWidth := From.FrameWidth;
1003  FrameColor := From.FrameColor;
1004  FrameStyle := From.FrameStyle;
1005  FillColor := From.FillColor;
1006  Format := From.Format;
1007  FormatStr := From.FormatStr;
1008  Visible := From.Visible;
1009  Memo.Assign(From.Memo);
1010  Script.Assign(From.Script);
1011end;
1012
1013procedure TfrView.CalcGaps;
1014var
1015  bx, by, bx1, by1, wx1, wx2, wy1, wy2: Integer;
1016begin
1017  SaveX := x; SaveY := y; SaveDX := dx; SaveDY := dy;
1018  SaveFW := FrameWidth;
1019  if DocMode = dmDesigning then
1020  begin
1021    ScaleX := 1; ScaleY := 1;
1022    OffsX := 0; OffsY := 0;
1023  end;
1024  x := Round(x * ScaleX) + OffsX;
1025  y := Round(y * ScaleY) + OffsY;
1026  dx := Round(dx * ScaleX);
1027  dy := Round(dy * ScaleY);
1028
1029  wx1 := Round((FrameWidth * ScaleX - 1) / 2);
1030  wx2 := Round(FrameWidth * ScaleX / 2);
1031  wy1 := Round((FrameWidth * ScaleY - 1) / 2);
1032  wy2 := Round(FrameWidth * ScaleY / 2);
1033  FrameWidth := FrameWidth * ScaleX;
1034  gapx := wx2 + 2; gapy := wy2 div 2 + 1;
1035  bx := x;
1036  by := y;
1037  bx1 := Round((SaveX + SaveDX) * ScaleX + OffsX);
1038  by1 := Round((SaveY + SaveDY) * ScaleY + OffsY);
1039  if (FrameTyp and $1) <> 0 then Dec(bx1, wx2);
1040  if (FrameTyp and $2) <> 0 then Dec(by1, wy2);
1041  if (FrameTyp and $4) <> 0 then Inc(bx, wx1);
1042  if (FrameTyp and $8) <> 0 then Inc(by, wy1);
1043  DRect := Rect(bx, by, bx1 + 1, by1 + 1);
1044end;
1045
1046procedure TfrView.RestoreCoord;
1047begin
1048  x := SaveX;
1049  y := SaveY;
1050  dx := SaveDX;
1051  dy := SaveDY;
1052  FrameWidth := SaveFW;
1053end;
1054
1055procedure TfrView.ShowBackground;
1056var
1057  fp: TColor;
1058begin
1059  if DisableDrawing then Exit;
1060  if (DocMode = dmPrinting) and (FillColor = clNone) then Exit;
1061  fp := FillColor;
1062  if (DocMode = dmDesigning) and (fp = clNone) then
1063    fp := clWhite;
1064  Canvas.Brush.Color := fp;
1065  if DocMode = dmDesigning then
1066    Canvas.FillRect(DRect) else
1067    Canvas.FillRect(Rect(x, y,
1068// use calculating coords instead of dx, dy - for best view
1069      Round((SaveX + SaveDX) * ScaleX + OffsX), Round((SaveY + SaveDY) * ScaleY + OffsY)));
1070end;
1071
1072procedure TfrView.ShowFrame;
1073var
1074  x1, y1: Integer;
1075  procedure Line(x, y, dx, dy: Integer);
1076  begin
1077    Canvas.MoveTo(x, y);
1078    Canvas.LineTo(x + dx, y + dy);
1079  end;
1080  procedure Line1(x, y, x1, y1: Integer);
1081  var
1082    i, w: Integer;
1083  begin
1084    if Canvas.Pen.Style = psSolid then
1085    begin
1086      if FrameStyle <> 5 then
1087      begin
1088        Canvas.MoveTo(x, y);
1089        Canvas.LineTo(x1, y1);
1090      end
1091      else
1092      begin
1093        if x = x1 then
1094        begin
1095          Canvas.MoveTo(x - Round(FrameWidth), y);
1096          Canvas.LineTo(x1 - Round(FrameWidth), y1);
1097          Canvas.Pen.Color := FillColor;
1098          Canvas.MoveTo(x, y);
1099          Canvas.LineTo(x1, y1);
1100          Canvas.Pen.Color := FrameColor;
1101          Canvas.MoveTo(x + Round(FrameWidth), y);
1102          Canvas.LineTo(x1 + Round(FrameWidth), y1);
1103        end
1104        else
1105        begin
1106          Canvas.MoveTo(x, y - Round(FrameWidth));
1107          Canvas.LineTo(x1, y1 - Round(FrameWidth));
1108          Canvas.Pen.Color := FillColor;
1109          Canvas.MoveTo(x, y);
1110          Canvas.LineTo(x1, y1);
1111          Canvas.Pen.Color := FrameColor;
1112          Canvas.MoveTo(x, y + Round(FrameWidth));
1113          Canvas.LineTo(x1, y1 + Round(FrameWidth));
1114        end;
1115      end
1116    end
1117    else
1118    begin
1119      Canvas.Brush.Color := FillColor;
1120      w := Canvas.Pen.Width;
1121      Canvas.Pen.Width := 1;
1122      if x = x1 then
1123        for i := 0 to w - 1 do
1124        begin
1125          Canvas.MoveTo(x - w div 2 + i, y);
1126          Canvas.LineTo(x - w div 2 + i, y1);
1127        end
1128      else
1129        for i := 0 to w - 1 do
1130        begin
1131          Canvas.MoveTo(x, y - w div 2 + i);
1132          Canvas.LineTo(x1, y - w div 2 + i);
1133        end;
1134      Canvas.Pen.Width := w;
1135    end;
1136  end;
1137begin
1138  if DisableDrawing then Exit;
1139  if (DocMode = dmPrinting) and ((FrameTyp and $F) = 0) then Exit;
1140  with Canvas do
1141  begin
1142    Brush.Style := bsClear;
1143    Pen.Style := psSolid;
1144    if (dx > 0) and (dy > 0) and (DocMode = dmDesigning) then
1145    begin
1146      Pen.Color := clBlack;
1147      Pen.Width := 1;
1148      Line(x, y + 3, 0, -3); Line(x, y, 4, 0);
1149      Line(x, y + dy - 3, 0, 3); Line(x, y + dy, 4, 0);
1150      Line(x + dx - 3, y, 3, 0); Line(x + dx, y, 0, 4);
1151      Line(x + dx - 3, y + dy, 3, 0); Line(x + dx, y + dy, 0, -4);
1152    end;
1153    Pen.Color := FrameColor;
1154    Pen.Width := Round(FrameWidth);
1155    if FrameStyle <> 5 then
1156      Pen.Style := TPenStyle(FrameStyle);
1157// use calculating coords instead of dx, dy - for best view
1158    x1 := Round((SaveX + SaveDX) * ScaleX + OffsX);
1159    y1 := Round((SaveY + SaveDY) * ScaleY + OffsY);
1160    if ((FrameTyp and $F) = $F) and (FrameStyle = 0) then
1161      Rectangle(x, y, x1 + 1, y1 + 1)
1162    else
1163    begin
1164      if (FrameTyp and $1) <> 0 then Line1(x1, y, x1, y1);
1165      if (FrameTyp and $4) <> 0 then Line1(x, y, x, y1);
1166      if (FrameTyp and $2) <> 0 then Line1(x, y1, x1, y1);
1167      if (FrameTyp and $8) <> 0 then Line1(x, y, x1, y);
1168    end;
1169  end;
1170end;
1171
1172procedure TfrView.BeginDraw(ACanvas: TCanvas);
1173begin
1174  Canvas := ACanvas;
1175  CurView := Self;
1176end;
1177
1178procedure TfrView.Print(Stream: TStream);
1179begin
1180  BeginDraw(Canvas);
1181  Memo1.Assign(Memo);
1182  CurReport.InternalOnEnterRect(Memo1, Self);
1183  frInterpretator.DoScript(Script);
1184  if not Visible then Exit;
1185
1186  Stream.Write(Typ, 1);
1187  if Typ = gtAddIn then
1188    frWriteString(Stream, ClassName);
1189  SaveToStream(Stream);
1190end;
1191
1192procedure TfrView.ExportData;
1193begin
1194  CurReport.InternalOnExportData(Self);
1195end;
1196
1197procedure TfrView.LoadFromStream(Stream: TStream);
1198var
1199  w: Integer;
1200begin
1201  with Stream do
1202  begin
1203    if StreamMode = smDesigning then
1204      if frVersion >= 23 then
1205        Name := ReadString(Stream) else
1206        CreateUniqueName;
1207    Read(x, 30); // this is equal to, but much faster:
1208{    Read(x, 4); Read(y, 4); Read(dx, 4); Read(dy, 4);
1209    Read(Flags, 2);
1210    Read(FrameTyp, 2);
1211    Read(FrameWidth, 4);
1212    Read(FrameColor, 4);
1213    Read(FrameStyle, 2);}
1214    Read(FillColor, 4);
1215    if StreamMode = smDesigning then
1216    begin
1217      Read(Format, 4);
1218      FormatStr := ReadString(Stream);
1219    end;
1220    ReadMemo(Stream, Memo);
1221    if (frVersion >= 23) and (StreamMode = smDesigning) then
1222    begin
1223      ReadMemo(Stream, Script);
1224      Read(Visible, 2);
1225    end;
1226    w := PInteger(@FrameWidth)^;
1227    if w <= 10 then
1228      w := w * 1000;
1229    FrameWidth := w / 1000;
1230  end;
1231end;
1232
1233procedure TfrView.SaveToStream(Stream: TStream);
1234var
1235  w: Integer;
1236  f: Single;
1237begin
1238  f := FrameWidth;
1239  if f <> Int(f) then
1240    w := Round(FrameWidth * 1000) else
1241    w := Round(f);
1242  PInteger(@FrameWidth)^ := w;
1243  with Stream do
1244  begin
1245    if StreamMode = smDesigning then
1246      frWriteString(Stream, Name);
1247    Write(x, 30); // this is equal to, but much faster:
1248{    Write(x, 4); Write(y, 4); Write(dx, 4); Write(dy, 4);
1249    Write(Flags, 2);
1250    Write(FrameTyp, 2);
1251    Write(FrameWidth, 4);
1252    Write(FrameColor, 4);
1253    Write(FrameStyle, 2);}
1254    Write(FillColor, 4);
1255    if StreamMode = smDesigning then
1256    begin
1257      Write(Format, 4);
1258      frWriteString(Stream, FormatStr);
1259      frWriteMemo(Stream, Memo);
1260    end
1261    else
1262      frWriteMemo(Stream, Memo1);
1263    if StreamMode = smDesigning then
1264    begin
1265      frWriteMemo(Stream, Script);
1266      Write(Visible, 2);
1267    end;
1268  end;
1269  FrameWidth := f;
1270end;
1271
1272procedure TfrView.SaveToFR3Stream(Stream: TStream);
1273var 
1274  FTyp: Integer;
1275  s: String;
1276
1277  procedure WriteStr(const s: String);
1278  begin
1279    Stream.Write(s[1], Length(s));
1280  end;
1281
1282begin
1283  s := ClassName;
1284  if Pos('Tfr', s) = 1 then
1285  begin
1286    Delete(s, 1, 3);
1287    s := 'Tfrx' + s;
1288    if CompareText(s, 'TfrxSubreportView') = 0 then
1289      s := 'TfrxSubreport';
1290  end;
1291  WriteStr('<' + s + ' ');
1292  WriteStr('Name="' + Name +
1293    '" Left="' + IntToStr(x) + '" Top="' + IntToStr(y) +
1294    '" Width="' + IntToStr(dx) + '" Height="' + IntToStr(dy) +
1295    '" Color="' + IntToStr(FillColor) + '"');
1296  if not Visible then
1297    WriteStr(' Visible="False"');
1298
1299  FTyp := 0;
1300  if (FrameTyp and frftLeft) <> 0 then
1301    FTyp := FTyp or 1;
1302  if (FrameTyp and frftRight) <> 0 then
1303    FTyp := FTyp or 2;
1304  if (FrameTyp and frftUp) <> 0 then
1305    FTyp := FTyp or 4;
1306  if (FrameTyp and frftDown) <> 0 then
1307    FTyp := FTyp or 8;
1308
1309  WriteStr(' Frame.Typ="' + IntToStr(FTyp) +
1310    '" Frame.Width="' + FloatToStr(FrameWidth) +
1311    '" Frame.Color="' + IntToStr(FrameColor) +
1312    '" Frame.Style="' + IntToStr(FrameStyle) +
1313    '" GapX="' + IntToStr(gapx) + '" GapY="' + IntToStr(gapy) +
1314    {'" TagStr="' + StrToXML(Tag) + }'" Memo.text="' + StrToXML(Memo.Text) + '"');
1315
1316{  ba := BandAlign;
1317  if ba = baRest then
1318    ba := baWidth
1319  else if ba = baTop then
1320    ba := baNone;
1321  WriteStr(' Align="' + IntToStr(ba) + '"');}
1322
1323  if Script.Count > 0 then
1324    WriteStr(' OnBeforePrint="' + Name + 'OnBeforePrint' +
1325      '" OnClick="' + Name + 'OnBeforePrint' +
1326      '" OnActivate="' + Name + 'OnBeforePrint"');
1327
1328{  RTyp := 0;
1329  if ((Restrictions and frrfDontEditMemo) <> 0) or
1330     ((Restrictions and frrfDontEditScript) <> 0) or
1331     ((Restrictions and frrfDontEditContents) <> 0) or
1332     ((Restrictions and frrfDontModify) <> 0) then
1333    RTyp := RTyp or 1;
1334  if (Restrictions and frrfDontSize) <> 0 then
1335    RTyp := RTyp or 2;
1336  if (Restrictions and frrfDontMove) <> 0 then
1337    RTyp := RTyp or 4;
1338  if (Restrictions and frrfDontDelete) <> 0 then
1339    RTyp := RTyp or 8;
1340  WriteStr(' Restrictions="' + IntToStr(RTyp) + '"');}
1341end;
1342
1343procedure TfrView.Resized;
1344begin
1345end;
1346
1347procedure TfrView.GetBlob(b: TfrTField);
1348begin
1349end;
1350
1351procedure TfrView.OnHook(View: TfrView);
1352begin
1353end;
1354
1355function TfrView.GetClipRgn(rt: TfrRgnType): HRGN;
1356var
1357  bx, by, bx1, by1, w1, w2: Integer;
1358begin
1359  if FrameStyle = 5 then
1360  begin
1361    w1 := Round(FrameWidth * 1.5);
1362    w2 := Round((FrameWidth - 1) / 2 + FrameWidth);
1363  end
1364  else
1365  begin
1366    w1 := Round(FrameWidth / 2);
1367    w2 := Round((FrameWidth - 1) / 2);
1368  end;
1369  bx := x; by := y; bx1 := x + dx + 1; by1 := y + dy + 1;
1370  if (FrameTyp and $1) <> 0 then Inc(bx1, w2);
1371  if (FrameTyp and $2) <> 0 then Inc(by1, w2);
1372  if (FrameTyp and $4) <> 0 then Dec(bx, w1);
1373  if (FrameTyp and $8) <> 0 then Dec(by, w1);
1374  if rt = rtNormal then
1375    Result := CreateRectRgn(bx, by, bx1, by1) else
1376    Result := CreateRectRgn(bx - 10, by - 10, bx1 + 10, by1 + 10);
1377end;
1378
1379procedure TfrView.CreateUniqueName;
1380var
1381  i: Integer;
1382begin
1383  Name := '';
1384  for i := 1 to 10000 do
1385    if CurReport.FindObject(BaseName + IntToStr(i)) = nil then
1386    begin
1387      Name := BaseName + IntToStr(i);
1388      Exit;
1389    end;
1390end;
1391
1392procedure TfrView.SetBounds(Left, Top, Width, Height: Integer);
1393begin
1394  x := Left;
1395  y := Top;
1396  dx := Width;
1397  dy := Height;
1398end;
1399
1400procedure TfrView.DefinePopupMenu(Popup: TPopupMenu);
1401var
1402  m: TMenuItem;
1403begin
1404  m := TMenuItem.Create(Popup);
1405  m.Caption := '-';
1406  Popup.Items.Add(m);
1407
1408  m := TMenuItem.Create(Popup);
1409  m.Caption := LoadStr(SStretched);
1410  m.OnClick := P1Click;
1411  m.Checked := (Flags and flStretched) <> 0;
1412  Popup.Items.Add(m);
1413end;
1414
1415procedure TfrView.P1Click(Sender: TObject);
1416var
1417  i: Integer;
1418  t: TfrView;
1419begin
1420  frDesigner.BeforeChange;
1421  with Sender as TMenuItem do
1422  begin
1423    Checked := not Checked;
1424    for i := 0 to frDesigner.Page.Objects.Count-1 do
1425    begin
1426      t := frDesigner.Page.Objects[i];
1427      if t.Selected then
1428        t.Flags := (t.Flags and not flStretched) + Word(Checked);
1429    end;
1430  end;
1431  frDesigner.AfterChange;
1432end;
1433
1434{----------------------------------------------------------------------------}
1435constructor TfrMemoView.Create;
1436begin
1437  inherited Create;
1438  Typ := gtMemo;
1439  FFont := TFont.Create;
1440  FFont.Name := 'Arial';
1441  FFont.Size := 10;
1442  FFont.Color := clBlack;
1443{$IFNDEF Delphi2}
1444  FFont.Charset := frCharset;
1445{$ENDIF}
1446  Highlight.FontColor := clBlack;
1447  Highlight.FillColor := clWhite;
1448  Highlight.FontStyle := 2; // fsBold
1449  BaseName := 'Memo';
1450  Flags := flStretched + flWordWrap;
1451  LineSpacing := 2;
1452  CharacterSpacing := 0;
1453end;
1454
1455destructor TfrMemoView.Destroy;
1456begin
1457  FFont.Free;
1458  inherited Destroy;
1459end;
1460
1461procedure TfrMemoView.SetFont(Value: TFont);
1462begin
1463  FFont.Assign(Value);
1464end;
1465
1466procedure TfrMemoView.Assign(From: TfrView);
1467begin
1468  inherited Assign(From);
1469  Font := TfrMemoView(From).Font;
1470  Adjust := TfrMemoView(From).Adjust;
1471  Highlight := TfrMemoView(From).Highlight;
1472  HighlightStr := TfrMemoView(From).HighlightStr;
1473  LineSpacing := TfrMemoView(From).LineSpacing;
1474end;
1475
1476procedure TfrMemoView.ExpandVariables;
1477var
1478  i: Integer;
1479  s: String;
1480  procedure GetData(var s: String);
1481  var
1482    i, j: Integer;
1483    s1, s2: String;
1484  begin
1485    i := 1;
1486    repeat
1487      while (i < Length(s)) and (s[i] <> '[') do Inc(i);
1488      s1 := GetBrackedVariable(s, i, j);
1489      if i <> j then
1490      begin
1491        Delete(s, i, j - i + 1);
1492        s2 := '';
1493        CurReport.InternalOnGetValue(s1, s2);
1494        Insert(s2, s, i);
1495        Inc(i, Length(s2));
1496        j := 0;
1497      end;
1498    until i = j;
1499  end;
1500begin
1501  Memo1.Clear;
1502  for i := 0 to Memo.Count - 1 do
1503  begin
1504    s := Memo[i];
1505    if Length(s) > 0 then
1506    begin
1507      GetData(s);
1508      Memo1.Text := Memo1.Text + s;
1509    end
1510    else
1511      Memo1.Add('');
1512  end;
1513end;
1514
1515procedure TfrMemoView.AssignFont(Canvas: TCanvas);
1516begin
1517  with Canvas do
1518  begin
1519    Brush.Style := bsClear;
1520    Font := Self.Font;
1521    if not IsPrinting then
1522      Font.Height := -Round(Font.Size * 96 / 72 * ScaleY);
1523  end;
1524end;
1525
1526
1527type
1528  TWordBreaks = string;
1529
1530const
1531  gl: set of Char = ['�', '�', '�', '�', '�', '�', '�', '�', '�', '�'];
1532  r_sogl: set of Char = ['�', '�'];
1533  spaces: set of Char = [' ', '.', ',', '-'];
1534
1535function BreakWord(s: String): TWordBreaks;
1536var
1537  i: Integer;
1538  CanBreak: Boolean;
1539begin
1540  Result := '';
1541  s := AnsiUpperCase(s);
1542  if Length(s) > 4 then
1543  begin
1544    i := 2;
1545    repeat
1546      CanBreak := False;
1547      if s[i] in gl then
1548      begin
1549        if (s[i + 1] in gl) or (s[i + 2] in gl) then CanBreak := True;
1550      end
1551      else
1552      begin
1553        if not (s[i + 1] in gl) and not (s[i + 1] in r_sogl) and
1554           (s[i + 2] in gl) then
1555          CanBreak := True;
1556      end;
1557      if CanBreak then
1558        Result := Result + Chr(i);
1559      Inc(i);
1560    until i > Length(s) - 2;
1561  end;
1562end;
1563
1564procedure TfrMemoView.WrapMemo;
1565var
1566  size, size1, maxwidth: Integer;
1567  b: TWordBreaks;
1568  WCanvas: TCanvas;
1569
1570  procedure OutLine(const str: String);
1571  var
1572    n, w: Word;
1573  begin
1574    n := Length(str);
1575    if (n > 0) and (str[n] = #1) then
1576      w := WCanvas.TextWidth(Copy(str, 1, n - 1)) else
1577      w := WCanvas.TextWidth(str);
1578    SMemo.Add(str + Chr(w div 256) + Chr(w mod 256));
1579    Inc(size, size1);
1580  end;
1581
1582  procedure WrapLine(const s: String);
1583  var
1584    i, cur, beg, last: Integer;
1585    Wa…

Large files files are truncated, but you can click here to view the full file