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

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;beginR.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;
beginPrinter.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) thenFormat := Format or DT_SINGLELINE or DT_VCENTERelsebeginif 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] thenbeginInc(R.Left, (W - S) div 2);Inc(R.Top, (H - S) div 2);W := S;H := S;end;case SC.Shape ofstRectangle, 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;beginPrinter.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 dofor K:= 0 to SGC.RowCount - 1 dobeginR := SGC.CellRect(J, K);if R.Right > R.Left thenbeginR.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) thenPrinter.Canvas.Brush.Color := SGC.FixedColorelsePrinter.Canvas.Brush.Style := bsClear;if SGC.GridLineWidth > 0 thenPrinter.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;tryDC := 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 doif TControl(F.Components[I]).Visible thenif (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) thenbeginif (F.Components[I] is TCustomLabel) or (F.Components[I] is TCustomEdit) thenPrintMComponent(TMemo(F.Components[I]));if (F.Components[I] is TShape) thenPrintShape(TShape(F.Components[I]));if (F.Components[I] is TStringGrid) thenPrintSGrid(TStringGrid(F.Components[I]));end;finallyPrinter.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;
typeTVRuler = 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] thenbeginfHRulerAlign := 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 dobeginBrush.Color := Color;FillRect(ClientRect);with ClientRect doRectangle(Left, Top, Right, Bottom);while X < Width dobeginMoveTo(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) thenTextOut(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] thenbeginfVRulerAlign := 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 dobeginBrush.Color := Color;FillRect(ClientRect);with ClientRect doRectangle(Left, Top, Right, Bottom);while Y < Height dobeginMoveTo(1, Y);LineTo(6*(2 + byte(N mod 3 = 0) +byte(N mod 6 = 0)),Y);if (N > 0) and (N mod 6 = 0) thenTextOut(12, PenPos.Y-16, IntToStr(N div 6));N := N + 1;Y := Y + a6th;end;end;end;

end.

[000529]

Содержание раздела