frxpreviewpages.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{ }
{ FastReport v3.0 }
{ Preview Pages }
{ }
{ Copyright (c) 1998-2005 }
{ by Alexander Tzyganenko, }
{ Fast Reports Inc. }
{ }
{******************************************}

unit frxPreviewPages;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  frxClass, frxXML
{$IFDEF Delphi6}
, Variants
{$ENDIF};

type
  TfrxOutline = class(TfrxCustomOutline)
  private
    function Root:TfrxXMLItem;
  protected
    function GetCount:Integer; override;
  public
    procedure AddItem(const Text:String; Top:Integer); override;
    procedure LevelDown(Index:Integer); override;
    procedure LevelRoot; override;
    procedure LevelUp; override;
    procedure GetItem(Index:Integer; var Text:String;
      var Page, Top:Integer); override;
    procedure ShiftItems(From:TfrxXMLItem; NewTop:Integer); override;
    function GetCurPosition:TfrxXMLItem; override;
  end;

  TfrxDictionary = class(TObject)
  private
    FNames:TStringList;
    FSourceNames:TStringList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(const Name, SourceName:String; Obj:TObject);
    procedure Clear;
    function AddUnique(const Base, SourceName:String; Obj:TObject):String;
    function CreateUniqueName(const Base:String):String;
    function GetSourceName(const Name:String):String;
    function GetObject(const Name:String):TObject;
    property Names:TStringList read FNames;
    property SourceNames:TStringList read FSourceNames;
  end;

  TfrxPreviewPages = class(TfrxCustomPreviewPages)
  private
    FDictionary:TfrxDictionary; { list of all objects }
    FFirstObjectIndex:Integer; { used in the ClearFirstPassPages }
    FFirstPageIndex:Integer; { used in the ClearFirstPassPages }
    FPageCache:TStringList; { last 20 TfrxPreviewPage }
    FPagesItem:TfrxXMLItem; { shortcut to XMLDoc.Root.FindName('previewpages') }
    FSourcePages:TList; { list of source pages }
    FXMLDoc:TfrxXMLDocument; { parsed FP3 document }
    FXMLSize:Integer;
    FTempStream:TStream;
    FAllowPartialLoading:Boolean;
    procedure AfterLoad;
    procedure BeforeSave;
    procedure ClearPageCache;
    procedure ClearSourcePages;
    function CurXMLPage:TfrxXMLItem;
    function GetObject(const Name:String):TfrxComponent;
    procedure DoLoadFromStream;
    procedure DoSaveToStream;
  protected
    function GetCount:Integer; override;
    function GetPage(Index:Integer):TfrxReportPage; override;
    function GetPageSize(Index:Integer):TPoint; override;
  public
    constructor Create(AReport:TfrxReport); override;
    destructor Destroy; override;
    procedure Clear; override;
    procedure Initialize; override;

    { engine commands }
    procedure AddAnchor(const Text:String);
    procedure AddObject(Obj:TfrxComponent); override;
    procedure AddPage(Page:TfrxReportPage); override;
    procedure AddSourcePage(Page:TfrxReportPage); override;
    procedure AddToSourcePage(Obj:TfrxComponent); override;
    procedure BeginPass; override;
    procedure ClearFirstPassPages; override;
    procedure CutObjects(APosition:Integer); override;
    procedure Finish; override;
    procedure PasteObjects(X, Y:Extended); override;
    function BandExists(Band:TfrxBand):Boolean; override;
    function FindAnchor(const Text:String):TfrxXMLItem;
    function GetAnchorPage(const Text:String):Integer;
    function GetCurPosition:Integer; override;
    function GetLastY:Extended; override;

    { preview commands }
    procedure DrawPage(Index:Integer; Canvas:TCanvas; ScaleX, ScaleY,
      OffsetX, OffsetY:Extended); override;
    procedure AddEmptyPage(Index:Integer); override;
    procedure DeletePage(Index:Integer); override;
    procedure ModifyPage(Index:Integer; Page:TfrxReportPage); override;
    procedure LoadFromStream(Stream:TStream;
      AllowPartialLoading:Boolean = False); override;
    procedure SaveToStream(Stream:TStream); override;
    function LoadFromFile(const FileName:String;
      ExceptionIfNotFound:Boolean = False):Boolean; override;
    procedure SaveToFile(const FileName:String); override;
    function Print:Boolean; override;
    function Export(Filter:TfrxCustomExportFilter):Boolean; override;
    procedure ObjectOver(Index:Integer; X, Y:Integer; Button:TMouseButton;
      Shift:TShiftState; Scale, OffsetX, OffsetY:Extended;
      Click:Boolean; var Cursor:TCursor); override;
    property SourcePages:TList read FSourcePages;
  end;

implementation

uses
  frxPreview, Printers, frxPrinter, frxPrintDialog, frxXMLSerializer, frxUtils,
  ShellApi, frxDMPClass, frxRes;

type
  THackComponent = class(TfrxComponent);
  THackMemoView = class(TfrxCustomMemoView);
  THackThread = class(TThread);

{ TfrxOutline }

procedure TfrxOutline.AddItem(const Text:String; Top:Integer);
begin
  CurItem:= CurItem.Add;
  CurItem.Name:= 'item';
  CurItem.Text:= 'text="'+frxStrToXML(Text)+
    '" page="'+IntToStr(PreviewPages.CurPage)+
    '" top="'+IntToStr(Top)+'"';
end;

procedure TfrxOutline.GetItem(Index:Integer; var Text:String; var Page,
  Top:Integer);
var
  Item:TfrxXMLItem;
  s:String;
begin
  Item:= CurItem[Index];
  Text:= Item.Prop['text'];

  s:= Item.Prop['page'];
  if s<>'' then
    Page:= StrToInt(s);

  s:= Item.Prop['top'];
  if s<>'' then
    Top:= StrToInt(s);
end;

procedure TfrxOutline.LevelDown(Index:Integer);
begin
  CurItem:= CurItem[Index];
end;

procedure TfrxOutline.LevelRoot;
begin
  CurItem:= Root;
end;

procedure TfrxOutline.LevelUp;
begin
  if CurItem<>Root then
    CurItem:= CurItem.Parent;
end;

function TfrxOutline.Root:TfrxXMLItem;
begin
  Result:= TfrxPreviewPages(PreviewPages).FXMLDoc.Root.FindItem('outline');
end;

function TfrxOutline.GetCount:Integer;
begin
  Result:= CurItem.Count;
end;

procedure TfrxOutline.ShiftItems(From:TfrxXMLItem; NewTop:Integer);
var
  i, TopY, CorrY:Integer;

  procedure EnumItems(Item:TfrxXMLItem);
  var
    i:Integer;
  begin
    Item.Prop['page']:= IntToStr(StrToInt(Item.Prop['page'])+1);
    Item.Prop['top']:= IntToStr(StrToInt(Item.Prop['top'])+CorrY);
    for i:= 0 to Item.Count-1 do
      EnumItems(Item[i]);
  end;

begin
  i:= From.Parent.IndexOf(From);
  if i+1 >= From.Parent.Count then Exit;
  From:= From.Parent[i+1];

  TopY:= StrToInt(From.Prop['top']);
  CorrY:= NewTop-TopY;
  EnumItems(From);
end;

function TfrxOutline.GetCurPosition:TfrxXMLItem;
begin
  if Count = 0 then
    Result:= CurItem else
    Result:= CurItem[Count-1];
end;

{ TfrxDictionary }

constructor TfrxDictionary.Create;
begin
  FNames:= TStringList.Create;
  FNames.Sorted:= True;
  FSourceNames:= TStringList.Create;
end;

destructor TfrxDictionary.Destroy;
begin
  FNames.Free;
  FSourceNames.Free;
  inherited;
end;

procedure TfrxDictionary.Clear;
begin
  FNames.Clear;
  FSourceNames.Clear;
end;

procedure TfrxDictionary.Add(const Name, SourceName:String; Obj:TObject);
var
  i:Integer;
begin
  i:= FSourceNames.AddObject(SourceName, Obj);
  FNames.AddObject(Name, TObject(i));
end;

function TfrxDictionary.AddUnique(const Base, SourceName:String; Obj:TObject):String;
begin
  Result:= CreateUniqueName(Base);
  Add(Result, SourceName, Obj);
end;

function TfrxDictionary.CreateUniqueName(const Base:String):String;
var
  i:Integer;
begin
  i:= 10000;
  while (i > 1) and (FNames.IndexOf(Base+IntToStr(i)) =-1) do
    i:= i div 2;
  while FNames.IndexOf(Base+IntToStr(i))<>-1 do
    Inc(i);
  Result:= Base+IntToStr(i);
end;

function TfrxDictionary.GetObject(const Name:String):TObject;
var
  i:Integer;
begin
  Result:= nil;
  i:= FNames.IndexOf(Name);
  if i<>-1 then
    Result:= FSourceNames.Objects[Integer(FNames.Objects[i])];
end;

function TfrxDictionary.GetSourceName(const Name:String):String;
var
  i:Integer;
begin
  Result:= '';
  i:= FNames.IndexOf(Name);
  if i<>-1 then
    Result:= FSourceNames[Integer(FNames.Objects[i])];
end;

{ TfrxPreviewPages }

constructor TfrxPreviewPages.Create(AReport:TfrxReport);
begin
  inherited;
  FDictionary:= TfrxDictionary.Create;
  FSourcePages:= TList.Create;
  FXMLDoc:= TfrxXMLDocument.Create;
  FXMLDoc.Root.Name:= 'preparedreport';
// FXMLDoc.AutoIndent:= True;
  FPageCache:= TStringList.Create;
end;

destructor TfrxPreviewPages.Destroy;
begin
  ClearPageCache;
  FPageCache.Free;
  FDictionary.Free;
  ClearSourcePages;
  FSourcePages.Free;
  FXMLDoc.Free;
  inherited;
end;

procedure TfrxPreviewPages.Clear;
begin
  ClearPageCache;
  ClearSourcePages;
  FXMLDoc.Clear;
  FDictionary.Clear;
  CurPage:=-1;
  FXMLSize:= 0;
end;

procedure TfrxPreviewPages.Initialize;
begin
  FXMLDoc.TempDir:= Report.EngineOptions.TempDir;
  Report.InternalOnProgressStart(ptRunning);
end;

procedure TfrxPreviewPages.ClearPageCache;
begin
  while FPageCache.Count > 0 do
  begin
    TfrxReportPage(FPageCache.Objects[0]).Free;
    FPageCache.Delete(0);
  end;
end;

procedure TfrxPreviewPages.ClearSourcePages;
begin
  while FSourcePages.Count > 0 do
  begin
    TfrxReportPage(FSourcePages[0]).Free;
    FSourcePages.Delete(0);
  end;
end;

procedure TfrxPreviewPages.BeginPass;
begin
  FFirstPageIndex:= Count-1;
  if FFirstPageIndex<>-1 then
    FFirstObjectIndex:= FXMLDoc.Root.FindItem('previewpages')[FFirstPageIndex].Count;
end;

procedure TfrxPreviewPages.ClearFirstPassPages;
var
  PagesRoot:TfrxXMLItem;
  p:TfrxXMLItem;
  i:Integer;
begin
  if FFirstPageIndex =-1 then
  begin
    for i:= 0 to FXMLDoc.Root.Count-1 do
      if CompareText(FXMLDoc.Root[i].Name, 'anchors')<>0 then
        FXMLDoc.Root[i].Clear;
  end
  else
  begin
    PagesRoot:= FXMLDoc.Root.FindItem('previewpages');
    p:= PagesRoot[FFirstPageIndex];
    { clear some objects on first page }
    while p.Count > FFirstObjectIndex do
      p[FFirstObjectIndex].Free;
    { clear remained pages }
    while Count > FFirstPageIndex+1 do
      PagesRoot[FFirstPageIndex+1].Free;
  end;

  CurPage:= FFirstPageIndex;
  FXMLSize:= 0;
end;

function TfrxPreviewPages.CurXMLPage:TfrxXMLItem;
begin
  Result:= FXMLDoc.Root.FindItem('previewpages');
  Result:= Result[CurPage];
end;

function TfrxPreviewPages.GetCount:Integer;
begin
  Result:= FXMLDoc.Root.FindItem('previewpages').Count;
end;

function TfrxPreviewPages.GetCurPosition:Integer;
begin
  Result:= CurXMLPage.Count;
end;

procedure TfrxPreviewPages.AddAnchor(const Text:String);
var
  AnchorRoot, Item:TfrxXMLItem;
begin
  AnchorRoot:= FXMLDoc.Root.FindItem('anchors');
  Item:= AnchorRoot.Add;
  Item.Name:= 'item';
  Item.Text:= 'text="'+frxStrToXML(Text)+
    '" page="'+IntToStr(CurPage)+
    '" top="'+IntToStr(Round(Engine.CurY))+'"';
end;

function TfrxPreviewPages.FindAnchor(const Text:String):TfrxXMLItem;
var
  AnchorRoot, Item:TfrxXMLItem;
  i:Integer;
begin
  Result:= nil;
  AnchorRoot:= FXMLDoc.Root.FindItem('anchors');
  for i:= AnchorRoot.Count-1 downto 0 do
  begin
    Item:= AnchorRoot[i];
    if AnsiCompareText(Item.Prop['text'], Text) = 0 then
    begin
      Result:= Item;
      Exit;
    end;
  end;
end;

function TfrxPreviewPages.GetAnchorPage(const Text:String):Integer;
var
  Item:TfrxXMLItem;
begin
  Item:= FindAnchor(Text);
  if Item<>nil then
    Result:= StrToInt(Item.Prop['page'])+1 else
    Result:= 1;
end;

procedure TfrxPreviewPages.AddObject(Obj:TfrxComponent);

  procedure DoAdd(c:TfrxComponent; Item:TfrxXMLItem);
  var
    i:Integer;
  begin
    if not c.Visible then Exit;

    { do not put out subreports, cross-tabs and dialog components }
    if not ((c is TfrxSubReport) or (CompareText(c.ClassName, 'TfrxCrossView') = 0) or
      (CompareText(c.ClassName, 'TfrxDBCrossView') = 0) or (c is TfrxDialogComponent)) then
      with THackComponent(c) do
      begin
        Item:= Item.Add;
        { the component that was created after report has been started }
        if FOriginalComponent = nil then
        begin
          Item.Name:= ClassName;
          Item.Text:= AllDiff(nil);
        end
        else
        begin
          { the component that exists in the report template }
          Item.Name:= FAliasName;
          if Engine.FinalPass then
          begin
            if DefaultDiff then
              Item.Text:= AllDiff(FOriginalComponent) else
              Item.Text:= Diff(FOriginalComponent);
          end
          else
            { we don't need to output all info on the first pass, only coordinates }
            Item.Text:= InternalDiff(FOriginalComponent);
        end;
        Inc(FXMLSize, Length(Item.Name)+Length(Item.Text)+Item.InstanceSize+16);
      end;

    for i:= 0 to c.Objects.Count-1 do
      DoAdd(c.Objects[i], Item);
  end;

begin
  DoAdd(Obj, CurXMLPage);
end;

procedure TfrxPreviewPages.AddPage(Page:TfrxReportPage);
var
  xi:TfrxXMLItem;

  procedure UnloadPages;
  var
    i:Integer;
  begin
    if Report.EngineOptions.UseFileCache then
      if FXMLSize > Report.EngineOptions.MaxMemSize * 1024 * 1024 then
      begin
        for i:= xi.Count-2 downto 0 do
          if xi[i].Loaded then
            FXMLDoc.UnloadItem(xi[i]) else
            break;
        FXMLSize:= 0;
      end;
  end;

  function GetSourceNo(Page:TfrxReportPage):Integer;
  var
    i:Integer;
  begin
    Result:=-1;
    for i:= 0 to FSourcePages.Count-1 do
      if THackComponent(FSourcePages[i]).FOriginalComponent = Page then
      begin
        Result:= i;
        break;
      end;
  end;

begin
  FPagesItem:= FXMLDoc.Root.FindItem('previewpages');
  xi:= FPagesItem;
  UnloadPages;

  CurPage:= CurPage+1;
  if (CurPage >= Count) or (AddPageAction = apAdd) then
  begin
    xi:= xi.Add;
    xi.Name:= 'page'+IntToStr(GetSourceNo(Page));
    if Count > 2 then
      xi.Unloadable:= True;
    Report.InternalOnProgress(ptRunning, CurPage+1);
    AddPageAction:= apWriteOver;
    CurPage:= Count-1;
  end;
end;

procedure TfrxPreviewPages.AddSourcePage(Page:TfrxReportPage);
var
  p:TfrxReportPage;
  xs:TfrxXMLSerializer;
  i:Integer;
  originals, copies:TList;
  c1, c2:TfrxComponent;
  s:String;

  function EnumObjects(Parent, Parent1:TfrxComponent):TfrxComponent;
  var
    i:Integer;