Печать всей формы

Written on . Posted in [Delphi] Система. Принтеры

unit PrintF;

{Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.

Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
Примечание: это не компонент. Успехов. Bill}

interface
uses
SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;

function PrintForm(AForm : TForm; ATag : Longint): integer;

{используйте:   PrintForm(Form2, 0);
AForm - форма, которую необходимо напечатать. Если вы, к примеру,
печатаете Form2 из обработчика события Form1, то используйте Unit2
в списке используемых модулей в секции implementation молуля Unit1.
ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
когда ATag равен 0, 2, 4 или 8.
Функция возвращает количество напечатанных компонентов. }

implementation
var ScaleX, ScaleY, I, Count : integer;
DC : HDC;
F : TForm;

function ScaleToPrinter(R:TRect):TRect;
begin
R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
Result := R;
end;

procedure PrintMComponent(MC:TMemo);
var C : array[0..255] of char;
CLen : integer;
Format : Word;
R: TRect;

begin
Printer.Canvas.Font := MC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
R := ScaleToPrinter(MC.BoundsRect);
if (not(F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle)
then Printer.Canvas.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
Format := DT_LEFT;
if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
Format := Format or DT_SINGLELINE or DT_VCENTER
else
begin
if MC.WordWrap then Format := DT_WORDBREAK;
if MC.Alignment = taCenter then Format := Format or DT_CENTER;
if MC.Alignment = taRightJustify then Format := Format or DT_RIGHT;
R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
end;
CLen := MC.GetTextBuf(C,255);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, CLen, R, Format);
inc(Count);
end;

procedure PrintShape(SC:TShape);
var H, W, S : integer;
R : TRect;
begin  {PrintShape}
Printer.Canvas.Pen := SC.Pen;
Printer.Canvas.Pen.Width :=  Printer.Canvas.Pen.Width * ScaleX;
Printer.Canvas.Brush := SC.Brush;
R := ScaleToPrinter(SC.BoundsRect);
W := R.Right - R.Left; H := R.Bottom - R.Top;
if W < H then S := W else S := H;
if SC.Shape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(R.Left, (W - S) div 2);
Inc(R.Top, (H - S) div 2);
W := S;
H := S;
end;
case SC.Shape of
stRectangle, stSquare:
Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
stRoundRect, stRoundSquare:
Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S div 4);
stCircle, stEllipse:
Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
end;
Printer.Canvas.Pen.Width := ScaleX;
Printer.Canvas.Brush.Style := bsClear;
inc(Count);
end; {PrintShape}

procedure PrintSGrid(SGC:TStringGrid);
var J, K : integer;
Q, R : TRect;
Format : Word;
C : array[0..255] of char;
CLen : integer;
begin
Printer.Canvas.Font := SGC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
Format := DT_SINGLELINE or DT_VCENTER;
Q := SGC.BoundsRect;
Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
for J := 0 to SGC.ColCount - 1 do
for K:= 0 to SGC.RowCount - 1 do
begin
R := SGC.CellRect(J, K);
if R.Right > R.Left then
begin
R.Left := R.Left + Q.Left;
R.Right := R.Right + Q.Left + SGC.GridLineWidth;
R.Top := R.Top + Q.Top;
R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
R := ScaleToPrinter(R);
if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
Printer.Canvas.Brush.Color := SGC.FixedColor
else
Printer.Canvas.Brush.Style := bsClear;
if SGC.GridLineWidth > 0 then
Printer.Canvas.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
StrPCopy(C, SGC.Cells[J,K]);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, StrLen(C), R, Format);

end;
end;
Printer.Canvas.Pen.Width := ScaleX;
inc(Count);
end;

function PrintForm(AForm : TForm; ATag : Longint): integer;
begin  {PrintForm}
Count := 0;
F := AForm;
Printer.BeginDoc;
try
DC := Printer.Canvas.Handle;
ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
for I := 0 to F.ComponentCount-1 do
if TControl(F.Components[I]).Visible then
if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
begin
if (F.Components[I] is TCustomLabel) or (F.Components[I] is TCustomEdit) then
PrintMComponent(TMemo(F.Components[I]));
if (F.Components[I] is TShape) then
PrintShape(TShape(F.Components[I]));
if (F.Components[I] is TStringGrid) then
PrintSGrid(TStringGrid(F.Components[I]));
end;
finally
Printer.EndDoc;
Result := Count;
end;
end;   {PrintForm}

end.

unit Rulers;
{ Добавьте в файл .DCR иконки для двух компонентов.

Успехов, Bill}
interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms;

type
THRuler = class(TGraphicControl)
private
{ Private declarations }
fHRulerAlign: TAlign;
procedure SetHRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default alNone;
property Color default clYellow;
property Height default 33;
property Width default 768;
property Visible;
end;

type
TVRuler = class(TGraphicControl)
private
{ Private declarations }
fVRulerAlign: TAlign;
procedure SetVRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default alNone;
property Color default clYellow;
property Height default 1008;
property Width default 33;
property Visible;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [THRuler, TVRuler]);
end;

procedure THRuler.SetHRulerAlign(Value: TAlign);
begin
if Value in [alTop, alBottom, alNone] then
begin
fHRulerAlign := Value;
Align := Value;
end;
end;

constructor THRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clYellow;
Height := 33;
Width := 768;
end;

procedure var a12th, N, X : word;
begin
a12th := Screen.PixelsPerInch div 12;
N := 0; X := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while X < Width do
begin
MoveTo(X, 1);
LineTo(X, 6*(1 + byte(N mod 3 = 0) +
byte(N mod 6 = 0) +
byte(N mod 12 = 0)));
if (N > 0) and (N mod 12 = 0) then
TextOut(PenPos.X+3, 9, IntToStr(N div 12));
N := N + 1;
X := X + a12th;
end;
end;
end;
{*********************************************}
procedure TVRuler.SetVRulerAlign(Value: TAlign);
begin
if Value in [alLeft, alRight, alNone] then
begin
fVRulerAlign := Value;
Align := Value;
end;
end;

constructor TVRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignVRuler := alNone;
Color := clYellow;
Height := 1008;
Width := 33;
end;

procedure TVRuler.Paint;
var a6th, N, Y : word;
begin
a6th := Screen.PixelsPerInch div 6;
N := 0; Y := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while Y < Height do
begin
MoveTo(1, Y);
LineTo(6*(2 + byte(N mod 3 = 0) +
byte(N mod 6 = 0)),Y);
if (N > 0) and (N mod 6 = 0) then
TextOut(12, PenPos.Y-16, IntToStr(N div 6));
N := N + 1;
Y := Y + a6th;
end;
end;
end;

end.

форум принтеры