无论什么,满足功能就行。打印预览。自己画线的。可能需要画布。
下面是源码,有心人请试试吧,拜托了!
unit Preview;
{
TPrintPreview v1.1 &
TPaperPreview v1.0 for Delphi
by Kambiz R. Khojasteh
mail: khojasteh@www.dci.co.ir
web: http://www.crosswinds.net/~khojasteh/
This component is freeware and may be used in any software product (free or commercial).
}
interface
uses
{$IFDEF WIN32} Windows, {$else
} WinTypes, WinProcs, {$ENDIF} Messages,
Classes, Graphics, Controls, SysUtils, Forms, Dialogs, StdCtrls, ExtCtrls,
Menus, Printers;
type
{ TPaperPreview }
TPaperPaintEvent = procedure(Sender: TObject;
Canvas: TCanvas;
PageRect: TRect) of object;
TPaperPreview = class(TCustomControl)
private
FPaperColor: TColor;
FBorderColor: TColor;
FBorderSize: TBorderWidth;
FShadowColor: TColor;
FShadowSize: TBorderWidth;
FOnResize: TNotifyEvent;
FOnPaint: TPaperPaintEvent;
procedure SetPaperWidth(Value: Integer);
function GetPaperWidth: Integer;
procedure SetPaperHeight(Value: Integer);
function GetPaperHeight: Integer;
procedure SetPaperColor(Value: TColor);
procedure SetBorderColor(Value: TColor);
procedure SetBorderSize(Value: TBorderWidth);
procedure SetShadowColor(Value: TColor);
procedure SetShadowSize(Value: TBorderWidth);
protected
property Canvas;
procedure Paint;
override;
function PageRect: TRect;
dynamic;
procedure WMSize(var Message: TWMSize);
message WM_SIZE;
procedure WMEraseBkGnd(var Message: TWMEraseBkGnd);
message WM_ERASEBKGND;
public
constructor Create(AOwner: TComponent);
override;
published
property Align;
property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
property BorderSize: TBorderWidth read FBorderSize write SetBorderSize default 1;
property Color;
property Cursor;
property DragCursor;
property DragMode;
property ParentColor;
property ParentShowHint;
property PopupMenu;
property PaperColor: TColor read FPaperColor write SetPaperColor default clWhite;
property PaperWidth: Integer read GetPaperWidth write SetPaperWidth;
property PaperHeight: Integer read GetPaperHeight write SetPaperHeight;
property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
property ShadowSize: TBorderWidth read FShadowSize write SetShadowSize default 3;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDRop;
property OnDragOver;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize: TNotifyEvent read FOnResize write FOnResize;
property OnPaint: TPaperPaintEvent read FOnPaint write FOnPaint;
end;
{ TPrintPreview}
TPreviewPrintProgress = procedure(Sender: TObject;
PageNum, Progress: Integer;
var AbortIt: Boolean) of object;
TPreviewState = (psReady, psCreating, psPrinting);
TZoomState = (zsZoomOther, zsZoomToWidth, zsZoomToHeight, zsZoomToFit);
TUnits = (mmPixel, mmLoMetric, mmHiMetric, mmLoEnglish, mmHiEnglish, mmTWIPS);
TPrintPreview = class(TCustomPanel)
private
FClient: TPanel;
FHorzScrollBar: TScrollBar;
FVertScrollBar: TScrollBar;
FPaperView: TPaperPreview;
FPrintJobTitle: String;
FPages: TList;
FCanvas: TCanvas;
FUnits: TUnits;
FResulotion: TBorderWidth;
FUsePrinterRes: Boolean;
FPixelsPerInch: TPoint;
FPixels: TPoint;
FGutter: Integer;
FAborted: Boolean;
FMarginLeft: Integer;
FMarginRight: Integer;
FMarginTop: Integer;
FMarginBottom: Integer;
FOrientation: TPrinterOrientation;
FCurrentPage: Integer;
FPaperWidth: Integer;
FPaperHeight: Integer;
FState: TPreviewState;
FZoom: Integer;
FZoomState: TZoomState;
FOnbegin
Doc: TNotifyEvent;
FOnEndDoc: TNotifyEvent;
FOnNewPage: TNotifyEvent;
FOnAbort: TNotifyEvent;
FOnChange: TNotifyEvent;
FOnPrintProgress: TPreviewPrintProgress;
FOnBeforePrint: TNotifyEvent;
FOnAfterPrint: TNotifyEvent;
procedure SetAbout(Value: String);
function GetAbout: String;
procedure SetUnits(Value: TUnits);
procedure SetResulotion(Value: TBorderWidth);
procedure SetUsePrinterRes(Value: Boolean);
procedure SetMarginLeft(Value: Integer);
procedure SetMarginRight(Value: Integer);
procedure SetMarginTop(Value: Integer);
procedure SetMarginBottom(Value: Integer);
procedure SetPaperWidth(Value: Integer);
procedure SetPaperHeight(Value: Integer);
procedure SetOrientation(Value: TPrinterOrientation);
procedure SetZoomState(Value: TZoomState);
procedure SetZoom(Value: Integer);
procedure SetCurrentPage(Value: Integer);
function GetTotalPages: Integer;
function GetPageWidth: Integer;
function GetPageHeight: Integer;
function GetPageRect: TRect;
function GetPages(PageNo: Integer): TMetaFile;
function GetCanvas: TCanvas;
procedure CreateMetaFileCanvas;
function DestroyMetaFileCanvas: TMetaFile;
procedure ResetPrinter;
procedure UpdatePrinterParameters;
procedure VScroll(Sender: TObject);
procedure HScroll(Sender: TObject);
procedure AdjustCanvasView;
protected
procedure WMWinIniChange(var Message: TMessage);
message WM_WININICHANGE;
procedure Loaded;
override;
procedure Resize;
override;
procedure KeyDown(var Key: Word;
Shift: TShiftState);
override;
procedure PaintPage(Sender: TObject;
Canvas: TCanvas;
PageRect: TRect);
dynamic;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
function Pixel2Units(Value: Integer): Integer;
procedure Clear;
procedure begin
Doc;
procedure EndDoc;
procedure NewPage;
procedure Abort;
procedure Print;
procedure UpdateZoom;
procedure PrintPages(StartPage, StopPage: Integer);
property Aborted: Boolean read FAborted;
property Canvas: TCanvas read GetCanvas;
property TotalPages: Integer read GetTotalPages;
property PageRect: TRect read GetPageRect;
property State: TPreviewState read FState;
property PageWidth: Integer read GetPageWidth;
property PageHeight: Integer read GetPageHeight;
property PixelsPerInch: TPoint read FPixelsPerInch;
property CurrentPage: Integer read FCurrentPage write SetCurrentPage;
property Pages[PageNo: Integer]: TMetaFile read GetPages;
property Paper: TPaperPreview read FPaperView;
published
property About: String read GetAbout write SetAbout stored False;
property Align default alClient;
property BorderStyle;
property BevelInner;
property BevelOuter;
property BorderWidth;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property Color;
property Ctl3D;
property ParentColor;
property ParentCtl3D;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop default True;
property Visible;
property PrintJobTitle: String read FPrintJobTitle write FPrintJobTitle;
property Resulotion: TBorderWidth read FResulotion write SetResulotion default 96;
property UsePrinterRes: Boolean read FUsePrinterRes write SetUsePrinterRes default False;
property ZoomState: TZoomState read FZoomState write SetZoomState default zsZoomToFit;
property Zoom: Integer read FZoom write SetZoom default 100;
property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 70;
property MarginRight: Integer read FMarginRight write SetMarginRight default 70;
property MarginTop: Integer read FMarginTop write SetMarginTop default 70;
property MarginBottom: Integer read FMarginBottom write SetMarginBottom default 70;
property PaperWidth: Integer read FPaperWidth write SetPaperWidth default 2100;
property PaperHeight: Integer read FPaperHeight write SetPaperHeight default 2970;
property Orientation: TPrinterOrientation read FOrientation write SetOrientation default poPortrait;
property Units: TUnits read FUnits write SetUnits default mmLoMetric;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property Onbegin
Doc: TNotifyEvent read FOnbegin
Doc write FOnbegin
Doc;
property OnEndDoc: TNotifyEvent read FOnEndDoc write FOnEndDoc;
property OnNewPage: TNotifyEvent read FOnNewPage write FOnNewPage;
property OnAbort: TNotifyEvent read FOnAbort write FOnAbort;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnPrintProgress: TPreviewPrintProgress read FOnPrintProgress write FOnPrintProgress;
property OnBeforePrint: TNotifyEvent read FOnBeforePrint write FOnBeforePrint;
property OnAfterPrint: TNotifyEvent read FOnAfterPrint write FOnAfterPrint;
end;
procedure Register;
implementation
{$IFDEF WIN32}
{$R *.D32}
{$else
}
{$R *.D16}
{$ENDIF}
procedure Register;
begin
RegisterComponents('Samples', [TPrintPreview, TPaperPreview]);
end;
procedure OutOfMemory;
begin
raise EOutOfMemory.Create('Not enough memory to create a new page');
end;
{ TPaperPreview }
constructor TPaperPreview.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBorderColor := clBlack;
FBorderSize := 1;
FPaperColor := clWhite;
FShadowColor := clBtnShadow;
FShadowSize := 3;
PaperWidth := 105;
PaperHeight := 148;
end;
procedure TPaperPreview.Paint;
var
R, PR: TRect;
Region: THandle;
begin
PR := PageRect;
with Canvasdo
begin
Pen.Mode := pmCopy;
if BorderSize > 0 then
begin
Pen.Width := BorderSize;
Pen.Style := psInsideFrame;
Pen.Color := BorderColor;
Brush.Style := bsClear;
Rectangle(0, 0, Width - ShadowSize, Height - ShadowSize);
end;
if ShadowSize > 0 then
begin
Brush.Style := bsSolid;
Brush.Color := ShadowColor;
SetRect(R, Width - ShadowSize, ShadowSize, Width, Height);
FillRect(R);
SetRect(R, ShadowSize, Height - ShadowSize, Width, Height);
FillRect(R);
Brush.Color := Color;
SetRect(R, Width - ShadowSize, 0, Width, ShadowSize);
FillRect(R);
SetRect(R, 0, Height - ShadowSize, ShadowSize, Height);
FillRect(R);
end;
Brush.Style := bsSolid;
Brush.Color := PaperColor;
FillRect(PR);
end;
if Assigned(FOnPaint) then
begin
Region := CreateRectRgn(PR.Left, PR.Top, PR.Right, PR.Bottom);
SelectClipRgn(Canvas.Handle, Region);
DeleteObject(Region);
try
FOnPaint(Self, Canvas, PR);
finally
SelectClipRgn(Canvas.Handle, 0);
end;
end;
end;
function TPaperPreview.PageRect;
begin
with Resultdo
begin
Left := BorderSize;
Top := BorderSize;
Right := Width - (ShadowSize + BorderSize);
Bottom := Height - (ShadowSize + BorderSize);
end;
end;
procedure TPaperPreview.SetPaperWidth(Value: Integer);
begin
Width := Value + 2 * FBorderSize + FShadowSize;
end;
function TPaperPreview.GetPaperWidth: Integer;
begin
Result := Width - 2 * FBorderSize - FShadowSize;
end;
procedure TPaperPreview.SetPaperHeight(Value: Integer);
begin
Height := Value + 2 * FBorderSize + FShadowSize;
end;
function TPaperPreview.GetPaperHeight: Integer;
begin
Result := Height - 2 * FBorderSize - FShadowSize;
end;
procedure TPaperPreview.SetPaperColor(Value: TColor);
begin
if FPaperColor <> Value then
begin
FPaperColor := Value;
InvalidateRect(Handle, nil, False);
end;
end;
procedure TPaperPreview.SetBorderColor(Value: TColor);
begin
if FBorderColor <> Value then
begin
FBorderColor := Value;
InvalidateRect(Handle, nil, False);
end;
end;
procedure TPaperPreview.SetBorderSize(Value: TBorderWidth);
begin
if FBorderSize <> Value then
begin
FBorderSize := Value;
InvalidateRect(Handle, nil, False);
end;
end;
procedure TPaperPreview.SetShadowColor(Value: TColor);
begin
if FShadowColor <> Value then
begin
FShadowColor := Value;
InvalidateRect(Handle, nil, False);
end;
end;
procedure TPaperPreview.SetShadowSize(Value: TBorderWidth);
begin
if FShadowSize <> Value then
begin
FShadowSize := Value;
InvalidateRect(Handle, nil, False);
end;
end;
procedure TPaperPreview.WMSize(var Message: TWMSize);
begin
inherited;
if Assigned(FOnResize) then
FOnResize(Self);
end;
procedure TPaperPreview.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
Message.Result := 1;
end;
{ TPrintPreview }
const
PAPERCOUNT = 66;
PaperSizes: Array[1..PAPERCOUNT] of TPoint = (
(X:2159;
Y:2794),
(X:2159;
Y:2794),
(X:2794;
Y:4318),
(X:4318;
Y:2794),
(X:2159;
Y:3556),
(X:1397;
Y:2159),
(X:1842;
Y:2667),
(X:2970;
Y:4200),
(X:2100;
Y:2970),
(X:2100;
Y:2970),
(X:1480;
Y:2100),
(X:2500;
Y:3540),
(X:1820;
Y:2570),
(X:2159;
Y:3302),
(X:2150;
Y:2750),
(X:2540;
Y:3556),
(X:2794;
Y:4318),
(X:2159;
Y:2794),
(X:984;
Y:2254),
(X:1048;
Y:2413),
(X:1143;
Y:2635),
(X:1207;
Y:2794),
(X:1270;
Y:2921),
(X:4318;
Y:5588),
(X:5588;
Y:8636),
(X:8636;
Y:11176),
(X:1100;
Y:2200),
(X:1620;
Y:2290),
(X:3240;
Y:4580),
(X:2290;
Y:3240),
(X:1140;
Y:1620),
(X:1140;
Y:2290),
(X:2500;
Y:3530),
(X:1760;
Y:2500),
(X:1760;
Y:1250),
(X:1100;
Y:2300),
(X:984;
Y:1905),
(X:920;
Y:1651),
(X:3778;
Y:2794),
(X:2159;
Y:3048),
(X:2159;
Y:3302),
(X:2500;
Y:3530),
(X:1000;
Y:1480),
(X:2286;
Y:2794),
(X:2540;
Y:2794),
(X:3810;
Y:2794),
(X:2200;
Y:2200),
(X:2355;
Y:3048),
(X:2355;
Y:3810),
(X:2969;
Y:4572),
(X:2354;
Y:3223),
(X:2101;
Y:2794),
(X:2100;
Y:2970),
(X:2355;
Y:3048),
(X:2270;
Y:3560),
(X:3050;
Y:4870),
(X:2159;
Y:3223),
(X:2100;
Y:3300),
(X:1480;
Y:2100),
(X:1820;
Y:2570),
(X:3220;
Y:4450),
(X:1740;
Y:2350),
(X:2010;
Y:2760),
(X:4200;
Y:5940),
(X:2970;
Y:4200),
(X:3220;
Y:4450));
const
DefaultGutterLoMM = 60;
Margin = 6;
type EAbortPrint = class(Exception);
procedure SwapValue(var A, B: Integer);
begin
A := A xor B;
B := A xor B;
A := A xor B;
end;
function GetPaperID(Size: TPoint): Word;
var
I: Word;
begin
for I := 1 to PAPERCOUNTdo
if (PaperSizes.X = Size.X) and (PaperSizes.Y = Size.Y) then
begin
Result := I;
Exit;
end;
Result := DMPAPER_USER;
end;
function GetPrinterPhysicalPage: TRect;
var
Ofs: TPoint;
begin
Ofs := Point(0, 0);
Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @Ofs);
Result := Rect(-Ofs.X, -Ofs.Y, Printer.PageWidth + Ofs.X, Printer.PageHeight + Ofs.Y);
end;
function ConvertUnits(Value, DPI: Integer;
InUnits, OutUnits: TUnits): Integer;
var
Pixels: Integer;
begin
case InUnits of
mmLoMetric: Pixels := MulDiv(Value, DPI, 254);
mmHiMetric: Pixels := MulDiv(Value, DPI, 2540);
mmLoEnglish: Pixels := MulDiv(Value, DPI, 10);
mmHiEnglish: Pixels := MulDiv(Value, DPI, 100);
mmTWIPS: Pixels := MulDiv(Value, DPI, 1440);
else
{ mmPixel }
Pixels := Value;
end;
case OutUnits of
mmLoMetric: Result := MulDiv(Pixels, 254, DPI);
mmHiMetric: Result := MulDiv(Pixels, 2540, DPI);
mmLoEnglish: Result := MulDiv(Pixels, 10, DPI);
mmHiEnglish: Result := MulDiv(Pixels, 100, DPI);
mmTWIPS: Result := MulDiv(Pixels, 1440, DPI);
else
{ mmPixel }
Result := Pixels;
end;
end;
constructor TPrintPreview.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alClient;
TabStop := True;
Font.Name := 'Arial';
Font.Size := 20;
FAborted := False;
FState := psReady;
FResulotion := 96;
FUsePrinterRes := False;
FUnits := mmLoMetric;
FMarginLeft := 70;
FMarginRight := 70;
FMarginTop := 70;
FMarginBottom := 70;
FGutter := DefaultGutterLoMM;
FOrientation := poPortrait;
FPaperWidth := 2100;
FPaperHeight := 2970;
FPixelsPerInch.X := FResulotion;
FPixelsPerInch.Y := FResulotion;
FZoom := 100;
FZoomState := zsZoomToFit;
FPages := TList.Create;
FVertScrollBar := TScrollBar.Create(Self);
FVertScrollBar.Parent := Self;
with FVertScrollBardo
begin
Kind := sbVertical;
TabStop := False;
SmallChange := 8;
Max := 0;
Align := alRight;
TabStop := False;
OnChange := VScroll;
end;
FHorzScrollBar := TScrollBar.Create(Self);
FHorzScrollBar.Parent := Self;
with FHorzScrollBardo
begin
Kind := sbHorizontal;
TabStop := False;
SmallChange := 8;
Max := 0;
Align := alBottom;
TabStop := False;
OnChange := HScroll;
end;
FClient := TPanel.Create(Self);
FClient.Parent := Self;
with FClientdo
begin
BevelInner := bvNone;
BevelOuter := bvNone;
BorderStyle := bsNone;
ParentColor := True;
TabStop := False;
Align := alClient;
end;
FPaperView := TPaperPreview.Create(FClient);
with FPaperViewdo
begin
Parent := FClient;
TabStop := False;
OnPaint := PaintPage;
Visible := False;
end;
ResetPrinter;
end;
destructor TPrintPreview.Destroy;
begin
Clear;
FPages.Free;
inherited Destroy;
end;
procedure TPrintPreview.Loaded;
begin
inherited Loaded;
UpdateZoom;
end;
function TPrintPreview.Pixel2Units(Value: Integer): Integer;
begin
Result := ConvertUnits(Value, FPixelsPerInch.Y, mmPixel, FUnits);
end;
procedure TPrintPreview.WMWinIniChange(var Message: TMessage);
begin
inherited;
if StrIComp(PChar(Message.lParam), 'Windows') = 0 then
begin
ResetPrinter;
UpdateZoom;
end;
end;
procedure TPrintPreview.KeyDown(var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_HOME) and (Shift = []) then
with FHorzScrollbardo
Position := Min
else
if (Key = VK_HOME) and (Shift = [ssCtrl]) then
with FVertScrollbardo
Position := Min
else
if (Key = VK_END) and (Shift = []) then
with FHorzScrollbardo
Position := Max
else
if (Key = VK_END) and (Shift = [ssCtrl]) then
with FVertScrollbardo
Position := Max
else
if (Key = VK_LEFT) and (Shift = []) then
with FHorzScrollbardo
Position := Position + SmallChange
else
if (Key = VK_LEFT) and (Shift = [ssCtrl]) then
with FHorzScrollbardo
Position := Position + LargeChange
else
if (Key = VK_RIGHT) and (Shift = []) then
with FHorzScrollbardo
Position := Position - SmallChange
else
if (Key = VK_RIGHT) and (Shift = [ssCtrl]) then
with FHorzScrollbardo
Position := Position - LargeChange
else
if (Key = VK_UP) and (Shift = []) then
with FVertScrollbardo
Position := Position - SmallChange
else
if (Key = VK_UP) and (Shift = [ssCtrl]) then
with FVertScrollbardo
Position := Position - LargeChange
else
if (Key = VK_DOWN) and (Shift = []) then
with FVertScrollbardo
Position := Position + SmallChange
else
if (Key = VK_DOWN) and (Shift = [ssCtrl]) then
with FVertScrollbardo
Position := Position + LargeChange
else
if (Key = VK_NEXT) and (Shift = [ssCtrl]) then
CurrentPage := TotalPages
else
if (Key = VK_PRIOR) and (Shift = [ssCtrl]) then
CurrentPage := 1
else
if (Key = VK_NEXT) and (Shift = []) then
CurrentPage := CurrentPage + 1
else
if (Key = VK_PRIOR) and (Shift = []) then
CurrentPage := CurrentPage - 1;
inherited KeyDown(Key, Shift);
end;
procedure TPrintPreview.UpdatePrinterParameters;
const
Orientations: array [TPrinterOrientation] of Integer =
(DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
var
DevMode: PDevMode;
DeviceMode: THandle;
PaperSize: TPoint;
Device, Driver, Port: array[0..255] of Char;
begin
if Printer.Printers.Count <= 0 then
Exit;
if not (Printer.PrinterIndex in [0..Printer.Printers.Count-1]) then
Printer.PrinterIndex := -1;
PaperSize.X := ConvertUnits(FPaperWidth, FPixelsPerInch.X, FUnits, mmLoMetric);
PaperSize.Y := ConvertUnits(FPaperHeight, FPixelsPerInch.Y, FUnits, mmLoMetric);
if FOrientation = poLandscape then
SwapValue(PaperSize.X, PaperSize.Y);
Printer.GetPrinter(Device, Driver, Port, DeviceMode);
DevMode := PDevMode(GlobalLock(DeviceMode));
with DevMode^do
begin
dmFields := dmFields or DM_PAPERSIZE;
dmPaperSize := GetPaperID(PaperSize);
if dmPaperSize = DMPAPER_USER then
begin
dmFields := dmFields or DM_PAPERWIDTH;
dmPaperWidth := PaperSize.X;
dmFields := dmFields or DM_PAPERLENGTH;
dmPaperLength := PaperSize.Y;
end;
dmFields := dmFields or DM_ORIENTATION;
dmOrientation := Orientations[(FOrientation)];
end;
GlobalUnlock(DeviceMode);
Printer.SetPrinter(Device, Driver, Port, DeviceMode);
end;
procedure TPrintPreview.ResetPrinter;
begin
if FUsePrinterRes and (Printer.Printers.Count > 0) and not Printer.Printing and
not (csDesigning in ComponentState) then
begin
Printer.Orientation := FOrientation;
FPixelsPerInch.Y := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
FPixelsPerInch.X := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
end
else
begin
FPixelsPerInch.Y := FResulotion;
FPixelsPerInch.X := FResulotion;
end;
FPixels.X := ConvertUnits(FPaperWidth, FPixelsPerInch.X, FUnits, mmPixel);
FPixels.Y := ConvertUnits(FPaperHeight, FPixelsPerInch.Y, FUnits, mmPixel);
end;
procedure TPrintPreview.Resize;
begin
inherited Resize;
UpdateZoom;
FHorzScrollBar.LargeChange := FClient.Width;
FVertScrollBar.LargeChange := FClient.Height;
end;
procedure TPrintPreview.HScroll(Sender: TObject);
var
Delta: Integer;
begin
Delta := (Margin - FHorzScrollBar.Position) - FPaperView.Left;
FClient.ScrollBy(Delta, 0);
end;
procedure TPrintPreview.VScroll(Sender: TObject);
var
Delta: Integer;
begin
Delta := (Margin - FVertScrollBar.Position) - FPaperView.Top;
FClient.ScrollBy(0, Delta);
end;
procedure TPrintPreview.UpdateZoom;
begin
FHorzScrollBar.SetParams(0, 0, 0);
FVertScrollBar.SetParams(0, 0, 0);
case FZoomState of
zsZoomOther:
begin
FHorzScrollBar.Visible := True;
FVertScrollBar.Visible := True;
FPaperView.PaperWidth := MulDiv(FPixels.X, FZoom * Screen.PixelsPerInch, FPixelsPerInch.X * 100);
FPaperView.PaperHeight := MulDiv(FPixels.Y, FZoom * Screen.PixelsPerInch, FPixelsPerInch.Y * 100);
end;
zsZoomToWidth:
begin
FHorzScrollBar.Visible := False;
FVertScrollBar.Visible := True;
FPaperView.Width := FClient.Width - 2 * Margin;
FPaperView.PaperHeight := MulDiv(FPaperView.PaperWidth, FPixels.Y, FPixels.X);
end;
zsZoomToHeight:
begin
FHorzScrollBar.Visible := True;
FVertScrollBar.Visible := False;
FPaperView.Height := FClient.Height - 2 * Margin;
FPaperView.PaperWidth := MulDiv(FPaperView.PaperHeight, FPixels.X, FPixels.Y);
end;
zsZoomToFit:
begin
FHorzScrollBar.Visible := False;
FVertScrollBar.Visible := False;
if (FPixels.Y / FPixels.X) < (FClient.Height / FClient.Width) then
begin
FPaperView.Width := FClient.Width - 2 * Margin;
FPaperView.PaperHeight := MulDiv(FPaperView.PaperWidth, FPixels.Y, FPixels.X);
end
else
FPaperView.Height := FClient.Height - 2 * Margin;
FPaperView.PaperWidth := MulDiv(FPaperView.PaperHeight, FPixels.X, FPixels.Y);
end;
end;
if FPaperView.Width < (FClient.Width - 2 * Margin) then
FPaperView.Left := (FClient.Width - FPaperView.Width) div 2
else
begin
FPaperView.Left := Margin;
FHorzScrollBar.Max := FPaperView.Width - FClient.Width + 2 * Margin;
end;
if FPaperView.Height < (FClient.Height - 2 * Margin) then
FPaperView.Top := (FClient.Height - FPaperView.Height) div 2
else
begin
FPaperView.Top := Margin;
FVertScrollBar.Max := FPaperView.Height - FClient.Height + 2 * Margin;
end;
FPaperView.Refresh;
FVertScrollBar.Visible := FVertScrollBar.Max <> 0;
FHorzScrollBar.Visible := FHorzScrollBar.Max <> 0;
end;
procedure TPrintPreview.PaintPage(Sender: TObject;
Canvas: TCanvas;
PageRect: TRect);
begin
if (FCurrentPage >= 1) and (FCurrentPage <= TotalPages) then
Canvas.StretchDraw(PageRect, TMetaFile(FPages[FCurrentPage-1]));
end;
procedure TPrintPreview.SetResulotion(Value: TBorderWidth);
begin
if FResulotion <> Value then
begin
FResulotion := Value;
if not FUsePrinterRes then
ResetPrinter;
end;
end;
procedure TPrintPreview.SetUsePrinterRes(Value: Boolean);
begin
if FUsePrinterRes <> Value then
begin
FUsePrinterRes := Value;
ResetPrinter;
end;
end;
procedure TPrintPreview.SetUnits(Value: TUnits);
begin
if not (csLoading in ComponentState) and (FUnits <> Value) then
begin
FGutter := ConvertUnits(FGutter, FPixelsPerInch.X, FUnits, Value);
FMarginLeft := ConvertUnits(FMarginLeft, FPixelsPerInch.X, FUnits, Value);
FMarginRight := ConvertUnits(FMarginRight, FPixelsPerInch.X, FUnits, Value);
FMarginTop := ConvertUnits(FMarginTop, FPixelsPerInch.Y, FUnits, Value);
FMarginBottom := ConvertUnits(FMarginBottom, FPixelsPerInch.Y, FUnits, Value);
FPaperWidth := ConvertUnits(FPaperWidth, FPixelsPerInch.X, FUnits, Value);
FPaperHeight := ConvertUnits(FPaperHeight, FPixelsPerInch.Y, FUnits, Value);
Font.Size := ConvertUnits(Font.Size, FPixelsPerInch.Y, FUnits, Value);
if Assigned(FCanvas) then
begin
AdjustCanvasView;
FCanvas.Font.Size := ConvertUnits(FCanvas.Font.Size, FPixelsPerInch.Y, FUnits, Value);
FCanvas.Pen.Width := ConvertUnits(FCanvas.Pen.Width, FPixelsPerInch.Y, FUnits, Value);
end;
end;
FUnits := Value;
end;
procedure TPrintPreview.SetMarginLeft(Value: Integer);
begin
FMarginLeft := Value;
if FMarginLeft < FGutter then
FMarginLeft := FGutter;
end;
procedure TPrintPreview.SetMarginRight(Value: Integer);
begin
FMarginRight := Value;
if FMarginRight < FGutter then
FMarginRight := FGutter;
end;
procedure TPrintPreview.SetMarginTop(Value: Integer);
begin
FMarginTop := Value;
if FMarginTop < FGutter then
FMarginTop := FGutter;
end;
procedure TPrintPreview.SetMarginBottom(Value: Integer);
begin
FMarginBottom := Value;
if FMarginBottom < FGutter then
FMarginBottom := FGutter;
end;
procedure TPrintPreview.SetPaperWidth(Value: Integer);
begin
if FPaperWidth <> Value then
begin
FPaperWidth := Value;
ResetPrinter;
UpdateZoom;
end;
end;
procedure TPrintPreview.SetPaperHeight(Value: Integer);
begin
if FPaperHeight <> Value then
begin
FPaperHeight := Value;
ResetPrinter;
UpdateZoom;
end;
end;
procedure TPrintPreview.SetOrientation(Value: TPrinterOrientation);
begin
if (FOrientation <> Value) and (FState <> psCreating) then
begin
FOrientation := Value;
if not ((csLoading in ComponentState) or (csReading in ComponentState)) then
SwapValue(FPaperWidth, FPaperHeight);
ResetPrinter;
UpdateZoom;
end;
end;
procedure TPrintPreview.SetZoom(Value: Integer);
begin
if (FZoom <> Value) or (FZoomState <> zsZoomOther) then
begin
FZoom := Value;
FZoomState := zsZoomOther;
UpdateZoom;
end;
end;
procedure TPrintPreview.SetZoomState(Value: TZoomState);
begin
if FZoomState <> Value then
begin
FZoomState := Value;
UpdateZoom;
end;
end;
procedure TPrintPreview.SetCurrentPage(Value: Integer);
begin
if TotalPages <> 0 then
begin
if Value < 1 then
Value := 1;
if Value > TotalPages then
Value := TotalPages;
if FCurrentPage <> Value then
begin
FCurrentPage := Value;
FPaperView.Refresh;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
end;
function TPrintPreview.GetTotalPages: Integer;
begin
Result := FPages.Count;
end;
function TPrintPreview.GetPageWidth: Integer;
begin
Result := FPaperWidth - (FMarginLeft + FMarginRight);
end;
function TPrintPreview.GetPageHeight: Integer;
begin
Result := FPaperHeight - (FMarginTop + FMarginBottom);
end;
function TPrintPreview.GetPages(PageNo: Integer): TMetaFile;
begin
if (PageNo >= 1) and (PageNo <= TotalPages) then
Result := TMetaFile(FPages[PageNo-1])
else
Result := nil;
end;
function TPrintPreview.GetPageRect: TRect;
begin
with Resultdo
begin
Left := FMarginLeft;
Right := FPaperWidth - FMarginRight;
Top := FMarginTop;
Bottom := FPaperHeight - FMarginBottom;
end;
end;
function TPrintPreview.GetCanvas: TCanvas;
begin
if (FState = psCreating) and Assigned(FCanvas) then
Result := FCanvas
else
Result := Printer.Canvas;
end;
procedure TPrintPreview.AdjustCanvasView;
begin
{$IFDEF WIN32}
Windows.SetMapMode(FCanvas.Handle, MM_ANISOTROPIC);
Windows.SetWindowExtEx(FCanvas.Handle, FPaperWidth, FPaperHeight, nil);
Windows.SetViewPortExtEx(FCanvas.Handle, FPaperWidth, FPaperHeight, nil);
{$else
}
WinProcs.SetMapMode(FCanvas.Handle, MM_ANISOTROPIC);
WinProcs.SetWindowExt(FCanvas.Handle, FPaperWidth, FPaperHeight);
{$ENDIF}
end;
procedure TPrintPreview.CreateMetaFileCanvas;
{$IFDEF WIN32}
var
R: TRect;
RefDC: HDC;
{$ENDIF}
begin
FCanvas := TCanvas.Create;
if not Assigned(FCanvas) then
OutOfMemory;
{$IFDEF WIN32}
RefDC := GetDC(0);
R.Left := 0;
R.Top := 0;
R.Right := MulDiv(FPixels.X, GetDeviceCaps(RefDC, HORZSIZE) * 254,
GetDeviceCaps(RefDC, HORZRES));
R.Bottom := MulDiv(FPixels.Y, GetDeviceCaps(RefDC, VERTSIZE) * 254,
GetDeviceCaps(RefDC, VERTRES));
FCanvas.Handle := CreateEnhMetaFile(RefDC, nil, @R, nil);
ReleaseDC(0, RefDC);
{$else
}
FCanvas.Handle := CreateMetaFile(nil);
{$ENDIF}
if FCanvas.Handle = 0 then
OutOfMemory;
AdjustCanvasView;
FCanvas.Font.Assign(Font);
end;
function TPrintPreview.DestroyMetaFileCanvas: TMetaFile;
var
Temp: HDC;
begin
Temp := FCanvas.Handle;
FCanvas.Handle := 0;
Result := TMetaFile.Create;
if Assigned(Result) then
{$IFDEF WIN32}
Result.Handle := CloseEnhMetaFile(Temp);
{$else
}
Result.Handle := CloseMetaFile(Temp);
{$ENDIF}
FCanvas.Free;
FCanvas := nil;
end;
procedure TPrintPreview.Clear;
var
I: Integer;
begin
for I := 0 to FPages.Count-1do
TMetaFile(FPages).Free;
FPages.Clear;
FState := psReady;
FCurrentPage := 0;
FAborted := False;
FPaperView.Visible := False;
if not (csDestroying in ComponentState) and Assigned(FOnChange) then
OnChange(Self)
end;
procedure TPrintPreview.begin
Doc;
begin
if FState <> psCreating then
begin
Clear;
ResetPrinter;
FState := psCreating;
if Assigned(FOnbegin
Doc) then
FOnbegin
Doc(Self);
NewPage;
end;
end;
procedure TPrintPreview.EndDoc;
var
Page: TMetaFile;
begin
if FState = psCreating then
begin
Page := DestroyMetaFileCanvas;
if not Assigned(Page) then
OutOfMemory;
FPages.Add(Page);
if FCurrentPage = 0 then
begin
FCurrentPage := 1;
FPaperView.Visible := True;
FPaperView.Update;
end;
if Assigned(FOnChange) then
OnChange(Self);
if Assigned(FOnEndDoc) then
FOnEndDoc(Self);
FState := psReady;
end;
end;
procedure TPrintPreview.NewPage;
var
Page: TMetaFile;
begin
if FState = psCreating then
begin
if Assigned(FCanvas) then
begin
Page := DestroyMetaFileCanvas;
if not Assigned(Page) then
OutOfMemory;
FPages.Add(Page);
if FCurrentPage = 0 then
begin
FCurrentPage := 1;
FPaperView.Visible := True;
FPaperView.Update;
end;
if Assigned(FOnChange) then
OnChange(Self)
end;
CreateMetaFileCanvas;
if Assigned(FOnNewPage) then
FOnNewPage(Self);
end;
end;
procedure TPrintPreview.Abort;
begin
FAborted := True;
case State of
psCreating: begin
if Assigned(FOnAbort) then
FOnAbort(Self);
DestroyMetaFileCanvas;
Clear;
end;
psPrinting:
if Printer.Printing and not Printer.Aborted then
Printer.Abort;
end;
end;
procedure TPrintPreview.Print;
begin
PrintPages(1, TotalPages);
end;
procedure TPrintPreview.PrintPages(StartPage, StopPage: Integer);
var
PageRect: TRect;
PageNo: Integer;
AbortIt: Boolean;
PrintedPages, TotalPrintPages: Integer;
begin
if StartPage < 1 then
StartPage := 1;
if StartPage > TotalPages then
StartPage := TotalPages;
if StopPage < 1 then
StartPage := 1;
if StopPage > TotalPages then
StopPage := TotalPages;
if (FState = psReady) and (StopPage >= StartPage) and (Printer.Printers.Count > 0) then
begin
FAborted := False;
PrintedPages := 0;
TotalPrintPages := StopPage - StartPage + 1;
FState := psPrinting;
try try
if Assigned(FOnBeforePrint) then
FOnBeforePrint(Self);
UpdatePrinterParameters;
PageRect := GetPrinterPhysicalPage;
Printer.Title := PrintJobTitle;
AbortIt := False;
Printer.begin
Doc;
for PageNo := StartPage to StopPagedo
begin
if Assigned(FOnPrintProgress) then
FOnPrintProgress(Self, PageNo, MulDiv(100, PrintedPages, TotalPrintPages), AbortIt);
if Printer.Aborted or AbortIt then
raise EAbortPrint.Create(EmptyStr);
Printer.Canvas.StretchDraw(PageRect, TMetaFile(FPages[PageNo-1]));
Inc(PrintedPages);
Application.ProcessMessages;
if Assigned(FOnPrintProgress) then
FOnPrintProgress(Self, PageNo, MulDiv(100, PrintedPages, TotalPrintPages), AbortIt);
if Printer.Aborted or AbortIt then
raise EAbortPrint.Create(EmptyStr);
if PageNo <> StopPage then
Printer.NewPage;
end;
except
AbortIt := True;
end;
finally
if AbortIt then
begin
FAborted := True;
Printer.Abort;
if Assigned(FOnAbort) then
FOnAbort(Self);
end
else
if Assigned(FOnAfterPrint) then
FOnAfterPrint(Self);
Printer.EndDoc;
Printer.Title := EmptyStr;
FState := psReady;
end;
end;
end;
procedure TPrintPreview.SetAbout(Value: String);
const
AboutMsg = 'TPrintPreview v1.1'#10#13 +
'by Kambiz R. Khojasteh'#10#13#10#13 +
'email: khojasteh@www.dci.co.ir'#13#10 +
'web: http://www.crosswinds.net/~khojasteh/'#13#10#13#10 +
'This component is freeware.'#10#13;
begin
MessageDlg(AboutMsg, mtInformation, [mbOK], 0);
end;
function TPrintPreview.GetAbout: String;
begin
Result := '(About)';
end;
end.