print_preview.pas

delphi语言开发的矢量图形处理对象

{
This code is based on the code provided as ryPrev32 by
Ry
http://public.usit.net/rpetersn
[e-mail]

he wrote

This is an example of a a print preview system based on EMFs
With source. It will only work with Delphi 2 as it uses Enhanced Metafiles

I only ask that you give me some feedback if you like
it, hate it, or have some improvements.

///////////////////////////////////////////////////////////////////////////////
Heavily modified and almost totally redesigned by John Biddiscombe
               [e-mail] - Freeware.

Original code use a single metafile to store each page, this new code allows
multiple objects within pages and thus resizing of each via the strechhandles.
To make this work, I needed to use a windowed control, which I could add
child windows to, since the strechhandles need a control to latch on to.
Created TSingle_page object to contain each page metafiles list.
the Fmetafiles contains the individual objects and the
Fmetafile contains the final print that goes to the printer it is only used
at the final stage - created on request... since every time you change the
print setup, or move any objects or add any, it needs to be redrawn.
I also use it to show the mini preview in the dialogsetupbox, but only as
a rough guide since we'd need to add more callbacks to continually change
the metafile with every margin, paper change etc etc.

The original code had a paintbox, but it is a nonwindowd control, so can't
have any child controls. I needed a simple box, like a panel, but with a
canvas, which is why I've made the TPanelWithCanvas

The PanelWithCanvases are created at runtime, so do not need to be installed on
the component palette.
///////////////////////////////////////////////////////////////////////////////

}
unit Print_preview;

interface

uses
  { Borland }
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, Printers, ExtCtrls,Dialogs, ComCtrls, ToolWin, ImgList,
  { Mine }
  handles;

type
  double_rec = record x,y : double; end;
  TPSPaintWhat=(pwFullPage,pwGreekText);
  TPanelWithCanvas=class(TPanel)
     private
        fOnPaint:TNotifyEvent;
     protected
        procedure Paint;override;
     public
        property Canvas;
        property OnPaint:TNotifyEvent read fOnPaint write fOnPaint;
  end;
var
  PageSize_pixels     : TPoint;
  PageSize_inches     : double_rec;
  Margin_Size_pixels  : TPoint; // left, top
  Margin_Size_pixels2 : TPoint; // right,bottom
  Margin_Size_inches  : double_rec;
  Printer_ppi         : TPoint;
  Screen_ppi          : TPoint;

type
  TPrintPreview_form = class;
  Tsingle_page = class
    FCanvas     : TMetaFileCanvas;
    FMetaFile   : TMetaFile;
    FMetafiles  : TList;
    FControls   : TList;
    FRects      : TList;
    parent_form : TPrintPreview_form;
    constructor create(form_parent:TPrintPreview_form);
    destructor  destroy; override;
    procedure   add_metafile(tm:TMetafile;backcolor:tcolor; tr,rr:TRect; xs,ys:integer);
    function    GetMetaFile : TMetaFile;
    function    obj_count : integer;
    procedure   Special_Paint_handler(Sender: TObject);
    procedure   Special_Resize_handler(Sender: TObject);
    //2004.4.4 new add module
    procedure   Special_Mouse_handler(Sender:TObject; Button:TMouseButton; Shift:TShiftState; X,Y:Integer);

  end;

  TPrintout = class;
  TPrintPreview_form = class(TForm)
    Panel2: TPanel;
    sb: TScrollBox;
    Panel3: TPanel;
    SnapToGrid: TCheckBox;
    Edit1: TEdit;
    UpDown1: TUpDown;
    ToolBar1: TToolBar;
    firstBtn: TToolButton;
    PriorBtn: TToolButton;
    NextBtn: TToolButton;
    LastBtn: TToolButton;
    FullButton: TToolButton;
    printBtn: TToolButton;
    WidthButton: TToolButton;
    setupBtn: TToolButton;
    ToolButton9: TToolButton;
    ImageList1: TImageList;
    ToolButton1: TToolButton;
    closeButton: TToolButton;
    ToolButton2: TToolButton;
    procedure PrintBtnClick(Sender: TObject);
    procedure FirstBtnClick(Sender: TObject);
    procedure PriorBtnClick(Sender: TObject);
    procedure NextBtnClick(Sender: TObject);
    procedure LastBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FullButtonClick(Sender: TObject);
    procedure PaintAreaPaint(Sender: TObject);
    procedure WidthButtonClick(Sender: TObject);
    procedure SetupBtnClick(Sender: TObject);
    function PageSetupDialog1PaintPage(Sender: TObject;
      PaintWhat: TPSPaintWhat; Canvas: TCanvas; Rect: TRect): Boolean;
    procedure CloseButtonClick(Sender: TObject);
    procedure ClearBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ThisPageBtnClick(Sender: TObject);
   //2004.4.4 new add module
    procedure UpDown1Changing(Sender: TObject; var AllowChange: Boolean);
    procedure SnapToGridClick(Sender: TObject);
    procedure StretchHandle1Moved(Sender: TObject);

  private
    { Private declarations }

    StretchHandle1   : TStretchHandle;

    PaintArea        : TPanelWithCanvas;
    PageSetupDialog1 : TPageSetupDialog;
    PrintOut         : TPrintout;
    PageDisplaying   : Integer;
    fullmode         : boolean;
  public
    { Public declarations }
  end;

  TPrintout = class(TObject)
  private
    { Private declarations }
    FPages         : TList; // of single_pages
    FCurrentPage   : Integer;
    Flastpage      : integer;
    Flastscale     : double;
    Print_Preview  : TPrintPreview_form;
    function  GetPageCount : Integer;
    procedure SetCurrentPage(Index : Integer);
    function  GetMetafile(Index : Integer): TMetafile;
  protected
    { Protected declarations }
  public
    { Public declarations }
    Title       : String;
    constructor Create;
    destructor  Destroy; override;
    procedure   PrintAll;
    procedure   PrintPage(pagenum:integer);
    procedure   Preview;
    procedure   rescale_objects(scale:double; page:integer);
    procedure   DisplayPage(Page : Integer);
    procedure   PrinterSetupChanged;
    procedure   ClearPrintBuff;
    function    NewPage : Integer;
    property    PageCount : Integer  read GetPageCount;
    property    CurrentPage : Integer read FCurrentPage write SetCurrentPage;
    property    Metafiles[Index : Integer] : TMetafile read GetMetafile;
    procedure   add_metafile(pagenum:integer; tm:TMetafile; abcolor:tcolor;ox,oy:double);
  end;

implementation

{$R *.DFM}

///////////////////////////////////////////////////////////////////////////////
// TSingle page - one canvas with a list of (source) metafiles...
// ...and a canvas metafile
///////////////////////////////////////////////////////////////////////////////
constructor Tsingle_page.create(form_parent:TPrintPreview_form);
begin
  inherited Create;
  FMetaFile   := nil;
  FCanvas     := nil;
  FMetafiles  := TList.Create;
  FControls   := TList.Create;
  FRects      := TList.Create;
  parent_form := form_parent;
end;

destructor Tsingle_page.Destroy;
var i : Integer;
begin
  for i := FMetafiles.Count - 1 downto 0 do TMetafile(FMetafiles[i]).Free;
  FMetafiles.Clear;
  FMetafiles.Free;
  for i := FControls.Count - 1  downto 0 do TControl(FControls[i]).Free;
  FControls.Clear;
  FControls.Free;
  for i := FRects.Count - 1     downto 0 do Freemem(FRects[i],sizeof(Trect));
  FRects.Clear;
  FCanvas.free;
  FMetaFile.Free;
  inherited Destroy;
end;

function Tsingle_page.GetMetaFile : TMetaFile;
var lp1 : integer;
begin
  if FMetaFile<>nil then FMetaFile.Free;
  FMetaFile := TMetafile.Create;
  with FMetaFile do begin
    width  := PageSize_pixels.x;//-(Margin_Size_pixels.x+Margin_Size_pixels2.x);
    height := PageSize_pixels.y;//-(Margin_Size_pixels.y+Margin_Size_pixels2.y);
  end;
  FCanvas := TMetafileCanvas.Create(FMetaFile,0);
  for lp1:=0 to FMetafiles.count-1 do
    FCanvas.StretchDraw(PRect(FRects[lp1])^,TMetaFile(FMetaFiles[lp1]));
  FCanvas.Free;
  FCanvas := nil;
  Result := FMetaFile;
end;

procedure Tsingle_page.add_MetaFile(tm:TMetaFile;backcolor:tcolor; tr,rr:TRect; xs,ys:integer);
var inx : integer;
    tp  : TPanelWithCanvas;
    pr  : PRect;
begin
  // add metafile to list
  inx := FmetaFiles.add(tm);
  // create a control to hold the metafile for resizing on screen
  tp := TPanelWithCanvas.Create(nil);
  with tp do begin
    color       := backcolor;
    BorderStyle := bsNone;
    BevelInner  := bvNone;
    BevelOuter  := bvNone;
    Tag         := integer(tm);
    OnPaint     := Special_Paint_handler;
    OnResize    := Special_Resize_handler;

    OnMouseDown := Special_Mouse_handler;
    
    SetBounds(rr.left, rr.top,(rr.right-rr.left), (rr.bottom-rr.top));
  end;
  FControls.add(tp);
  // Add rect of metafile to list
  GetMem(pr,sizeof(TRect));
  pr^ := tr;
  FRects.add(pr);
end;

function Tsingle_page.obj_count : integer;
begin
  result := FMetafiles.count;
end;

procedure Tsingle_page.Special_Paint_handler(Sender: TObject);
begin
  with sender as TPanelWithCanvas do begin
    Canvas.StretchDraw(ClientRect,TMetafile(Tag));
  end;
end;

procedure Tsingle_page.Special_Resize_handler(Sender: TObject);
var inx   : integer;
    scale : double;
begin
  inx    := FControls.Indexof(sender);
  scale  := parent_form.PaintArea.Width / PageSize_pixels.X;
  with PRect(FRects[inx])^ do begin
    left   := round(TControl(sender).left/scale);
    right  := round(TControl(sender).width/scale)+left;
    top    := round(TControl(sender).top/scale);
    bottom := round(TControl(sender).height/scale)+top;
  end;
end;
///////////////////////////////////////////////////////////////////////////////
// TPrintout - a collection of pages
///////////////////////////////////////////////////////////////////////////////
constructor TPrintout.Create;
begin
  inherited Create;
  FPages                       := TList.Create;
  FCurrentPage                 := 0;
  Print_Preview                := TPrintPreview_form.Create(Application);
  Print_Preview.PrintOut       := Self;
  Print_Preview.PageDisplaying := 1;
  Flastpage                    := -1;
  Title                        := 'Print job fromPrint Preview module';
  ClearPrintBuff;
end;

destructor TPrintout.Destroy;
var i : Integer;
begin
  for i := Fpages.Count - 1 downto 0 do Tsingle_page(FPages[i]).Free;
  if Printer.Printing then Printer.Abort;
  inherited Destroy;
end;

function TPrintout.GetPageCount : Integer;
begin
  Result := FPages.Count;
end;

procedure TPrintout.SetCurrentPage(Index : Integer);
begin
  if (Index <= PageCount) AND (Index > 0) then FCurrentPage := Index;
end;

function TPrintout.GetMetafile(Index : Integer): TMetafile;
begin
  if (Index > 0) AND (Index <= PageCount) then result := TSingle_page(FPages[Index - 1]).GetMetaFile
  else Result := nil;
end;

procedure TPrintout.PrintAll;
var i : Integer;
    s : String;
begin
  if PageCount > 0 then begin
    Printer.Title := Title;
    if not Printer.Printing then Printer.BeginDoc;
    i := 1;
    if Assigned(Print_Preview) then s := Print_Preview.Panel2.Caption;
    try
      if Assigned(Print_Preview) then begin
        Print_Preview.Panel2.Caption := Format('Printing page %d of %d',[1, PageCount]);
        Print_Preview.Panel2.repaint;
      end;
      Printer.Canvas.StretchDraw(Rect(0,0,Printer.PageWidth, Printer.PageHeight), Metafiles[i]);
      for i := 2 to PageCount do begin
        if Assigned(Print_Preview) then begin
          Print_Preview.Panel2.Caption := Format('Printing page %d of %d',[i, PageCount]);
          Print_Preview.Panel2.repaint;
        end;
        Printer.NewPage;
        Printer.Canvas.StretchDraw(Rect(0,0,Printer.PageWidth, Printer.PageHeight), Metafiles[i]);
      end;
    finally
      Printer.EndDoc;
      if Assigned(Print_Preview) then Print_Preview.Panel2.Caption := s;
    end;
  end;
end;

procedure TPrintout.PrintPage(pagenum:integer);