Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО 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);
   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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS