frxpreview.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{             Report preview               }
{                                          }
{         Copyright (c) 1998-2008          }
{         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, frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};


const
  WM_UPDATEZOOM = WM_USER + 1;

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

  TfrxPreviewTool = (ptHand, ptZoom); // not implemented, backw compatibility only
  TfrxPageChangedEvent = procedure(Sender: TfrxPreview; PageNo: Integer) of object;


  TfrxPreview = class(TfrxCustomPreview)

  private
    FAllowF3: Boolean;
    FBorderStyle: TBorderStyle;
    FCancelButton: TButton;
    FLocked: Boolean;
    FMessageLabel: TLabel;
    FMessagePanel: TPanel;
    FOnPageChanged: TfrxPageChangedEvent;
    FOutline: TTreeView;
    FOutlineColor: TColor;
    FOutlinePopup: TPopupMenu;
    FPageNo: Integer;
    FRefreshing: Boolean;
    FRunning: Boolean;
    FScrollBars: TScrollStyle;
    FSplitter: TSplitter;
    FThumbnail: TfrxPreviewWorkspace;
    FTick: Cardinal;
    FTool: TfrxPreviewTool;
    FWorkspace: TfrxPreviewWorkspace;
    FZoom: Extended;
    FZoomMode: TfrxZoomMode;
    function GetActiveFrameColor: TColor;
    function GetBackColor: TColor;
    function GetFrameColor: TColor;
    function GetOutlineVisible: Boolean;
    function GetOutlineWidth: Integer;
    function GetPageCount: Integer;
    function GetThumbnailVisible: Boolean;
    procedure EditTemplate;
    procedure OnCancel(Sender: TObject);
    procedure OnCollapseClick(Sender: TObject);
    procedure OnExpandClick(Sender: TObject);
    procedure OnMoveSplitter(Sender: TObject);
    procedure OnOutlineClick(Sender: TObject);
    procedure SetActiveFrameColor(const Value: TColor);
    procedure SetBackColor(const Value: TColor);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetFrameColor(const Value: TColor);
    procedure SetOutlineColor(const Value: TColor);
    procedure SetOutlineWidth(const Value: Integer);
    procedure SetOutlineVisible(const Value: Boolean);
    procedure SetPageNo(Value: Integer);
    procedure SetThumbnailVisible(const Value: Boolean);
    procedure SetZoom(const Value: Extended);
    procedure SetZoomMode(const Value: TfrxZoomMode);
    procedure UpdateOutline;
    procedure UpdatePages;
    procedure UpdatePageNumbers;
    procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    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 RefreshReport; 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 Edit;
    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);

    function  GetTopPosition: Integer;
    procedure LoadFromFile; overload;
    procedure LoadFromFile(FileName: String); overload;
    procedure SaveToFile; overload;
    procedure SaveToFile(FileName: String); overload;
    procedure Export(Filter: TfrxCustomExportFilter);
    function FindText(SearchString: String; FromTop, IsCaseSensitive: Boolean): Boolean;
    function FindTextFound: Boolean;
    procedure FindTextClear;

    property PageCount: Integer read GetPageCount;
    property PageNo: Integer read FPageNo write SetPageNo;
    // not implemented, backw compatibility only
    property Tool: TfrxPreviewTool read FTool write FTool;
    property Zoom: Extended read FZoom write SetZoom;
    property ZoomMode: TfrxZoomMode read FZoomMode write SetZoomMode;
    property  Locked: Boolean read FLocked;
    property OutlineTree: TTreeView read FOutline;
    property Splitter: TSplitter read FSplitter;
    property Thumbnail: TfrxPreviewWorkspace read FThumbnail;
    property Workspace: TfrxPreviewWorkspace read FWorkspace;
  published
    property Align;
    property ActiveFrameColor: TColor read GetActiveFrameColor write SetActiveFrameColor default $804020;
    property BackColor: TColor read GetBackColor write SetBackColor default clGray;
    property BevelEdges;
    property BevelInner;
    property BevelKind;
    property BevelOuter;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property BorderWidth;
    property FrameColor: TColor read GetFrameColor write SetFrameColor default clBlack;
    property OutlineColor: TColor read FOutlineColor write SetOutlineColor default clWindow;
    property OutlineVisible: Boolean read GetOutlineVisible write SetOutlineVisible;
    property OutlineWidth: Integer read GetOutlineWidth write SetOutlineWidth;
    property PopupMenu;
    property ThumbnailVisible: Boolean read GetThumbnailVisible write SetThumbnailVisible;
    property OnClick;
    property OnDblClick;
    property OnPageChanged: TfrxPageChangedEvent read FOnPageChanged write FOnPageChanged;
    property Anchors;
    property UseReportHints;
  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;
    ZoomMinusB: TToolButton;
    Sep5: TToolButton;
    ZoomPlusB: TToolButton;
    DesignerB: TToolButton;
    frTBPanel1: TfrxTBPanel;
    CancelB: TSpeedButton;
    ExportPopup: TPopupMenu;
    HiddenMenu: TPopupMenu;
    Showtemplate1: TMenuItem;
    RightMenu: TPopupMenu;
    FullScreenBtn: TToolButton;
    EmailB: TToolButton;
    PdfB: TToolButton;
    OutlineB: TToolButton;
    ThumbB: TToolButton;
    N1: TMenuItem;
    ExpandMI: TMenuItem;
    CollapseMI: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure ZoomMinusBClick(Sender: TObject);
    procedure ZoomCBClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    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);
    procedure ZoomPlusBClick(Sender: TObject);
    procedure OutlineBClick(Sender: TObject);
    procedure ThumbBClick(Sender: TObject);
    procedure CollapseAllClick(Sender: TObject);
    procedure ExpandAllClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    FFreeOnClose: Boolean;
    FPreview: TfrxPreview;
    FOldBS: TFormBorderStyle;
    FOldState: TWindowState;
    FFullScreen: Boolean;
    FPDFExport: TfrxCustomExportFilter;
    FEmailExport: TfrxCustomExportFilter;
    FStatusBarOldWindowProc: TWndMethod;
    procedure ExportMIClick(Sender: TObject);
    procedure OnPageChanged(Sender: TfrxPreview; PageNo: Integer);
    procedure OnPreviewDblClick(Sender: TObject);
    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;
    procedure StatusBarWndProc(var Message: TMessage);
    function GetReport: TfrxReport;
  public
    procedure Init;
    procedure SetMessageText(const Value: String; IsHint: Boolean = False);
    procedure SwitchToFullScreen;
    property FreeOnClose: Boolean read FFreeOnClose write FFreeOnClose;
    property Preview: TfrxPreview read FPreview;
    property Report: TfrxReport read GetReport;
  end;

  TfrxPreviewWorkspace = class(TfrxScrollWin)
  private
    FActiveFrameColor: TColor;
    FBackColor: TColor;
    FDefaultCursor: TCursor;
    FDisableUpdate: Boolean;
    FDown: Boolean;
    FEMFImage: TMetafile;
    FEMFImagePage: Integer;
    FFrameColor: TColor;
    FIsThumbnail: Boolean;
    FLastFoundPage: Integer;
    FLastPoint: TPoint;
    FLocked: Boolean;
    FOffset: TPoint;
    FTimeOffset: Cardinal;
    FPageList: TfrxPageList;
    FPageNo: Integer;
    FPreview: TfrxPreview;
    FPreviewPages: TfrxCustomPreviewPages;
    FZoom: Extended;
    FRTLLanguage: Boolean;
    procedure DrawPages(BorderOnly: Boolean);
    procedure FindText;
    procedure SetToPageNo(PageNo: Integer);
    procedure UpdateScrollBars;
  protected
    procedure PrevDblClick(Sender: TObject);
    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;
    procedure SetPosition(PageN, Top: Integer);
    function GetTopPosition: Integer;
    { page list }
    procedure AddPage(AWidth, AHeight: Integer);
    procedure ClearPageList;
    procedure CalcPageBounds(ClientWidth: Integer);

    property ActiveFrameColor: TColor read FActiveFrameColor write FActiveFrameColor default $804020;
    property BackColor: TColor read FBackColor write FBackColor default clGray;
    property FrameColor: TColor read FFrameColor write FFrameColor default clBlack;
    property IsThumbnail: Boolean read FIsThumbnail write FIsThumbnail;
    property Locked: Boolean read FLocked write FLocked;
    property PageNo: Integer read FPageNo write FPageNo;
    property Preview: TfrxPreview read FPreview write FPreview;
    property PreviewPages: TfrxCustomPreviewPages read FPreviewPages
      write FPreviewPages;
    property Zoom: Extended read FZoom write FZoom;
    property RTLLanguage: Boolean read FRTLLanguage write FRTLLanguage;
    property OnDblClick;
  end;

  TfrxPageItem = class(TCollectionItem)
  public
    Height: Integer;
    Width: Integer;
    OffsetX: Integer;
    OffsetY: Integer;
  end;

  TfrxPageList = class(TCollection)
  private
    FMaxWidth: Integer;
    function GetItems(Index: Integer): TfrxPageItem;
  public
    constructor Create;
    property Items[Index: Integer]: TfrxPageItem read GetItems; default;
    procedure AddPage(AWidth, AHeight: Integer; Zoom: Extended);
    procedure CalcBounds(ClientWidth: Integer);
    function FindPage(OffsetY: Integer; OffsetX: Integer = 0): Integer;
    function GetPageBounds(Index, ClientWidth: Integer; Scale: Extended; RTL: Boolean): TRect;
    function GetMaxBounds: TPoint;
  end;


implementation

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

uses
  Printers, frxPrinter, frxSearchDialog, frxUtils, 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(PAnsiChar(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
  inherited Create(TfrxPageItem);
end;

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

procedure TfrxPageList.AddPage(AWidth, AHeight: Integer; Zoom: Extended);
begin
  with TfrxPageItem(Add) do
  begin
    Width := Round(AWidth * Zoom);
    Height := Round(AHeight * Zoom);
  end;
end;

procedure TfrxPageList.CalcBounds(ClientWidth: Integer);
var
  i, j, CurX, CurY, MaxY, offs: Integer;
  Item: TfrxPageItem;
begin
  FMaxWidth := 0;
  CurY := 10;
  i := 0;
  while i < Count do
  begin
    j := i;
    CurX := 0;
    MaxY := 0;
    { find series of pages that will fit in the clientwidth }
    { also calculate max height of series }
    while j < Count do
    begin
      Item := Items[j];
      { check the width, allow at least one iteration }
      if (CurX > 0) and (CurX + Item.Width > ClientWidth) then break;
      Item.OffsetX := CurX;
      Item.OffsetY := CurY;
      Inc(CurX, Item.Width + 10);
      if Item.Height > MaxY then
        MaxY := Item.Height;
      Inc(j);
    end;

    if CurX > FMaxWidth then
      FMaxWidth := CurX;

    { center series horizontally }
    offs := (ClientWidth - CurX + 10) div 2;
    if offs < 0 then
      offs := 0;
    Inc(offs, 10);
    while (i < j) do
    begin
      Inc(Items[i].OffsetX, offs);
      Inc(i);
    end;

    Inc(CurY, MaxY + 10);
  end;
end;

function TfrxPageList.FindPage(OffsetY: Integer; OffsetX: Integer = 0): Integer;
var
  i, i0, i1, c, add: Integer;
  Item: TfrxPageItem;
begin
  i0 := 0;
  i1 := Count - 1;

  while i0 <= i1 do
  begin
    i := (i0 + i1) div 2;
    if OffsetX <> 0 then
      add := 0 else
      add := Round(Items[i].Height / 5);
    if Items[i].OffsetY <= OffsetY + add then