找到一打印预览控件(源码),如何转换成ACTIVEX控件,以供其他开发环境使用?(100分)

  • 主题发起人 主题发起人 yuxuant
  • 开始时间 开始时间
Y

yuxuant

Unregistered / Unconfirmed
GUEST, unregistred user!
在delphi环境下使用转换的activex控件提示错误(地址访问冲突)。在其他开发环境也是一样。怎么办啊?
 
做成动态库的形式不可以吗?
 
无论什么,满足功能就行。打印预览。自己画线的。可能需要画布。
下面是源码,有心人请试试吧,拜托了!
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.
 
首先,转换有点麻烦,因为你的这个控件不是从TwinControl继承下来的,在Delphi里面
只有从TwinControl控件继承下来的控件才能直接转换成ActiveX控件。不过,我以前做过
一个非TWinControl控件转换成ActiveX控件的事情。转换很简单,但工作量稍微多一点。
首先,新建一个从TWinControl继承下来的控件。再在这个控件内部动态创建一个你的
打印控件的实例,然后把所有打印控件的属性、方法重新用你新建的这个控件公开,
简单的说,就是做一个外套控件。
不过做好控件后,当你要直接转换成ActiveX的时候,会出现错误!不要着急,直接把
你新建的这个控件里面除了Create和Destroy两个方法里面的inherited语句以外的所有语句
(包括其它方法和属性调用方法里面的所有语句),全部注释掉。在编译一遍。最后转换
到ActiveX控件,完成后,再次把所有注释去掉。这样就成功了!
 
to zqw0117:
帮我做一下?我太笨~谢谢
 
Qreport有有现成的,为什么不用?
 
自定义快速报表的打印预览窗口

---- Quick Report 2.0 中 提 供 的 默 认 打 印 预 览 窗 口 是 英 文 界 面 的, 如 果 开 发 的 中 文 软 件 中 带 有 这 种 英 文 显 示, 不 免 有 些 小 小 的 缺 憾。 因 此 有 必 要 实 现 中 文 界 面 的 打 印 预 览 窗 口。 但 是Delphi 提 供 的 源 代 码 中 并 没 有 打 印 预 览 窗 口 的.PAS 源 文 件, 这 就 无 法 直 接 修 改 源 码, 只 能 全 部 自 己 编 程 实 现。 经 多 次 实 践, 笔 者 模 仿 实 现 了 与 默 认 预 览 窗 口 外 观 类 似, 功 能 相 同 的 打 印 预 览 窗 口。 步 骤 如 下:

---- 1. 新 建 一 个 窗 体, 设 置Name 为MyPreview。
---- 2. 在 窗 体 上 添 加 一Toolbar 控 件, 模 仿 默 认 预 览 窗 口 创 建 相 应 的Toolbutton, 并 设 置 各 按 钮 的Hint 提 示。
---- 3. 添 加 一Panel 控 件, 对 齐 方 式 置 为alBottom。 再 在 此Panel 上 放 一ProgressBar( 左 对 齐) 和Panel( 右 对 齐), 分 别 显 示 报 表 装 载 进 度 和 其 他 提 示 信 息。
---- 4. 添 加QRPreview 控 件, 对 齐 方 式 置 为alClient。
---- 5. 添 加OpenDialog, 设 置Filter 属 性 为*.QR; 添 加SaveDialog, 设 置Filter 属 性 为*.QR|*.TXT|*.HTM|*.CSV, 设 置DefaultExt 属 性 为*.QR。
---- 6. 双 击 各 个Toolbutton, 输 入 相 应 代 码。
---- 可 以 按 以 下 方 法 调 用 自 定 义 预 览 窗 口。

---- 重 载TQuickRep 的OnPreview 事 件, 输 入 如 下 代 码:
procedure TRptForm.RptFormPreview(Sender: TObject);
begin

with TMyPreview.Create(Application)do

begin

QRPreview1.QRPrinter := TQRPrinter(Sender);
CurRep := self;
Show;
end;

end;

附 各 成 员 方 法 的 具 体 实 现:
unit Myprv;

interface
uses
Windows
Messages
SysUtils
Classes
Graphics
Controls
Forms
Dialogs
ComCtrls
ToolWin
qrprntr
Quickrpt
StdCtrls
ExtCtrls
qrextra
qrhtml;

type
TMyPreview = class(TForm)
QRPreview1: TQRPreview;
ToolBar1: TToolBar;
(其 余 成 员 变 量 和 成 员 方 法 声 明 略。)
private
{ Private declarations }
FPageCount : integer;
// 生 成 报 表 的 总 页 数
public
{ Public declarations }
CurRep : TQuickRep;
// 所 预 览 的 报 表
procedure UpdatePanelShow;
end;

implementation

{$R *.DFM}
procedure TMyPreview.UpdatePanelShow;
begin
// 更 新 显 示
Panel2.Caption := ' 第 '+inttostr(QRPreview1.PageNumber)+ ' 页 总 '+inttostr(FPageCount)+' 页';
end;

procedure TMyPreview.ToolButton2Click(Sender: TObject);
begin
//ZoomToFit 缩 放 至 全 屏
QRPreview1.ZoomToFit;
end;

procedure TMyPreview.ToolButton3Click(Sender: TObject);
begin
//ZoomTo100% 缩 放 至 实 际 大 小
QRPreview1.Zoom:=100;
end;

procedure TMyPreview.ToolButton4Click(Sender: TObject);
begin
//ZoomToWidth 缩 放 至 页 宽
QRPreview1.ZoomToWidth;
end;

procedure TMyPreview.ToolButton6Click(Sender: TObject);
begin
//First page
QRPreview1.PageNumber := 1;
UpdatePanelShow;
end;

procedure TMyPreview.ToolButton8Click(Sender: TObject);
begin
//prior page
QRPreview1.PageNumber := QRPreview1.PageNumber+1;
UpdatePanelShow;
end;

procedure TMyPreview.ToolButton7Click(Sender: TObject);
begin
//next page
QRPreview1.PageNumber := QRPreview1.PageNumber-1;
if QRPreview1.PageNumber =0 then

QRPreview1.PageNumber:=1;
UpdatePanelShow;
end;

procedure TMyPreview.ToolButton9Click(Sender: TObject);
begin
//Last page
QRPreview1.PageNumber := FPageCount;
UpdatePanelShow;
end;

procedure TMyPreview.QRPreview1PageAvailable(Sender: TObject;
PageNum: Integer);
begin
//get pagecount
FPageCount := PageNum ;
UpdatePanelShow;
end;

procedure TMyPreview.FormClose(Sender: TObject;
var Action: TCloseAction);
begin

CurRep := nil;
Action := caFree;
end;

procedure TMyPreview.ToolButton14Click(Sender: TObject);
begin
//close the window
Close;
end;

procedure TMyPreview.ToolButton11Click(Sender: TObject);
begin
//print setup
QRPreview1.QRPrinter.PrintSetup;
end;

procedure TMyPreview.ToolButton13Click(Sender: TObject);
begin
//print
QRPreview1.QRPrinter.Print;
end;

procedure TMyPreview.ToolButton16Click(Sender: TObject);
begin
//save button
if SaveDlg1.Execute then

begin

if (SaveDlg1.FIlterIndex <>1) and (CurRep = nil) then

Exit;
case SaveDlg1.FilterINdex of
1: //--*.QR
QRPreview1.QRPrinter.Save(SaveDlg1.FileName);
2: //--*.TXT
CurRep.ExportToFilter (TQRAsciiExportFilter.Create(SaveDlg1.FileName));
3: //--*.HTM
CurRep.ExportToFilter (TQRHTMLExportFilter.Create(SaveDlg1.FileName));
4: //--*.CSV
CurRep.ExportToFilter(TQRCSVExportFilter.Create(SaveDlg1.FileName));
end;

end;

end;

procedure TMyPreview.ToolButton17Click(Sender: TObject);
begin
//load button
if OpenDlg1.Execute then

QRPreview1.QRPrinter.Load(OpenDlg1.FileName);
end;

procedure TMyPreview.QRPreview1ProgressUpdate(Sender: TObject;
Progress: Integer);
begin
//updage progress bar
ProgressBar1.Position := Progress;
end;

procedure TMyPreview.SaveDlg1TypeChange(Sender: TObject);
begin
//set DefaultExt property of Savedialog
with SaveDlg1do

case FilterIndex of
0: DefaultExt := '.QR';
1: DefaultExt := '.TXT';
2: DefaultExt := '.HTM';
3: DefaultExt := '.CSV';
end;

end;

end.
//end of Unit
 

Similar threads

D
回复
0
查看
2K
DelphiTeacher的专栏
D
S
回复
0
查看
3K
SUNSTONE的Delphi笔记
S
D
回复
0
查看
2K
DelphiTeacher的专栏
D
S
回复
0
查看
2K
SUNSTONE的Delphi笔记
S
后退
顶部