gmpreview.pas

此控件可轻松制作报表及打印预览等功能

{******************************************************************************}
{                                                                              }
{                           TGmPreview 1.0                                     }
{                                                                              }
{           Copyright (c) 2000 Graham Murt  - www.MurtSoft.com                 }
{                                                                              }
{      Feel free to e-mail me with any comments, suggestions or help at:       }
{                                                                              }
{                           [e-mail]                                   }
{                                                                              }
{******************************************************************************}


unit GmPreview;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Printers, dsgnintf;

const
  ABOUT_GMREPORT = 'TGmPrinter - (c) Graham Murt 2000';
  VERSION = '1.0 Lite';
  MmPerInch     = 25.4;
  DefaultDPI    = 300;

type
  TGmType = (gmRectangle, gmEllipse, gmText, gmPicture, gmLine, gmTable);

  TGmFont = record
    Name  : string;
    Size  : integer;
    Color : TColor;
    Style : TFontStyles;
  end;

  TGmPen = record
    Style : TPenStyle;
    Width : integer;
    Color : TColor;
  end;

  TGmBrush = record
    Color : TColor;
    Style : TBrushStyle;
  end;

  PGmMetaFileRec = ^TGmMetaFileRec;
  TGmMetaFileRec = record
    left    : integer;
    top     : integer;
    right   : integer;
    bottom  : integer;
    rows    : integer;
    cols    : integer;
    Text    : string;
    gmType  : TGmType;
    gmFont  : TGmFont;
    gmBrush : TGmBrush;
    gmPen   : TGmPen;
    Page    : integer;
    Graphic : TPicture;
  end;

  TGmPreview = class;

  TGmHeaderFooter = class(TPersistent)
  private
    FText: string;
    FFont: TFont;
    FBrush: TBrush;
    FLine: TPen;
    FParent: TGmPreview;
    FShowLine: Boolean;
    FVisible: Boolean;
    procedure SetText(Value: string);
    procedure SetFont(Value: TFont);
    procedure SetBrush(Value: TBrush);
    procedure SetLine(Value: TPen);
    procedure SetShowLine(Value: Boolean);
    procedure SetVisible(Value: Boolean);
    procedure OnFontChange(Sender: TObject);
    procedure OnBrushChange(Sender: TObject);
    procedure OnLineChange(Sender: TObject);
  public
    constructor Create(AOwner: TGmPreview; AInitialText: string);
    destructor Destroy; override;
  published
    property Text: string read FText write SetText;
    property Font: TFont read FFont write SetFont;
    property Brush: TBrush read FBrush write SetBrush;
    property Line: TPen read FLine write SetLine;
    property ShowLine: Boolean read FShowLine write SetShowLine default True;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

  TGmMargin = class(TPersistent)
  private
    FMarginColor: TColor;
    FParent: TGmPreview;
    FShowMargins: Boolean;
    procedure SetMarginColor(AColor: TColor);
    procedure SetShowMargins(AValue: Boolean);
  public
    constructor Create(AOwner: TGmPreview);
    destructor Destroy; override;
  published
    property MarginColor: TColor read FMarginColor write SetMarginColor default clSilver;
    property ShowMargins: Boolean read FShowMargins write SetShowMargins default True;
  end;

  TGmCanvas = TMetafileCanvas;

  TGmPages = TList;
  TGmPageDefs = TList;

  TGmPreview = class(TScrollingWinControl)
  private
    // TGmPreview...
    FAbout: string;
    FAllowMouseZoom: boolean;
    FCanvas: TGmCanvas;
    FCanvasFont: TFont;
    FCanvasBrush: TBrush;
    FCanvasPen: TPen;
    FCurrentPage: integer;
    FFooter: TGmHeaderFooter;
    FHeader: TGmHeaderFooter;
    FLastCanvasFont: TFont;
    FLastCanvasBrush: TBrush;
    FLastCanvasPen: TPen;
    FMargin: TGmMargin;
    FPage: TMetafile;
    FPages: TGmPages;
    FPageDefs: TGmPageDefs;
    FPaintBox: TPaintBox;
    FPreviewWidth: integer;
    FPreviewHeight: integer;
    FPrintCollate: Boolean;
    FPrintCopies: integer;
    FPrinter: TPrinter;
    FShadowColor: TColor;
    FShadowWidth: integer;
    FShowShadow: Boolean;
    FZoom: integer;

    FAfterPrint: TNotifyEvent;
    FBeforePrint: TNotifyEvent;
    FOnAbortPrint: TNotifyEvent;
    FOnClear: TNotifyEvent;
    FOnPageChange: TNotifyEvent;
    FOnPageDraw: TNotifyEvent;
    FOnPrintProgress: TNotifyEvent;
    FOnNewPage: TNotifyEvent;
    FOnZoom: TNotifyEvent;

    function GetMarginLeft: integer;
    function GetMarginTop: integer;
    function GetMarginRight: integer;
    function GetMarginBottom: integer;
    function GetMarginRect: TRect;
    function GetNumPages: integer;
    function GetAvailablePageWidth: integer;
    function GetAvailablePageHeight: integer;
    function GetPhysicalPrinterWidth: integer;
    function GetPhysicalPrinterHeight: integer;
    procedure PaintPreview(Sender: TObject); // OnPaint handler for TPaintBox;
    procedure PaintBoxMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);

    procedure SetCanvasBrush(AValue: TBrush);
    procedure SetCanvasFont(AValue: TFont);
    procedure SetCanvasPen(AValue: TPen);

    procedure SetCurrentPage(APage: integer);
    procedure SetShadowColor(AValue: TColor);
    procedure SetShadowWidth(AValue: integer);
    procedure SetShowShadow(AValue: boolean);
    procedure SetZoom(AValue: integer);
    procedure UpdateDimensions(AScaleFactor: double);
  protected
    function GetPrinterToPreviewH(AValue: integer): integer;
    function GetPrinterToPreviewV(AValue: integer): integer;
    function PrinterMmToPixelsX(AValue: double): integer;
    function PrinterMmToPixelsY(AValue: double): integer;
    function PrinterPixelsToMmX(AValue: integer): double;
    function PrinterPixelsToMmY(AValue: integer): double;

    procedure CanvasPropertiesToRec(ARec: PGmMetaFileRec);
    procedure ShowAbout;
    procedure WriteFooter;
    procedure WriteHeader;
    procedure FreeAllPages;
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function NewPage: integer;    // returns the number of the page added...
    procedure Clear;

    procedure RedrawPage;
    procedure MmLine(X,Y, X2, Y2: double);
    procedure MmEllipse(X,Y,X2,Y2: double);
    procedure MmRectangle(X,Y,X2,Y2: double);
    procedure MmTable(X,Y,X2,Y2: double; ARows,ACols: integer);
    procedure MmDraw(X,Y: double; AGraphic: TPicture);
    procedure MmTextOut(X,Y: double; AText: string);
    procedure FirstPage;
    procedure PrevPage;
    procedure NextPage;
    procedure LastPage;
    procedure Print;

    property AvailablePageWidth: integer read GetAvailablePageWidth;
    property AvailablePageHeight: integer read GetAvailablePageHeight;
    property CanvasBrush: TBrush read FCanvasBrush write SetCanvasBrush;
    property CanvasFont: TFont read FCanvasFont write SetCanvasFont;
    property CanvasPen: TPen read FCanvasPen write SetCanvasPen;
    property CurrentPage: integer read FCurrentPage write SetCurrentPage;
    property MarginLeft: integer read GetMarginLeft;
    property MarginTop: integer read GetMarginTop;
    property MarginRight: integer read GetMarginRight;
    property MarginBottom: integer read GetMarginBottom;
    property MarginRect: TRect read GetMarginRect;
    property NumCopies: integer read FPrintCopies write FPrintCopies;
    property NumPages: integer read GetNumPages;  // read only
    property PhysicalPrinterWidth: integer read GetPhysicalPrinterWidth;
    property PhysicalPrinterHeight: integer read GetPhysicalPrinterHeight;

    { Public declarations }
  published
    property About: string read FAbout write FAbout stored False;
    property Align;
    property AllowMouseZoom: boolean read FAllowMouseZoom write FAllowMouseZoom default True;
    property AutoScroll;
    property CollatePrinting: Boolean read FPrintCollate write FPrintCollate default True;
    property Color;
    property Enabled;
    property Footer: TGmHeaderFooter read FFooter write FFooter;
    property Header: TGmHeaderFooter read FHeader write FHeader;
    property Margins: TGmMargin read FMargin write FMargin;
    property ParentColor;
    property PopupMenu;
    property ShadowColor: TColor read FShadowColor write SetShadowColor default clBlack;
    property ShadowWidth: integer read FShadowWidth write SetShadowWidth default 3;
    property ShowShadow: Boolean read FShowShadow write SetShowShadow default True;
    property Tag;
    property Visible;
    property Zoom: integer read FZoom write SetZoom default 25;

    property BeforePrint: TNotifyEvent read FBeforePrint write FBeforePrint;
    property AfterPrint: TNotifyEvent read FAfterPrint write FAfterPrint;
    property OnAbortPrint: TNotifyEvent read FOnAbortPrint write FOnAbortPrint;
    property OnClear: TNotifyEvent read FOnClear write FOnClear;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnNewPage: TNotifyEvent read FOnNewPage write FOnNewPage;
    property OnPageChange: TNotifyEvent read FOnPageChange write FOnPageChange;
    property OnPageDraw: TNotifyEvent read FOnPageDraw write FOnPageDraw;
    property OnPrintProgress: TNotifyEvent read FOnPrintProgress write FOnPrintProgress;
    property OnStartDrag;
    property OnZoom: TNotifyEvent read FOnZoom write FOnZoom;
{ Published declarations }
  end;

procedure Register;

implementation

//------------------------------------------------------------------------------

// object inspector "About" property...

type
  TAboutProperty = class(TPropertyEditor)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue:string; override;
  end;

procedure TAboutProperty.Edit;
{call the 'About' dialog window when clicking on ... in the Object Inspector}
begin
  TGmPreview(GetComponent(0)).ShowAbout;
end;

function TAboutProperty.GetAttributes: TPropertyAttributes;
{set up to display a string in the Object Inspector}
begin
  GetAttributes := [paDialog, paReadOnly];
end;

function TAboutProperty.GetValue: String;
{set string to appear in the Object Inspector}
begin
  GetValue := '(About)';
end;

procedure TGmPreview.ShowAbout;
var
  Msg: string;
begin
  Msg := 'TGmPreview Component for Delphi'+#13+
         'Version '+VERSION+#13+#13+
         'Copyright