Печать всей формы |
Previous Top Next |
Code: |
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. |
©Drkb::03246
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba