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

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);
  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
.

Другое по теме:

• Escape код PASSTHROUGH
• Вместо печати графики использовать резидентный шрифт принтера
• Вывести все способы подачи бумаги для печати