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

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
 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;
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
 begin
 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;
 end;
 Printer.Canvas.Pen.Width := ScaleX;
 Inc(Count);
end;
function PrintForm(AForm: TForm; ATag: Longint): Integer;
begin
 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;
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);
 AlignHRuler := alNone;
 Color := clYellow;
 Height := 33;
 Width := 768;
end;
procedure THRuler.Paint;
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.
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03246
Category:Принтер
Category:TForm