/Source/FR_Class.pas
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