fr_view.pas

1、开发环境 d6 up2,sqlserver2000, win2000 server 1024*768（笔记本电脑） c/s 2、数据库配置方法

{******************************************}
{                                          }
{             FastReport v2.4              }
{             Report preview               }
{                                          }
{ Copyright (c) 1998-2001 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_View;

interface

{$I FR.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Buttons, StdCtrls, Menus, FR_Ctrls, FR_Dock, FR_Const;

type
  TfrPreviewForm = class;
  TfrPreview = class;
  TfrPreviewZoom = (pzDefault, pzPageWidth, pzOnePage, pzTwoPages);
  TfrPreviewButton = (pbZoom, pbLoad, pbSave, pbPrint, pbFind, pbHelp, pbExit, pbPageSetup);
  TfrPreviewButtons = set of TfrPreviewButton;

  TfrPageChangedEvent = procedure(Sender: TfrPreview; PageNo: Integer) of object;

  TfrPreview = class(TPanel)
  private
    FWindow: TfrPreviewForm;
    FScrollBars: TScrollStyle;
    FShowToolbar: Boolean;
    FOnPageChanged: TfrPageChangedEvent;
    procedure WMSize(var Message: TMessage); message WM_WINDOWPOSCHANGED;
    function GetPage: Integer;
    procedure SetPage(Value: Integer);
    function GetZoom: Double;
    procedure SetZoom(Value: Double);
    function GetAllPages: Integer;
    procedure SetScrollBars(Value: TScrollStyle);
    procedure SetShowToolbar(Value: Boolean);
    procedure OnInternalPageChanged(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect(Doc: Pointer);
    procedure Disconnect;
    procedure OnePage;
    procedure TwoPages;
    procedure PageWidth;
    procedure First;
    procedure Next;
    procedure Prev;
    procedure Last;
    procedure SaveToFile;
    procedure LoadFromFile;
    procedure Print;
    procedure PageSetupDlg;
    procedure Edit;
    procedure Find;
    procedure Clear;
    procedure LoadFile(Name: String);
    property AllPages: Integer read GetAllPages;
    property Page: Integer read GetPage write SetPage;
    property Zoom: Double read GetZoom write SetZoom;
    property Window: TfrPreviewForm read FWindow write FWindow;
  published
    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;
    property ShowToolbar: Boolean read FShowToolbar write SetShowToolbar default False;
    property OnPageChanged: TfrPageChangedEvent read FOnPageChanged write FOnPageChanged;
  end;

  TfrPBox = class(TPanel)
  private
    Down, DFlag: Boolean;
    LastX, LastY: Integer;
    LastClick: Integer;
  public
    Preview: TfrPreviewForm;
    procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
    procedure Paint; 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 DblClick; override;
  end;

  TfrScaleMode = (mdNone, mdPageWidth, mdOnePage, mdTwoPages);

  TfrPreviewForm = class(TForm)
    TPanel: TPanel;
    ProcMenu: TPopupMenu;
    N2001: TMenuItem;
    N1501: TMenuItem;
    N1001: TMenuItem;
    N751: TMenuItem;
    N501: TMenuItem;
    N251: TMenuItem;
    N101: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    Bevel2: TBevel;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    PreviewPanel: TPanel;
    ScrollBox1: TScrollBox;
    RPanel: TPanel;
    PgUp: TfrSpeedButton;
    PgDown: TfrSpeedButton;
    VScrollBar: TScrollBar;
    BPanel: TPanel;
    Bevel1: TBevel;
    Label1: TLabel;
    HScrollBar: TScrollBar;
    Panel1: TPanel;
    ZoomBtn: TfrTBButton;
    frTBSeparator1: TfrTBSeparator;
    LoadBtn: TfrTBButton;
    SaveBtn: TfrTBButton;
    PrintBtn: TfrTBButton;
    frTBSeparator2: TfrTBSeparator;
    FindBtn: TfrTBButton;
    HelpBtn: TfrTBButton;
    frTBSeparator3: TfrTBSeparator;
    ExitBtn: TfrTBButton;
    PageSetupBtn: TfrTBButton;
    procedure FormResize(Sender: TObject);
    procedure VScrollBarChange(Sender: TObject);
    procedure HScrollBarChange(Sender: TObject);
    procedure PgUpClick(Sender: TObject);
    procedure PgDownClick(Sender: TObject);
    procedure ZoomBtnClick(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure ExitBtnClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
    procedure PrintBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FindBtnClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure EditBtnClick(Sender: TObject);
    procedure DelPageBtnClick(Sender: TObject);
    procedure NewPageBtnClick(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormActivate(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure HScrollBarEnter(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure PageSetupBtnClick(Sender: TObject);
  private
    { Private declarations }
    PBox: TfrPBox;
    CurPage: Integer;
    ofx, ofy, OldV, OldH: Integer;
    per: Double;
    mode: TfrScaleMode;
    PaintAllowed: Boolean;
    FindStr: String;
    CaseSensitive: Boolean;
    StrFound: Boolean;
    StrBounds: TRect;
    LastFoundPage, LastFoundObject: Integer;
    HF: String;
    FOnPageChanged: TNotifyEvent;
    KWheel: Integer;
    procedure ShowPageNum;
    procedure SetToCurPage;
    procedure RedrawAll(ResetPage: Boolean);
    procedure LoadFromFile(name: String);
    procedure SaveToFile(name: String);
    procedure FindInEMF(emf: TMetafile);
    procedure FindText;
    procedure SetGrayedButtons(Value: Boolean);
    procedure InitButtons;
    procedure Localize;
    property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
{$IFDEF Delphi4}
    procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
{$ENDIF}
  public
    { Public declarations }
    Doc: Pointer;
    EMFPages: Pointer;
    procedure Connect(ADoc: Pointer);
    procedure ConnectBack;
    procedure Show_Modal(ADoc: Pointer);
  end;


implementation

{$R *.DFM}

uses
  FR_Class, Printers, FR_Prntr, FR_Srch, Registry, FR_PrDlg, FR_Utils, CommDlg;

type
  THackControl = class(TControl)
  end;

var
  LastScale: Double = 1;
  LastScaleMode: TfrScaleMode = mdNone;
  CurPreview: TfrPreviewForm;
  RecordNum: Integer;


{----------------------------------------------------------------------------}
constructor TfrPreview.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWindow := TfrPreviewForm.Create(nil);
  FWindow.OnPageChanged := OnInternalPageChanged;
  FWindow.Localize;
  BevelInner := bvNone;
  BevelOuter := bvLowered;
  ScrollBars := ssBoth;
end;

destructor TfrPreview.Destroy;
begin
  FWindow.Free;
  inherited Destroy;
end;

procedure TfrPreview.WMSize(var Message: TMessage);
begin
  inherited;
  FWindow.FormResize(nil);
end;

{$HINTS OFF}
procedure TfrPreview.Connect(Doc: Pointer);
var
  f: TForm;
begin
  FWindow.PreviewPanel.Parent := Self;
  if FShowToolbar then
    FWindow.TPanel.Parent := Self;
  FWindow.PreviewPanel.Show;
  FWindow.Connect(Doc);
  FWindow.InitButtons;
  FWindow.RedrawAll(True);
  if PopupMenu <> nil then
    FWindow.PopupMenu := PopupMenu;
{$IFDEF Delphi4}
  f := TForm(GetParentForm(Self));
  if f <> nil then
  begin
    f.OnMouseWheelUp := FWindow.FormMouseWheelUp;
    f.OnMouseWheelDown := FWindow.FormMouseWheelDown;
    FWindow.KWheel := 3;
  end;
{$ENDIF}
end;
{$HINTS ON}

procedure TfrPreview.Disconnect;
begin
  FWindow.ConnectBack;
end;

function TfrPreview.GetPage: Integer;
begin
  Result := FWindow.CurPage;
end;

procedure TfrPreview.SetPage(Value: Integer);
begin
  if (Value < 1) or (Value > AllPages) then Exit;
  FWindow.CurPage := Value;
  FWindow.SetToCurPage;
end;

function TfrPreview.GetZoom: Double;
begin
  Result := FWindow.Per * 100;
end;

procedure TfrPreview.SetZoom(Value: Double);
begin
  FWindow.Per := Value / 100;
  FWindow.Mode := mdNone;
  LastScale := FWindow.Per;
  LastScaleMode := FWindow.Mode;
  FWindow.FormResize(nil);
  FWindow.PBox.Paint;
end;

function TfrPreview.GetAllPages: Integer;
begin
  Result := 0;
  if TfrEMFPages(FWindow.EMFPages) <> nil then
    Result := TfrEMFPages(FWindow.EMFPages).Count;
end;

procedure TfrPreview.SetScrollBars(Value: TScrollStyle);
begin
  FScrollBars := Value;
  FWindow.RPanel.Visible := (Value = ssBoth) or (Value = ssVertical);
  FWindow.BPanel.Visible := (Value = ssBoth) or (Value = ssHorizontal);
end;

procedure TfrPreview.SetShowToolbar(Value: Boolean);
begin
  FShowToolbar := Value;
  if FShowToolbar then
    FWindow.TPanel.Parent := Self else
    FWindow.TPanel.Parent := FWindow;
end;

procedure TfrPreview.OnePage;
begin
  FWindow.Mode := mdOnePage;
  LastScaleMode := FWindow.Mode;
  FWindow.FormResize(nil);
  FWindow.PBox.Paint;
end;

procedure TfrPreview.TwoPages;
begin
  FWindow.Mode := mdTwoPages;
  LastScaleMode := FWindow.Mode;
  FWindow.FormResize(nil);
  FWindow.PBox.Paint;
end;

procedure TfrPreview.PageWidth;
begin
  FWindow.Mode := mdPageWidth;
  LastScaleMode := FWindow.Mode;
  FWindow.FormResize(nil);
  FWindow.PBox.Paint;
end;

procedure TfrPreview.First;
begin
  Page := 1;
end;

procedure TfrPreview.Next;
begin
  Page := Page + 1;
end;

procedure TfrPreview.Prev;
begin
  Page := Page - 1;
end;

procedure TfrPreview.Last;
begin
  Page := AllPages;
end;

procedure TfrPreview.SaveToFile;
begin
  FWindow.SaveBtnClick(nil);
end;

procedure TfrPreview.LoadFromFile;
begin
  FWindow.LoadBtnClick(nil);
end;

procedure TfrPreview.Print;
begin
  FWindow.PrintBtnClick(nil);
end;

procedure TfrPreview.PageSetupDlg;
begin
  FWindow.PageSetupBtnClick(nil);
end;

procedure TfrPreview.Edit;
begin
  FWindow.EditBtnClick(nil);
end;

procedure TfrPreview.Find;
begin
  FWindow.FindBtnClick(nil);
end;

procedure TfrPreview.Clear;
begin
  if FWindow.EMFPages <> nil then
  begin
    TfrEMFPages(FWindow.EMFPages).Free;
    FWindow.EMFPages := nil;
    FWindow.PreviewPanel.Hide;
    FWindow.RedrawAll(True);
  end;
end;

procedure TfrPreview.LoadFile(Name: String);
begin
  if FileExists(Name) then
    FWindow.LoadFromFile(Name) else
    Clear;
end;

procedure TfrPreview.OnInternalPageChanged(Sender: TObject);
begin
  if Assigned(FOnPageChanged) then
    FOnPageChanged(Self, Page);
end;

{----------------------------------------------------------------------------}
procedure TfrPBox.WMEraseBackground(var Message: TMessage);
begin
end;

procedure TfrPBox.Paint;
var
  i: Integer;
  r, r1: TRect;
  Pages: TfrEMFPages;
  h: HRGN;
begin
  if not Preview.PaintAllowed then Exit;
  if Preview.EMFPages = nil then
  begin
    Canvas.Brush.Color := clBtnFace;
    Canvas.FillRect(ClientRect);
    Exit;
  end;
  Pages := TfrEMFPages(Preview.EMFPages);
  h := CreateRectRgn(0, 0, Width, Height);
  GetClipRgn(Canvas.Handle, h);

  for i := 0 to Pages.Count - 1 do            // drawing window background
  begin
    r := Pages[i].r;
    OffsetRect(r, Preview.ofx, Preview.ofy);
    if (r.Top > 2000) or (r.Bottom < 0) then
      Pages[i].Visible := False else
      Pages[i].Visible := RectVisible(Canvas.Handle, r);
    if Pages[i].Visible then
      ExcludeClipRect(Canvas.Handle, r.Left + 1, r.Top + 1, r.Right - 1, r.Bottom - 1);
  end;
  with Canvas do
  begin
    Brush.Color := clGray;
    FillRect(Rect(0, 0, Width, Height));
    Pen.Color := clBlack;
    Pen.Width := 1;
    Pen.Mode := pmCopy;
    Pen.Style := psSolid;
    Brush.Color := clWhite;
  end;

  SelectClipRgn(Canvas.Handle, h);
  for i := 0 to Pages.Count - 1 do            // drawing page background
    if Pages[i].Visible then
    begin
      r := Pages[i].r;
      OffsetRect(r, Preview.ofx, Preview.ofy);
      Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom);
      Canvas.Polyline([Point(r.Left + 1, r.Bottom),
                       Point(r.Right, r.Bottom),
                       Point(r.Right, r.Top + 1)]);
    end;

  for i := 0 to Pages.Count - 1 do           // drawing page content
  begin
    if Pages[i].Visible then
    begin
      r := Pages[i].r;
      OffsetRect(r, Preview.ofx, Preview.ofy);
      if Pages[i].UseMargins then
        Pages.Draw(i, Canvas, r)
      else
      begin
        with Preview, Pages[i].PrnInfo, Pages[i].pgMargins do
        begin
          r1.Left := Round((Ofx + Left) * per);
          r1.Top := Round((Ofy + Top) * per);