home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / D1 / PRINTP43.ZIP / PRINTPAG.PAS < prev    next >
Pascal/Delphi Source File  |  1995-11-04  |  31KB  |  893 lines
  1. unit Printpag;  {PrintPage Version 4.3 Copyright ⌐ W. Murto 1995}
  2.  
  3. {$DEFINE NORULER}             {THRuler & TVRuler in RULER1.ZIP}
  4. {$DEFINE NOROTATE}            {TRotateLabel in ROTATEL.ZIP}
  5. {To use these components remove 'NO' then Install or Rebuild.}
  6.  
  7. interface
  8. uses
  9.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  10.   Forms, Grids, Printers, StdCtrls, ExtCtrls, Tabs, TabNotBk, Menus, Calendar
  11.   {$IFDEF RULER} , Rulers            {$ENDIF}
  12.   {$IFDEF ROTATE}, Rotatel           {$ENDIF}
  13.   ;
  14.  
  15. const mrPrint = mrAll + 1;
  16.  
  17. type
  18.   TPrintPreview = class(TForm)
  19.     MainMenu1: TMainMenu;
  20.     Print1: TMenuItem;
  21.     Cancel1: TMenuItem;
  22.     procedure Print1Click(Sender: TObject);
  23.     procedure Cancel1Click(Sender: TObject);
  24.   private
  25.     { Private declarations }
  26.   public
  27.     { Public declarations }
  28.   end;
  29.  
  30. type
  31.   TPrintPage = class(TComponent)
  32.   private
  33.     { Private declarations }
  34.     fSource : TScrollingWinControl;
  35.     fTags : longint;
  36.     fDest : TCanvas;
  37.     fOnPrintControl : TNotifyEvent;
  38.     fOnExternalPrint : TNotifyEvent;
  39.     fPreviewCaption : string;
  40.     fPreviewing,
  41.     fPreviewMenu,
  42.     fPreviewRulers : boolean;
  43.     RulerOffset : integer;
  44.     fPreviewScale : double;
  45.     fDesignPixelsPerInch : integer;
  46.     fPreviewHeight,
  47.     fPreviewWidth : double;
  48.     fTopOffset, fLeftOffset,
  49.     VOffset, HOffset,
  50.     VScrollPos, HScrollPos,
  51.     fScaleX, fScaleY : integer;
  52.     fScaleRX, fScaleRY : double;
  53.     PDC : HDC;
  54.     procedure SetPreviewRulers(Value: boolean);
  55.     procedure SetPreviewScale(Value: double);
  56.     procedure Paint_Preview(Sender: TObject);
  57.   protected
  58.     { Protected declarations }
  59.   public
  60.     { Public declarations }
  61.     constructor Create(AOwner: TComponent); override;
  62.     procedure Print;
  63.     function Preview: integer;
  64.     property Source: TScrollingWinControl read fSource write fSource stored false;
  65.     property Dest: TCanvas read fDest;
  66.     property Previewing: boolean read fPreviewing;
  67.     property OnExternalPrint: TNotifyEvent read fOnExternalPrint write fOnExternalPrint stored false;
  68.     property LeftOffset: integer read fLeftOffset write fLeftOffset stored false;
  69.     property TopOffset: integer read fTopOffset write fTopOffset stored false;
  70.     property LineSize: integer read fScaleY;
  71.     property ScaleRX: double read fScaleRX;
  72.     property ScaleRY: double read fScaleRY;
  73.     property ScaleX: integer read fScaleX;
  74.     property ScaleY: integer read fScaleY;
  75.     function ScaleToPrinter(R:TRect):TRect;
  76.   published
  77.     { Published declarations }
  78.     property PrintTags: longint read fTags write fTags;
  79.     property PreviewCaption: string read fPreviewCaption write fPreviewCaption;
  80.     property PreviewMenu: boolean read fPreviewMenu write fPreviewMenu;
  81.     property PreviewRulers: boolean read fPreviewRulers write SetPreviewRulers;
  82.     property PreviewScale: double read fPreviewScale write SetPreviewScale;
  83.     property DesignPixelsPerInch: integer read fDesignPixelsPerInch write fDesignPixelsPerInch;
  84.     property PerviewHeight: double read fPreviewHeight write fPreviewHeight;
  85.     property PerviewWidth: double read fPreviewWidth write fPreviewWidth;
  86.     property OnUpdatePrintStatus: TNotifyEvent read fOnPrintControl write fOnPrintControl;
  87.   private
  88.     { more Private declarations - the Print/Paint stuff }
  89.     procedure DrawHRuler(R: TRect);
  90.     procedure DrawVRuler(R: TRect);
  91.     procedure PrintLabel(ALabel: TLabel);
  92.     procedure PrintMemo(AMemo: TMemo);
  93.     procedure PrintEdit(AEdit: TEdit);
  94.     procedure PrintComboBox(ACombo: TComboBox);
  95.     procedure PrintShape(AShape:TShape);
  96.     procedure PrintGrid(TheGrid:TObject);
  97.     procedure PrintCheck(ACheck: TCheckBox);
  98.     procedure PrintRadio(ARadio: TRadioButton);
  99.     procedure PrintBevel(ABevel: TBevel);
  100.     procedure PrintTabSet(ATabSet: TTabSet);
  101.     procedure PrintImage(AImage: TImage);
  102.     {$IFDEF RULER}
  103.     procedure PrintHRuler(Ruler: THRuler);
  104.     procedure PrintVRuler(Ruler: TVRuler);
  105.     {$ENDIF}
  106.     {$IFDEF ROTATE}
  107.     procedure PrintRotate(ARotate: TRotateLabel);
  108.     {$ENDIF}
  109.     procedure PrintGroup(AGroup: TGroupBox);
  110.     Procedure PrintPanel(APanel: TPanel);
  111.     Procedure PrintNotebook(ANotebook: TNotebook);
  112.     Procedure PrintTabNotebook(ATabNotebook: TTabbedNotebook);
  113.     procedure PrintControl(AControl: TObject);
  114.   end;
  115.  
  116. procedure Register;
  117.  
  118. implementation
  119.  
  120. {$R *.DFM}
  121.  
  122. var
  123.   PrintPreview: TPrintPreview;
  124.  
  125. procedure Register;
  126. begin
  127.   RegisterComponents('Samples', [TPrintPage]);
  128. end;
  129.  
  130. procedure TPrintPreview.Print1Click(Sender: TObject);
  131. begin
  132.   ModalResult := mrPrint;
  133. end;
  134.  
  135. procedure TPrintPreview.Cancel1Click(Sender: TObject);
  136. begin
  137.   ModalResult := mrCancel;
  138. end;
  139.  
  140.     { PrintPage Private declarations }
  141. procedure TPrintPage.SetPreviewRulers(Value: boolean);
  142. begin
  143.   fPreviewRulers := Value;
  144.   if Value then RulerOffset := 32 else RulerOffset := 0;
  145. end;
  146.  
  147. procedure TPrintPage.SetPreviewScale(Value: double);
  148. begin
  149.   if (Value > 0.9) and (Value < 4.1) then fPreviewScale := Value;
  150. end;
  151.  
  152.     { preview form onpaint set to this in the preview function }
  153. procedure TPrintPage.Paint_Preview(Sender: TObject);
  154. var I, ROffset : integer;
  155. begin
  156.   if not fPreviewing then exit;
  157.   try
  158.     VOffset := RulerOffset; HOffset := RulerOffset;
  159.     if fPreviewRulers then
  160.     begin
  161.       ROffset :=  trunc(RulerOffset * fScaleRX);
  162.       DrawHRuler(Rect(ROffset, 0, PrintPreview.ClientWidth, ROffset));
  163.       DrawVRuler(Rect(0, ROffset, ROffset, PrintPreview.ClientHeight));
  164.     end;
  165.     VScrollPos := fSource.VertScrollBar.Position;
  166.     HScrollPos := fSource.HorzScrollBar.Position;
  167.     for I := 0 to fSource.ControlCount-1 do
  168.     if (fSource.Controls[I].Visible) and (fSource.Controls[I].Tag >= 0) then
  169.       if (fTags = 0) or (fSource.Controls[I].Tag and fTags = fTags) then
  170.         PrintControl(fSource.Controls[I]);
  171.   except
  172.     on Exception do fPreviewing := false;
  173.   end;
  174. end; {Paint_Preview}
  175.  
  176.     { Public declarations }
  177. constructor TPrintPage.Create(AOwner: TComponent);
  178. begin
  179.   inherited Create(AOwner);
  180.   fPreviewCaption := 'Print Preview';
  181.   fPreviewScale := 3.0;
  182.   fDesignPixelsPerInch := 96;
  183.   fPreviewHeight := 10.5;
  184.   fPreviewWidth := 8.0;
  185. end; {create}
  186.  
  187. procedure TPrintPage.Print;
  188. var I : integer;
  189. begin
  190.   if not Assigned(fSource) then exit;
  191.   fPreviewing := false;
  192.   VOffset := fTopOffset; HOffset := fLeftOffset;
  193.   VScrollPos := fSource.VertScrollBar.Position;
  194.   HScrollPos := fSource.HorzScrollBar.Position;
  195.   Printer.BeginDoc;
  196.   try
  197.     fDest := Printer.Canvas;
  198.     PDC := Printer.Canvas.Handle;
  199.     fScaleRX := WinProcs.GetDeviceCaps(PDC, LOGPIXELSX) / fDesignPixelsPerInch;
  200.     fScaleRY := WinProcs.GetDeviceCaps(PDC, LOGPIXELSY) / fDesignPixelsPerInch;
  201.     fScaleX := Trunc(fScaleRX);
  202.     fScaleY := Trunc(fScaleRY);
  203.     for I := 0 to fSource.ControlCount-1 do {components with a neg. tag won't print}
  204.     if (fSource.Controls[I].Visible) and (fSource.Controls[I].Tag >= 0) then
  205.       if (fTags = 0) or (fSource.Controls[I].Tag and fTags = fTags) then
  206.         PrintControl(fSource.Controls[I]);
  207.   finally
  208.     Printer.EndDoc;
  209.   end;
  210. end;   {Print}
  211.  
  212. function TPrintPage.Preview: integer;
  213. var LSize, SSize : integer;
  214. begin
  215.   Result := mrCancel;
  216.   if not Assigned(fSource) then exit;
  217.   PrintPreview := TPrintPreview.Create(nil);
  218.   try
  219.     fPreviewing := true;
  220.     PrintPreview.Caption := fPreviewCaption;
  221.     PrintPreview.Print1.Visible := fPreviewMenu;
  222.     PrintPreview.Cancel1.Visible := fPreviewMenu;
  223.     PrintPreview.OnPaint := Paint_Preview;
  224.     fDest := PrintPreview.Canvas;
  225.     PDC := fDest.Handle;
  226.     fScaleRX := 1/fPreviewScale;
  227.     fScaleRY := fScaleRX;
  228.     fScaleX := 1; fScaleY := 1;
  229.     LSize := trunc(fDesignPixelsPerInch * fPreviewHeight * fScaleRX);
  230.     LSize := LSize + trunc(RulerOffset * fScaleRX);
  231.     SSize := trunc(fDesignPixelsPerInch * fPreviewWidth * fScaleRX);
  232.     SSize := SSize + trunc(RulerOffset * fScaleRX);
  233.     PrintPreview.ClientHeight := LSize;
  234.     PrintPreview.ClientWidth := LSize;
  235.     if Printer.Orientation = poLandscape then PrintPreview.ClientHeight := SSize
  236.       else PrintPreview.ClientWidth := SSize;
  237.     Result := PrintPreview.ShowModal;
  238.   finally
  239.     PrintPreview.Free;
  240.     PrintPreview := nil;
  241.     fPreviewing := false;
  242.   end;
  243. end;   {preview}
  244.  
  245. function TPrintPage.ScaleToPrinter(R:TRect):TRect;
  246. begin
  247.   Result.Top := Trunc((R.Top + VScrollPos + VOffset) * fScaleRY);
  248.   Result.Left := Trunc((R.Left + HScrollPos + HOffset) * fScaleRX);
  249.   Result.Bottom := Trunc((R.Bottom + VScrollPos + VOffset) * fScaleRY);
  250.   Result.Right := Trunc((R.Right + HScrollPos + HOffset) * fScaleRX);
  251. end;
  252.  
  253.     { more Private declarations - the Print/Paint stuff }
  254. procedure TPrintPage.DrawHRuler(R:TRect);
  255. var a12th, N, Y : word;
  256.     RX : double;
  257. begin
  258.   a12th := fDesignPixelsPerInch div 12;
  259.   fDest.Font.Size := 10;
  260.   if fPreviewing then
  261.   begin
  262.     fDest.Font.Name := 'Arial';
  263.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  264.   end;
  265.   PDC := fDest.Handle;
  266.   fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  267.   N := 0;
  268.   RX := R.Left;
  269.   Y := R.Top;
  270.   with fDest do
  271.     while trunc(RX) < R.Right do
  272.     begin
  273.       MoveTo(trunc(RX), Y + fScaleY);
  274.       LineTo(trunc(RX), Y + (trunc(6 * fScaleRY) * (1 + byte(N mod 3 = 0) +
  275.         byte(N mod 6 = 0) +
  276.         byte(N mod 12 = 0))));
  277.       if (N > 0) and (N mod 12 = 0) and (PenPos.X < (R.Right - a12th div 2)) then
  278.         TextOut(PenPos.X+trunc(3*fScaleRX), Y+trunc(9*fScaleRY), IntToStr(N div 12));
  279.       N := N + 1;
  280.       RX := RX + a12th * fScaleRX;
  281.     end;
  282. end;
  283.  
  284. procedure TPrintPage.DrawVRuler(R:TRect);
  285. var a6th, N, X : word;
  286.     RY : double;
  287. begin
  288.   a6th := fDesignPixelsPerInch div 6;
  289.   fDest.Font.Size := 10;
  290.   if fPreviewing then
  291.   begin
  292.     fDest.Font.Name := 'Arial';
  293.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  294.   end;
  295.   PDC := fDest.Handle;
  296.   fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  297.   N := 0;
  298.   X := R.Left;
  299.   RY := R.Top;
  300.   with fDest do
  301.     while trunc(RY) < R.Bottom do
  302.     begin
  303.       MoveTo(X + fScaleX, trunc(RY));
  304.       LineTo(X + (trunc(6 * fScaleRX) * (2 + byte(N mod 3 = 0) +
  305.         byte(N mod 6 = 0))),trunc(RY));
  306.       if (N > 0) and (N mod 6 = 0) then
  307.         TextOut(X+trunc(12*fScaleRX), PenPos.Y-trunc(16*fScaleRY), IntToStr(N div 6));
  308.       N := N + 1;
  309.       RY := RY + a6th * fScaleRY;
  310.     end;
  311. end;
  312.  
  313. procedure TPrintPage.PrintLabel(ALabel: TLabel);
  314. const
  315.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  316. var C : array[0..255] of char;
  317.     CLen : integer;
  318.     Format : Word;
  319.     R: TRect;
  320. begin
  321.   fDest.Font := ALabel.Font;
  322.   if fPreviewing then
  323.   begin
  324.     fDest.Font.Name := 'Arial';
  325.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  326.   end;
  327.   PDC := fDest.Handle; {so DrawText knows about font}
  328.   R := ScaleToPrinter(ALabel.BoundsRect);
  329.   R.Right := R.Right + fScaleX*3;
  330.   Format := DT_EXPANDTABS or DT_WORDBREAK or Alignments[ALabel.Alignment];
  331.   CLen := ALabel.GetTextBuf(C,255);
  332.   WinProcs.DrawText(PDC, C, CLen, R, Format);
  333. end; {label}
  334.  
  335. procedure TPrintPage.PrintMemo(AMemo: TMemo);
  336. const
  337.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  338. var C : Pchar;
  339.     CLen : integer;
  340.     Format : Word;
  341.     R: TRect;
  342. begin
  343.   fDest.Font := AMemo.Font;
  344.   if fPreviewing then
  345.   begin
  346.     fDest.Font.Name := 'Arial';
  347.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  348.   end;
  349.   PDC := fDest.Handle;
  350.   R := ScaleToPrinter(AMemo.BoundsRect);
  351.   if AMemo.BorderStyle = bsSingle then
  352.     begin
  353.       fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  354.       R.Left := R.Left + fScaleX + fScaleX;
  355.       R.Right := R.Right - fScaleX - fScaleX;
  356.       R.Top:=R.Top + fScaleY*3;
  357.     end;
  358.   R.Bottom := R.Bottom + fDest.Font.Height;
  359.   Format := DT_EXPANDTABS;
  360.   if AMemo.WordWrap then Format := Format or DT_WORDBREAK;
  361.   Format := Format or Alignments[AMemo.Alignment];
  362.   CLen := AMemo.GetTextLen;
  363.   inc(CLen);
  364.   GetMem(C, CLen);
  365.   AMemo.GetTextBuf(C, CLen);
  366.   WinProcs.DrawText(PDC, C, -1, R, Format);
  367.   FreeMem(C, CLen);
  368. end; {memo}
  369.  
  370. procedure TPrintPage.PrintEdit(AEdit: TEdit);
  371. var C : array[0..255] of char;
  372.     CLen : integer;
  373.     Format : Word;
  374.     R: TRect;
  375. begin
  376.   fDest.Font := AEdit.Font;
  377.   if fPreviewing then
  378.   begin
  379.     fDest.Font.Name := 'Arial';
  380.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  381.   end;
  382.   PDC := fDest.Handle;
  383.   R := ScaleToPrinter(AEdit.BoundsRect);
  384.   if AEdit.BorderStyle = bsSingle then
  385.     fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  386.   R.Left := R.Left + fScaleX + fScaleX;
  387.   Format := DT_SINGLELINE or DT_VCENTER;
  388.   CLen := AEdit.GetTextBuf(C,255);
  389.   WinProcs.DrawText(PDC, C, CLen, R, Format);
  390. end; {edit}
  391.  
  392. procedure TPrintPage.PrintComboBox(ACombo: TComboBox);
  393. var C : array[0..255] of char;
  394.     CLen : integer;
  395.     Format : Word;
  396.     R: TRect;
  397. begin
  398.   fDest.Font := ACombo.Font;
  399.   if fPreviewing then
  400.   begin
  401.     fDest.Font.Name := 'Arial';
  402.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  403.   end;
  404.   PDC := fDest.Handle;
  405.   R := ScaleToPrinter(ACombo.BoundsRect);
  406.   fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  407.   R.Left := R.Left + fScaleX + fScaleX;
  408.   Format := DT_SINGLELINE or DT_VCENTER;
  409.   CLen := ACombo.GetTextBuf(C,255);
  410.   WinProcs.DrawText(PDC, C, CLen, R, Format);
  411. end; {combo}
  412.  
  413. procedure TPrintPage.PrintShape(AShape:TShape);
  414. var H, W, S : integer;
  415.     R : TRect;
  416. begin
  417.   fDest.Pen := AShape.Pen;
  418.   fDest.Pen.Width :=  fDest.Pen.Width * fScaleY;
  419.   fDest.Brush := AShape.Brush;
  420.   R := ScaleToPrinter(AShape.BoundsRect);
  421.   W := R.Right - R.Left; H := R.Bottom - R.Top;
  422.   if W < H then S := W else S := H;
  423.   if AShape.Shape in [stSquare, stRoundSquare, stCircle] then
  424.   begin
  425.     Inc(R.Left, (W - S) div 2);
  426.     Inc(R.Top, (H - S) div 2);
  427.     W := S;
  428.     H := S;
  429.   end;
  430.   case AShape.Shape of
  431.     stRectangle, stSquare:
  432.       fDest.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
  433.     stRoundRect, stRoundSquare:
  434.       fDest.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S div 4);
  435.     stCircle, stEllipse:
  436.       fDest.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
  437.   end;
  438. end; {Shape}
  439.  
  440. procedure TPrintPage.PrintGrid(TheGrid:TObject);
  441. var J, K : integer;
  442.     Q, R : TRect;
  443.     Format : Word;
  444.     C : array[0..255] of char;
  445.     CLen : integer;
  446.     AGrid : TDrawGrid;
  447. begin
  448.   AGrid := TDrawGrid(TheGrid);
  449.   fDest.Font := AGrid.Font;
  450.   if fPreviewing then
  451.   begin
  452.     fDest.Font.Name := 'Arial';
  453.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  454.   end;
  455.   PDC := fDest.Handle;
  456.   Format := DT_SINGLELINE or DT_VCENTER;
  457.   Q := AGrid.BoundsRect;
  458.   fDest.Pen.Width := AGrid.GridLineWidth * fScaleY;
  459.   for J := 0 to AGrid.ColCount - 1 do
  460.     for K:= 0 to AGrid.RowCount - 1 do
  461.     begin
  462.       R := AGrid.CellRect(J, K);
  463.       if R.Right > R.Left then
  464.       begin
  465.         R.Left := R.Left + Q.Left;
  466.         R.Right := R.Right + Q.Left + AGrid.GridLineWidth;
  467.         R.Top := R.Top + Q.Top;
  468.         R.Bottom := R.Bottom + Q.Top + AGrid.GridLineWidth;
  469.         R := ScaleToPrinter(R);
  470.         if (J < AGrid.FixedCols) or (K < AGrid.FixedRows) then
  471.           fDest.Brush.Color := AGrid.FixedColor
  472.         else
  473.         begin
  474.           fDest.Brush.Style := bsClear;
  475.           WinProcs.SetBKColor(fDest.Handle, ColorToRGB(clWhite));
  476.         end;
  477.         if AGrid.GridLineWidth > 0 then  {print grid lines or not}
  478.           fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  479.         C[0] := Chr(0);
  480.         if TheGrid is TStringGrid then
  481.         begin
  482.           StrPCopy(C, TStringGrid(TheGrid).Cells[J,K]);
  483.           R.Left := R.Left + fScaleX + fScaleX;
  484.         end;
  485.         if TheGrid is TCalendar then
  486.         begin
  487.           StrPCopy(C, TCalendar(TheGrid).CellText[J,K]);
  488.           Format := Format or DT_CENTER;
  489.         end;
  490.         WinProcs.DrawText(PDC, C, StrLen(C), R, Format);
  491.       end;
  492.     end;
  493. end; {Grid}
  494.  
  495. procedure TPrintPage.PrintCheck(ACheck: TCheckBox);
  496. var R, BR : TRect;
  497.     W, H : integer;
  498.     C : array[0..255] of char;
  499.     CLen : integer;
  500.     Format : Word;
  501. begin
  502.   fDest.Font := ACheck.Font;
  503.   if fPreviewing then
  504.   begin
  505.     fDest.Font.Name := 'Arial';
  506.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  507.   end;
  508.   PDC := fDest.Handle;
  509.   W := trunc(12 * fScaleRX); H := trunc(12 * fScaleRY);
  510.   R := ScaleToPrinter(ACheck.BoundsRect);
  511.   BR := R;
  512.   BR.Top := R.Top + ((R.Bottom - R.Top) div 2) - (H div 2);
  513.   BR.Bottom := BR.Top + H;
  514.   if ACheck.Alignment = taLeftJustify then
  515.     begin
  516.       BR.Right := R.Right; BR.Left := R.Right - W;
  517.       R.Right := R.Right - W - fScaleX - fScaleX;
  518.     end
  519.     else
  520.     begin
  521.       BR.Right := R.Left + w; BR.Left := R.Left;
  522.       R.Left := R.Left + W + fScaleX + fScaleX;
  523.     end;
  524.   fDest.Rectangle(BR.Left, BR.Top, BR.Right, BR.Bottom);
  525.   if ACheck.Checked then with fDest do
  526.   begin
  527.     fDest.Pen.Width := 2*fScaleY;
  528.     MoveTo(BR.Left+fScaleX, BR.Top + H div 2);
  529.     LineTo(BR.Left + W div 2 - fScaleX, BR.Bottom-2*fScaleY);
  530.     LineTo(BR.Right-fScaleX, BR.Top+fScaleY);
  531.   end;
  532.   Format := DT_SINGLELINE or DT_VCENTER;
  533.   CLen := ACheck.GetTextBuf(C,255);
  534.   WinProcs.DrawText(PDC, C, CLen, R, Format);
  535. end; {Check}
  536.  
  537. procedure TPrintPage.PrintRadio(ARadio: TRadioButton);
  538. var R, BR : TRect;
  539.     W, H, CutX, CutY : integer;
  540.     C : array[0..255] of char;
  541.     CLen : integer;
  542.     Format : Word;
  543. begin
  544.   fDest.Font := ARadio.Font;
  545.   if fPreviewing then
  546.   begin
  547.     fDest.Font.Name := 'Arial';
  548.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  549.   end;
  550.   PDC := fDest.Handle;
  551.   W := trunc(12 * fScaleRX); H := trunc(12 * fScaleRY);
  552.   CutX := W div 3; CutY := H div 3;
  553.   R := ScaleToPrinter(ARadio.BoundsRect);
  554.   BR := R;
  555.   BR.Top := R.Top + ((R.Bottom - R.Top) div 2) - (H div 2);
  556.   BR.Bottom := BR.Top + H;
  557.   if ARadio.Alignment = taLeftJustify then
  558.     begin
  559.       BR.Right := R.Right; BR.Left := R.Right - W;
  560.       R.Right := R.Right - W - fScaleX - fScaleX;
  561.     end
  562.     else
  563.     begin
  564.       BR.Right := R.Left + w; BR.Left := R.Left;
  565.       R.Left := R.Left + W + fScaleX * 3;
  566.     end;
  567.   fDest.Ellipse(BR.Left, BR.Top, BR.Right, BR.Bottom);
  568.   if ARadio.Checked then with fDest do
  569.   begin
  570.     Brush.Color := clBlack;
  571.     Ellipse(BR.Left+CutX, BR.Top+CutY, BR.Right-CutX, BR.Bottom-CutY);
  572.     Brush.Style := bsClear;
  573.     WinProcs.SetBKColor(Handle, ColorToRGB(clWhite));
  574.   end;
  575.   Format := DT_SINGLELINE or DT_VCENTER;
  576.   CLen := ARadio.GetTextBuf(C,255);
  577.   WinProcs.DrawText(PDC, C, CLen, R, Format);
  578. end; {Radio}
  579.  
  580. procedure TPrintPage.PrintBevel(ABevel: TBevel);
  581. var R : TRect;
  582.     AShape : TBevelShape;
  583. begin
  584.   R := ScaleToPrinter(ABevel.BoundsRect);
  585.   AShape := ABevel.Shape;
  586.   with fDest do
  587.     case AShape of
  588.       bsBox, bsFrame: Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  589.       bsTopLine: PolyLine([Point(R.Left,R.Top),Point(R.Right,R.Top)]);
  590.       bsBottomLine: PolyLine([Point(R.Left,R.Bottom),Point(R.Right,R.Bottom)]);
  591.       bsLeftLine: PolyLine([Point(R.Left,R.Top),Point(R.Left,R.Bottom)]);
  592.       bsRightLine: PolyLine([Point(R.Right,R.Top),Point(R.Right,R.Bottom)]);
  593.     end;
  594. end; {bevel}
  595.  
  596. procedure TPrintPage.PrintTabSet(ATabSet: TTabSet);
  597. var R : TRect;
  598. begin
  599.   if ATabSet.TabIndex < 0 then exit;
  600.   fDest.Font := ATabSet.Font;
  601.   fDest.Font.Style := fDest.Font.Style + [fsBold];
  602.   if fPreviewing then
  603.   begin
  604.     fDest.Font.Name := 'Arial';
  605.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  606.   end;
  607.   PDC := fDest.Handle;
  608.   R := ScaleToPrinter(ATabSet.BoundsRect);
  609.   with fDest , ATabSet do
  610.   begin
  611.     TextOut(R.Left + trunc(15*fScaleRX), R.Top, Tabs[TabIndex]);
  612.     MoveTo(R.Left+fScaleX,R.Top);
  613.     R.Left := R.Left + trunc(10*fScaleRX);
  614.     LineTo(R.Left, R.Top);
  615.     R.Left := R.Left + trunc(5*fScaleRX);
  616.     R.Bottom := R.Top + trunc(3*fScaleRY) - fDest.Font.Height;
  617.     LineTo(R.Left, R.Bottom);
  618.     R.Left := R.Left + TextWidth(Tabs[TabIndex]);
  619.     LineTo(R.Left, R.Bottom);
  620.     R.Left := R.Left + trunc(5*fScaleRX);
  621.     LineTo(R.Left, R.Top);
  622.     LineTo(R.Right-fScaleX, R.Top);
  623.   end;
  624. end; {tabset}
  625.  
  626. procedure TPrintPage.PrintImage(AImage: TImage);
  627. var R : TRect;
  628.     Info: PBitmapInfo;
  629.     InfoSize: Integer;
  630.     Image: Pointer;
  631.     ImageSize: Longint;
  632. begin
  633.   if not(AImage.Picture.Graphic is TBitmap) then exit;  {bitmap only}
  634.   R := ScaleToPrinter(AImage.BoundsRect);
  635.   if fPreviewing then
  636.   begin
  637.     fDest.Rectangle(R.Left,R.Top,R.Right,R.Bottom);
  638.     fDest.Font.Size := 7;
  639.     fDest.TextRect(R, R.Left, R.Top, ' Image');
  640.   end
  641.   else
  642.     with AImage.Picture.Bitmap do
  643.     begin
  644.       GetDIBSizes(Handle, InfoSize, ImageSize);
  645.       Info := MemAlloc(InfoSize);
  646.       try
  647.         Image := MemAlloc(ImageSize);
  648.         try
  649.           GetDIB(Handle, Palette, Info^, Image^);
  650.           with Info^.bmiHeader do
  651.             StretchDIBits(fDest.Handle, R.Left, R.Top, R.Right-R.Left,
  652.               R.Bottom-R.Top, 0, 0, biWidth, biHeight, Image, Info^,
  653.               DIB_RGB_COLORS, SRCCOPY);
  654.         finally
  655.           FreeMem(Image, ImageSize);
  656.         end;
  657.       finally
  658.         FreeMem(Info, InfoSize);
  659.       end;
  660.     end;
  661. end; {image}
  662.  
  663. {$IFDEF RULER}
  664. procedure TPrintPage.PrintHRuler(Ruler: THRuler);
  665. var R: TRect;
  666. begin
  667.   R := ScaleToPrinter(Ruler.BoundsRect);
  668.   DrawHRuler(R);
  669. end; {HRuler}
  670.  
  671. procedure TPrintPage.PrintVRuler(Ruler: TVRuler);
  672. var R: TRect;
  673. begin
  674.   R := ScaleToPrinter(Ruler.BoundsRect);
  675.   DrawVRuler(R);
  676. end; {VRuler}
  677. {$ENDIF}
  678.  
  679. {$IFDEF ROTATE}
  680. procedure TPrintPage.PrintRotate(ARotate: TRotateLabel);
  681. var R: TRect;
  682.     LogRec: TLOGFONT;
  683.     OldFont, NewFont: HFONT;
  684.     midX, midY, H, W, X, Y: integer;
  685.     DegToRad, CosAngle, SinAngle: double;
  686.     P1, P2, P3, P4: TPoint;
  687. begin
  688.   R := ScaleToPrinter(ARotate.BoundsRect);
  689.   fDest.Font := ARotate.Font;
  690.   if fPreviewing then
  691.   begin
  692.     fDest.Font.Name := 'Arial';
  693.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  694.   end;
  695.   PDC := fDest.Handle;
  696.   GetObject(fDest.Font.Handle, SizeOf(LogRec), @LogRec);
  697.   LogRec.lfEscapement := ARotate.Angle*10;
  698.   LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
  699.   NewFont := CreateFontIndirect(LogRec);
  700.   OldFont := SelectObject(fDest.Handle,NewFont);
  701.   midX := (R.Right - R.Left) div 2 + R.Left;
  702.   midY := (R.Bottom - R.Top) div 2 + R.Top;
  703.   DegToRad := PI / 180;
  704.   CosAngle := cos(ARotate.Angle * DegToRad);
  705.   SinAngle := sin(ARotate.Angle * DegToRad);
  706.   W := fDest.TextWidth(ARotate.Caption);
  707.   H := fDest.TextHeight(ARotate.Caption);
  708.   X := midX - trunc(W/2*CosAngle) - trunc(H/2*SinAngle);
  709.   Y := midY + trunc(W/2*SinAngle) - trunc(H/2*CosAngle);
  710.   if not ARotate.Transparent then
  711.   begin
  712.     W := W+7*fScaleX; H := H+5*fScaleY;
  713.     P1.X := midX - trunc(W/2*CosAngle) - trunc(H/2*SinAngle);
  714.     P1.Y := midY + trunc(W/2*SinAngle) - trunc(H/2*CosAngle);
  715.     P2.X := midX + trunc(W/2*CosAngle) - trunc(H/2*SinAngle);
  716.     P2.Y := midY - trunc(W/2*SinAngle) - trunc(H/2*CosAngle);
  717.     P3.X := midX + trunc(W/2*CosAngle) + trunc(H/2*SinAngle);
  718.     P3.Y := midY - trunc(W/2*SinAngle) + trunc(H/2*CosAngle);
  719.     P4.X := midX - trunc(W/2*CosAngle) + trunc(H/2*SinAngle);
  720.     P4.Y := midY + trunc(W/2*SinAngle) + trunc(H/2*CosAngle);
  721.     fDest.PolyLine([P1, P2, P3, P4, P1]);
  722.   end;
  723.   fDest.TextOut(X, Y, ARotate.Caption);
  724.   NewFont := SelectObject(fDest.Handle,OldFont);
  725.   DeleteObject(NewFont);
  726. end; {Rotate}
  727. {$ENDIF}
  728.  
  729. procedure TPrintPage.PrintGroup(AGroup: TGroupBox);
  730. var I : integer;
  731.     R, F : TRect;
  732. begin
  733.   R := ScaleToPrinter(AGroup.BoundsRect);
  734.   fDest.Font := AGroup.Font;
  735.   if fPreviewing then
  736.   begin
  737.     fDest.Font.Name := 'Arial';
  738.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  739.   end;
  740.   PDC := fDest.Handle;
  741.   VOffset := VOffset + AGroup.BoundsRect.Top;
  742.   HOffset := HOffset + AGroup.BoundsRect.Left;
  743.   F := R; F.Bottom := F.Bottom - fScaleY;
  744.   F.Top := F.Top - (fDest.Font.Height div 2) + fScaleY;
  745.   F.Left := F.Left + fScaleX; F.Right := F.Right - fScaleX;
  746.   with fDest do
  747.   begin
  748.     if AGroup.Caption = '' then Rectangle(F.Left,F.Top,F.Right,F.Bottom)
  749.     else
  750.     begin
  751.       TextOut(R.Left+trunc(8*fScaleRX), R.Top, AGroup.Caption);
  752.       MoveTo(F.Left+TextWidth(AGroup.Caption)+trunc(10*fScaleRX), F.Top);
  753.       LineTo(F.Right, F.Top); LineTo(F.Right, F.Bottom);
  754.       LineTo(F.Left, F.Bottom); LineTo(F.Left, F.Top);
  755.       LineTo(F.Left+trunc(4*fScaleRX), F.Top);
  756.     end;
  757.   end;
  758.   for I := 0 to AGroup.ControlCount-1 do
  759.     if (AGroup.Controls[I].Visible) and (AGroup.Controls[I].Tag >= 0) then
  760.       if (fTags = 0) or (AGroup.Controls[I].Tag and fTags = fTags) then
  761.         PrintControl(AGroup.Controls[I]);
  762.   VOffset := VOffset - AGroup.BoundsRect.Top;
  763.   HOffset := HOffset - AGroup.BoundsRect.Left;
  764. end; {group}
  765.  
  766. Procedure TPrintPage.PrintPanel(APanel: TPanel);
  767. var I : integer;
  768.     R : TRect;
  769. begin
  770.   R := ScaleToPrinter(APanel.BoundsRect);
  771.   VOffset := VOffset + APanel.BoundsRect.Top;
  772.   HOffset := HOffset + APanel.BoundsRect.Left;
  773.   if APanel.BorderStyle = bsSingle then
  774.   begin
  775.     fDest.PolyLine([Point(R.Left, R.Bottom-fScaleY),
  776.                    Point(R.Left, R.Top),
  777.                    Point(R.Right-fScaleX, R.Top)]);
  778.     fDest.Pen.Width := 2*fScaleY;
  779.     fDest.PolyLine([Point(R.Right-fScaleX, R.Top+fScaleY),
  780.                    Point(R.Right-fScaleX, R.Bottom-fScaleY),
  781.                    Point(R.Left+fScaleX, R.Bottom-fScaleY)]);
  782.     fDest.Pen.Width := fScaleY;
  783.   end;
  784.   for I := 0 to APanel.ControlCount-1 do
  785.     if (APanel.Controls[I].Visible) and (APanel.Controls[I].Tag >= 0) then
  786.       if (fTags = 0) or (APanel.Controls[I].Tag and fTags = fTags) then
  787.         PrintControl(APanel.Controls[I]);
  788.   VOffset := VOffset - APanel.BoundsRect.Top;
  789.   HOffset := HOffset - APanel.BoundsRect.Left;
  790. end; {panel}
  791.  
  792. Procedure TPrintPage.PrintNotebook(ANotebook: TNotebook);
  793. var I : integer;
  794.     APage : TPage;
  795. begin
  796.   VOffset := VOffset + ANotebook.BoundsRect.Top;
  797.   HOffset := HOffset + ANotebook.BoundsRect.Left;
  798.   APage := ANotebook.Pages.Objects[ANotebook.PageIndex] as TPage;
  799.   for I := 0 to APage.ControlCount-1 do
  800.     if (APage.Controls[I].Visible) and (APage.Controls[I].Tag >= 0) then
  801.       if (fTags = 0) or (APage.Controls[I].Tag and fTags = fTags) then
  802.         PrintControl(APage.Controls[I]);
  803.   VOffset := VOffset - ANotebook.BoundsRect.Top;
  804.   HOffset := HOffset - ANotebook.BoundsRect.Left;
  805. end; {notebook}
  806.  
  807. Procedure TPrintPage.PrintTabNotebook(ATabNotebook: TTabbedNotebook);
  808. var I : integer;
  809.     R : TRect;
  810.     APage : TTabPage;
  811. begin
  812.   APage := ATabNotebook.Pages.Objects[ATabNotebook.PageIndex] as TTabPage;
  813.   VOffset := VOffset + ATabNotebook.BoundsRect.Top + APage.BoundsRect.Top;
  814.   HOffset := HOffset + ATabNotebook.BoundsRect.Left + APage.BoundsRect.Left;
  815.   R := ScaleToPrinter(APage.ClientRect);
  816.   fDest.Font := ATabNotebook.TabFont;
  817.   fDest.Font.Style := fDest.Font.Style + [fsBold];
  818.   if fPreviewing then
  819.   begin
  820.     fDest.Font.Name := 'Arial';
  821.     fDest.Font.Size := trunc(fDest.Font.Size / fPreviewScale);
  822.   end;
  823.   PDC := fDest.Handle;
  824.   with fDest , ATabNotebook do
  825.   begin
  826.     TextOut(R.Left + trunc(15*fScaleRX),
  827.             R.Top-trunc(3*fScaleRY)+fDest.Font.Height, Pages[PageIndex]);
  828.     fDest.Pen.Width := 2*fScaleY;
  829.     PolyLine([Point(R.Right,R.Top+fScaleY),
  830.               Point(R.Right,R.Bottom),
  831.               Point(R.Left+fScaleX,R.Bottom)]);
  832.     fDest.Pen.Width := fScaleY;
  833.     MoveTo(R.Left,R.Bottom);
  834.     LineTo(R.Left,R.Top);
  835.     R.Left := R.Left + trunc(10*fScaleRX);
  836.     LineTo(R.Left, R.Top);
  837.     R.Left := R.Left + trunc(5*fScaleRX);
  838.     LineTo(R.Left, R.Top - trunc(6*fScaleRY) + fDest.Font.Height);
  839.     R.Left := R.Left + TextWidth(Pages[PageIndex]);
  840.     LineTo(R.Left, R.Top - trunc(6*fScaleRY) + fDest.Font.Height);
  841.     R.Left := R.Left + trunc(5*fScaleRX);
  842.     LineTo(R.Left, R.Top);
  843.     LineTo(R.Right, R.Top);
  844.   end;
  845.   for I := 0 to APage.ControlCount-1 do
  846.     if (APage.Controls[I].Visible) and (APage.Controls[I].Tag >= 0) then
  847.       if (fTags = 0) or (APage.Controls[I].Tag and fTags = fTags) then
  848.         PrintControl(APage.Controls[I]);
  849.   VOffset := VOffset - ATabNotebook.BoundsRect.Top - APage.BoundsRect.Top;
  850.   HOffset := HOffset - ATabNotebook.BoundsRect.Left - APage.BoundsRect.Left;
  851. end; {tabnotebook}
  852.  
  853. procedure TPrintPage.PrintControl(AControl: TObject);
  854. begin
  855.   fDest.Pen.Width := fScaleY;
  856.   fDest.Pen.Color := clBlack;
  857.   fDest.Pen.Style := psSolid;
  858.   fDest.Brush.Style := bsClear;
  859.   WinProcs.SetBKColor(fDest.Handle, ColorToRGB(clWhite));
  860.   if Assigned(fOnExternalPrint) then fOnExternalPrint(AControl);
  861.   if not fPreviewing then
  862.     if Assigned(fOnPrintControl) then fOnPrintControl(AControl);
  863.  
  864.   if (AControl is TCustomLabel) {$IFDEF ROTATE} and
  865.   not(AControl is TRotateLabel) {$ENDIF}
  866.                                    then PrintLabel(TLabel(AControl));
  867.   if (AControl is TCustomMemo)     then PrintMemo(TMemo(AControl));
  868.   if (AControl is TCustomEdit) and
  869.   not(AControl is TCustomMemo)     then PrintEdit(TEdit(AControl));
  870.   if (AControl is TCustomComboBox) then PrintComboBox(TComboBox(AControl));
  871.   if (AControl is TShape)          then PrintShape(TShape(AControl));
  872.   if (AControl is TStringGrid) or
  873.      (AControl is TCalendar)       then PrintGrid(AControl);
  874.   if (AControl is TCustomCheckBox) then PrintCheck(TCheckBox(AControl));
  875.   if (AControl is TRadioButton)    then PrintRadio(TRadioButton(AControl));
  876.   if (AControl is TBevel)          then PrintBevel(TBevel(AControl));
  877.   if (AControl is TTabSet)         then PrintTabSet(TTabSet(AControl));
  878.   if (AControl is TImage)          then PrintImage(TImage(AControl));
  879.   {$IFDEF RULER}
  880.   if (AControl is THRuler)         then PrintHRuler(THRuler(AControl));
  881.   if (AControl is TVRuler)         then PrintVRuler(TVRuler(AControl));
  882.   {$ENDIF}
  883.   {$IFDEF ROTATE}
  884.   if (AControl is TRotateLabel)    then PrintRotate(TRotateLabel(AControl));
  885.   {$ENDIF}
  886.   if (AControl is TCustomGroupBox) then PrintGroup(TGroupBox(AControl));
  887.   if (AControl is TPanel)          then PrintPanel(TPanel(AControl));
  888.   if (AControl is TNotebook)       then PrintNotebook(TNotebook(AControl));
  889.   if (AControl is TTabbedNotebook) then PrintTabNotebook(TTabbedNotebook(AControl));
  890. end;  {printcontrol}
  891.  
  892. end.
  893.