frxpreview.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{             Report preview               }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxPreview;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Buttons, StdCtrls, Menus, ComCtrls, ImgList, frxCtrls, frxDock,
  ToolWin, frxPreviewPages
{$IFDEF FR_COM}
//, ActiveX, AxCtrls
//, VCLCom, ComObj, ComServ
//, ClrStream
//, frxFont
, FastReport_TLB
{$ENDIF}
, frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};


const
  WM_UPDATEZOOM = WM_USER + 1;

type
  TfrxPreview = class;
  TfrxPreviewWorkspace = class;
  TfrxPageList = class;

  TfrxPreviewTool = (ptHand, ptZoom);
  TfrxPageChangedEvent = procedure(Sender: TfrxPreview; PageNo: Integer) of object;

{$IFDEF FR_COM}
  TfrxPreview = class(TfrxCustomPreview, IfrxPreview)
{$ELSE}
  TfrxPreview = class(TfrxCustomPreview)
{$ENDIF}
  private
    FAllowF3: Boolean;
    FBackColor: TColor;
    FCancelButton: TButton;
    FFrameColor: TColor;
    FLocked: Boolean;
    FMessageLabel: TLabel;
    FMessagePanel: TPanel;
    FOnPageChanged: TfrxPageChangedEvent;
    FOutline: TTreeView;
    FPageNo: Integer;
    FRunning: Boolean;
    FScrollBars: TScrollStyle;
    FSplitter: TSplitter;
    FTick: Cardinal;
    FTool: TfrxPreviewTool;
    FWorkspace: TfrxPreviewWorkspace;
    FZoom: Extended;
    FZoomMode: TfrxZoomMode;
    function GetOutlineVisible: Boolean;
    function GetPageCount: Integer;
    procedure EditTemplate;
    procedure OnCancel(Sender: TObject);
    procedure SetOutlineVisible(const Value: Boolean);
    procedure SetPageNo(const Value: Integer);              
    procedure SetTool(const Value: TfrxPreviewTool);
    procedure SetZoom(const Value: Extended);
    procedure SetZoomMode(const Value: TfrxZoomMode);
    procedure TreeClick(Sender: TObject);
    procedure UpdateZoom;
    procedure UpdateOutline;
    procedure UpdatePageNumbers;
    procedure UpdatePages;
    procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    function GetOutlineWidth: Integer;
    procedure SetOutlineWidth(const Value: Integer);
  protected
    procedure Resize; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Init; override;
    procedure Lock; override;
    procedure Unlock; override;
    procedure InternalOnProgressStart(Sender: TfrxReport;
      ProgressType: TfrxProgressType; Progress: Integer); override;
    procedure InternalOnProgress(Sender: TfrxReport;
      ProgressType: TfrxProgressType; Progress: Integer); override;
    procedure InternalOnProgressStop(Sender: TfrxReport;
      ProgressType: TfrxProgressType; Progress: Integer); override;

    procedure AddPage;
    procedure DeletePage;
    procedure Print;
    procedure LoadFromFile; overload;
    procedure LoadFromFile(FileName: String); overload;
    procedure SaveToFile; overload;
    procedure SaveToFile(FileName: String); overload;
    procedure Edit;
    procedure Export(Filter: TfrxCustomExportFilter);
    procedure First;
    procedure Next;
    procedure Prior;
    procedure Last;
    procedure PageSetupDlg;
    procedure Find;
    procedure FindNext;
    procedure Cancel;
    procedure Clear;
    procedure SetPosition(PageN, Top: Integer);
    procedure ShowMessage(const s: String);
    procedure HideMessage;
    procedure MouseWheelScroll(Delta: Integer; Horz: Boolean = False;
      Zoom: Boolean = False);
    property PageCount: Integer read GetPageCount;
    property PageNo: Integer read FPageNo write SetPageNo;
    property Tool: TfrxPreviewTool read FTool write SetTool;
    property Zoom: Extended read FZoom write SetZoom;
    property ZoomMode: TfrxZoomMode read FZoomMode write SetZoomMode;
  published
    property Align;
    property BackColor: TColor read FBackColor write FBackColor default clGray;
    property FrameColor: TColor read FFrameColor write FFrameColor default clBlack;
    property OutlineVisible: Boolean read GetOutlineVisible write SetOutlineVisible;
    property OutlineWidth: Integer read GetOutlineWidth write SetOutlineWidth;
    property PopupMenu;
    property OnClick;
    property OnPageChanged: TfrxPageChangedEvent read FOnPageChanged write FOnPageChanged;
  end;

  TfrxPreviewForm = class(TForm)
    ToolBar: TToolBar;
    OpenB: TToolButton;
    SaveB: TToolButton;
    PrintB: TToolButton;
    ExportB: TToolButton;
    FindB: TToolButton;
    PageSettingsB: TToolButton;
    Sep3: TfrxTBPanel;
    ZoomCB: TfrxComboBox;
    Sep1: TToolButton;
    Sep2: TToolButton;
    FirstB: TToolButton;
    PriorB: TToolButton;
    Sep4: TfrxTBPanel;
    PageE: TEdit;
    NextB: TToolButton;
    LastB: TToolButton;
    StatusBar: TStatusBar;
    ZoomWholePageB: TToolButton;
    ZoomPageWidthB: TToolButton;
    Zoom100B: TToolButton;
    Zoom50B: TToolButton;
    Sep5: TToolButton;
    HandToolB: TToolButton;
    ZoomToolB: TToolButton;
    Sep6: TToolButton;
    OutlineB: TToolButton;
    NewPageB: TToolButton;
    DelPageB: TToolButton;
    DesignerB: TToolButton;
    Sep7: TToolButton;
    frTBPanel1: TfrxTBPanel;
    CancelB: TSpeedButton;
    ExportPopup: TPopupMenu;
    HiddenMenu: TPopupMenu;
    Showtemplate1: TMenuItem;
    RightMenu: TPopupMenu;
    FullScreenBtn: TToolButton;
    EmailB: TToolButton;
    PdfB: TToolButton;
    procedure FormCreate(Sender: TObject);
    procedure OutlineBClick(Sender: TObject);
    procedure ZoomWholePageBClick(Sender: TObject);
    procedure ZoomPageWidthBClick(Sender: TObject);
    procedure Zoom100BClick(Sender: TObject);
    procedure Zoom50BClick(Sender: TObject);
    procedure ZoomCBClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure SelectToolBClick(Sender: TObject);
    procedure FirstBClick(Sender: TObject);
    procedure PriorBClick(Sender: TObject);
    procedure NextBClick(Sender: TObject);
    procedure LastBClick(Sender: TObject);
    procedure PageEClick(Sender: TObject);
    procedure PrintBClick(Sender: TObject);
    procedure OpenBClick(Sender: TObject);
    procedure SaveBClick(Sender: TObject);
    procedure FindBClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure DesignerBClick(Sender: TObject);
    procedure NewPageBClick(Sender: TObject);
    procedure DelPageBClick(Sender: TObject);
    procedure CancelBClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure PageSettingsBClick(Sender: TObject);
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
    procedure DesignerBMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Showtemplate1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FullScreenBtnClick(Sender: TObject);
    procedure PdfBClick(Sender: TObject);
    procedure EmailBClick(Sender: TObject);
  private
    FFreeOnClose: Boolean;
    FPreview: TfrxPreview;
    FOldBS: TFormBorderStyle;
    FOldState: TWindowState;
    FFullScreen: Boolean;
    FPDFExport: TfrxCustomExportFilter;
    FEmailExport: TfrxCustomExportFilter;
    procedure ExportMIClick(Sender: TObject);
    procedure OnPageChanged(Sender: TfrxPreview; PageNo: Integer);
    procedure UpdateControls;
    procedure UpdateZoom;
    procedure WMUpdateZoom(var Message: TMessage); message WM_UPDATEZOOM;
    procedure WMActivateApp(var Msg: TWMActivateApp); message WM_ACTIVATEAPP;
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
    function GetReport: TfrxReport;
  public
    procedure Init;
    procedure SetMessageText(const Value: String);
    procedure SwitchToFullScreen;
    property FreeOnClose: Boolean read FFreeOnClose write FFreeOnClose;
    property Preview: TfrxPreview read FPreview;
    property Report: TfrxReport read GetReport;
  end;

  TfrxPreviewWorkspace = class(TfrxScrollWin)
  private
    FDefaultCursor: TCursor;
    FDisableUpdate: Boolean;
    FDown: Boolean;
    FEMFImage: TMetafile;
    FEMFImagePage: Integer;
    FLastFoundPage: Integer;
    FLastPoint: TPoint;
    FOffset: TPoint;
    FPageList: TfrxPageList;
    FPreview: TfrxPreview;
    function PreviewPages: TfrxCustomPreviewPages;
    procedure FindText;
    procedure HandleKey(Key: Word; Shift: TShiftState);
    procedure SetToPageNo(PageNo: Integer);
    procedure UpdateScrollBars;
  protected
    procedure DblClick; override;
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure OnHScrollChange(Sender: TObject); override;
    procedure Resize; override;
    procedure OnVScrollChange(Sender: TObject); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  end;

  TfrxPageItem = class(TObject)
  public
    Column: Word;
    Height: Word;
    Width: Word;
    Offset: Integer;
  end;

  TfrxPageList = class(TObject)
  private
    FColumnCount: Integer;
    FList: TList;
    FMaxWidth: Integer;
    procedure SetColumnCount(Value: Integer);
    function GetCount: Integer;
    function GetItems(Index: Integer): TfrxPageItem;
    property Items[Index: Integer]: TfrxPageItem read GetItems;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure AddPage(AWidth, AHeight: Integer);
    function FindPage(Offset: Integer; Scale: Extended;
      Exact: Boolean = False): Integer;
    function GetPageBounds(Index, ClientWidth: Integer; Scale: Extended): TRect;
    function GetMaxBounds(ClientWidth: Integer; Scale: Extended): TPoint;
    property ColumnCount: Integer read FColumnCount write SetColumnCount;
    property Count: Integer read GetCount;
  end;


implementation

{$R *.DFM}
{$R *.RES}

uses
  Printers, frxPrinter, frxSearchDialog, frxUtils, frxFormUtils, frxRes,
  frxDsgnIntf, frxPreviewPageSettings, frxDMPClass;


type
  THackControl = class(TWinControl);

{ search given string in a metafile }

var
  TextToFind: String;
  TextFound: Boolean;
  TextBounds: TRect;
  RecordNo: Integer;
  LastFoundRecord: Integer;
  CaseSensitive: Boolean;

function EnumEMFRecordsProc(DC: HDC; HandleTable: PHandleTable;
  EMFRecord: PEnhMetaRecord; nObj: Integer; OptData: Pointer): Bool; stdcall;
var
  Typ: Byte;
  s: String;
  t: TEMRExtTextOut;
  Found: Boolean;
begin
  Result := True;
  Typ := EMFRecord^.iType;
  if Typ in [83, 84] then
  begin
    t := PEMRExtTextOut(EMFRecord)^;
    s := WideCharLenToString(PWideChar(PChar(EMFRecord) + t.EMRText.offString),
      t.EMRText.nChars);
    if CaseSensitive then
      Found := Pos(TextToFind, s) <> 0 else
      Found := Pos(AnsiUpperCase(TextToFind), AnsiUpperCase(s)) <> 0;
    if Found and (RecordNo > LastFoundRecord) then
    begin
      TextFound := True;
      TextBounds := t.rclBounds;
      LastFoundRecord := RecordNo;
      Result := False;
    end;
  end;
  Inc(RecordNo);
end;


{ TfrxPageList }

constructor TfrxPageList.Create;
begin
  FList := TList.Create;
  FColumnCount := 1;
end;

destructor TfrxPageList.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

procedure TfrxPageList.Clear;
var
  i: Integer;
begin
  for i := 0 to FList.Count - 1 do
    TObject(FList[i]).Free;
  FList.Clear;
  FMaxWidth := 0;
end;

function TfrxPageList.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TfrxPageList.GetItems(Index: Integer): TfrxPageItem;
begin
  Result := FList[Index];
end;

procedure TfrxPageList.SetColumnCount(Value: Integer);
begin
  FColumnCount := Value;
  Clear;
end;

procedure TfrxPageList.AddPage(AWidth, AHeight: Integer);
var
  i, FirstColumnIndex, ColumnWidth, MaxHeight: Integer;
  Item, LastItem: TfrxPageItem;
begin
  Item := TfrxPageItem.Create;
  Item.Width := AWidth;
  Item.Height := AHeight;

  if Count > 0 then
  begin
    LastItem := Items[Count - 1];

    if LastItem.Column >= ColumnCount - 1 then
    begin
      FirstColumnIndex := Count - 1;
      while Items[FirstColumnIndex].Column > 0 do
        Dec(FirstColumnIndex);

      MaxHeight := 0;
      for i := FirstColumnIndex to Count - 1 do
        if Items[i].Height > MaxHeight then
          MaxHeight := Items[i].Height;

      Item.Column := 0;
      Item.Offset := LastItem.Offset + MaxHeight + 10;
    end
    else
    begin
      Item.Column := LastItem.Column + 1;
      Item.Offset := LastItem.Offset;
    end;
  end
  else
  begin
    Item.Column := 0;
    Item.Offset := 10;
  end;

  FList.Add(Item);

  FirstColumnIndex := Count - 1;
  while Items[FirstColumnIndex].Column > 0 do
    Dec(FirstColumnIndex);

  ColumnWidth := 0;
  for i := FirstColumnIndex to Count - 1 do
    Inc(ColumnWidth, Items[i].Width + 10);

  if FMaxWidth < ColumnWidth then
    FMaxWidth := ColumnWidth;
end;

function TfrxPageList.FindPage(Offset: Integer; Scale: Extended;
  Exact: Boolean = False): Integer;
var
  i, i0, i1, c, add: Integer;
begin
  i0 := 0;
  i1 := Count - 1;

  while i0 <= i1 do
  begin
    i := (i0 + i1) div 2;
    if Exact then
      add := 0 else
      add := Round(Scale * Items[i].Height / 5);
    if Items[i].Offset * Scale <= Offset + add then
      c := -1 else
      c := 1;

    if c < 0 then
      i0 := i + 1 else
      i1 := i - 1;
  end;

  Result := i1;
end;

function TfrxPageList.GetPageBounds(Index, ClientWidth: Integer;
  Scale: Extended): TRect;
var
  i, FirstColumnIndex, ItemOffs, ColumnOffs, ColumnWidth: Integer;
  Item: TfrxPageItem;
begin
  if (Index >= Count) or (Index < 0) then
  begin
    if 794 * Scale > ClientWidth then
      ColumnOffs := 10 else
      ColumnOffs := Round((ClientWidth - 794 * Scale) / 2);
    Result.Left := ColumnOffs;
    Result.Top := Round(10 * Scale);
    Result.Right := Result.Left + Round(794 * Scale);
    Result.Bottom := Result.Top + Round(1123 * Scale);
    Exit;
  end;

  Item := Items[Index];
  if ColumnCount > 1 then
  begin
    ItemOffs := 0;
    FirstColumnIndex := Index;
    while Items[FirstColumnIndex].Column > 0 do
    begin
      Dec(FirstColumnIndex);
      Inc(ItemOffs, Items[FirstColumnIndex].Width + 10);
    end;

    i := FirstColumnIndex;
    ColumnWidth := Items[i].Width;
    Inc(i);
    while (i < Count) and (Items[i].Column > 0) do
    begin
      Inc(ColumnWidth, Items[i].Width + 10);
      Inc(i);
    end;
  end
  else
  begin
    ItemOffs := 0;
    ColumnWidth := Item.Width;
  end;

  if ColumnWidth * Scale > ClientWidth then
    ColumnOffs := 10 else
    ColumnOffs := Round((ClientWidth - ColumnWidth * Scale) / 2);
  Result.Left := ColumnOffs + Round(ItemOffs * Scale);
  Result.Top := Round(Item.Offset * Scale);
  Result.Right := Result.Left + Round(Item.Width * Scale);
  Result.Bottom := Result.Top + Round(Item.Height * Scale);
end;

function TfrxPageList.GetMaxBounds(ClientWidth: Integer;
  Scale: Extended): TPoint;
begin
  if Count = 0 then
  begin
    Result := Point(0, 0);
    Exit;
  end;

  Result.X := Round(FMaxWidth * Scale);
  Result.Y := GetPageBounds(Count - 1, ClientWidth, Scale).Bottom;
end;


{ TfrxPreviewWorkspace }

constructor TfrxPreviewWorkspace.Create(AOwner: TComponent);
begin
  inherited;
  FPreview := TfrxPreview(AOwner);
  FPageList := TfrxPageList.Create;
  Color := clGray;
  LargeChange := 300;
  SmallChange := 8;
end;

destructor TfrxPreviewWorkspace.Destroy;
begin