Tips (1541)

Tip Rating (71):

{
  The following example project
  shows how to print a memos lines, but you can as well use
  listbox.items, it will work with every TStrings descendent, even a
  TStirnglist.
}

unit PrintStringsUnit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender : TObject);
  private
    { Private declarations }
    procedure PrintHeader(aCanvas : TCanvas; aPageCount : integer;
      aTextrect : TRect; var Continue : boolean);
    procedure PrintFooter(aCanvas : TCanvas; aPageCount : integer;
      aTextrect : TRect; var Continue : boolean);
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;

implementation

uses Printers;
{$R *.DFM}

type
  THeaderFooterProc =
    procedure(aCanvas : TCanvas; aPageCount : integer;
    aTextrect : TRect; var Continue : boolean) of object;
   { Prototype for a callback method that PrintString will call
     when it is time to print a header or footer on a page. The
     parameters that will be passed to the callback are:
     aCanvas   : the canvas to output on
     aPageCount: page number of the current page, counting from 1
     aTextRect : output rectangle that should be used. This will be
                 the area available between non-printable margin and
                 top or bottom margin, in device units (dots). Output
                 is not restricted to this area, though.
     continue  : will be passed in as True. If the callback sets it
                 to false the print job will be aborted. }

{+------------------------------------------------------------
 | Function PrintStrings
 |
 | Parameters :
 |   lines:
 |     contains the text to print, already formatted into
 |     lines of suitable length. No additional wordwrapping
 |     will be done by this routine and also no text clipping
 |     on the right margin!
 |   leftmargin, topmargin, rightmargin, bottommargin:
 |     define the print area. Unit is inches, the margins are
 |     measured from the edge of the paper, not the printable
 |     area, and are positive values! The margin will be adjusted
 |     if it lies outside the printable area.
 |   linesPerInch:
 |     used to calculate the line spacing independent of font
 |     size.
 |   aFont:
 |     font to use for printout, must not be Nil.
 |   measureonly:
 |     If true the routine will only count pages and not produce any
 |     output on the printer. Set this parameter to false to actually
 |     print the text.
 |   OnPrintheader:
 |     can be Nil. Callback that will be called after a new page has
 |     been started but before any text has been output on that page.
 |     The callback should be used to print a header and/or a watermark
 |     on the page.
 |   OnPrintfooter:
 |     can be Nil. Callback that will be called after all text for one
 |     page has been printed, before a new page is started. The  callback
 |     should be used to print a footer on the page.
 | Returns:
 |   number of pages printed. If the job has been aborted the return
 |   value will be 0.
 | Description:
 |   Uses the Canvas.TextOut function to perform text output in
 |   the rectangle defined by the margins. The text can span
 |   multiple pages.
 | Nomenclature:
 |   Paper coordinates are relative to the upper left corner of the
 |   physical page, canvas coordinates (as used by Delphis  Printer.Canvas)
 |   are relative to the upper left corner of the printable area. The
 |   printorigin variable below holds the origin of the canvas  coordinate
 |   system in paper coordinates. Units for both systems are printer
 |   dots, the printers device unit, the unit for resolution is dots
 |   per inch (dpi).
 | Error Conditions:
 |   A valid font is required. Margins that are outside the printable
 |   area will be corrected, invalid margins will raise an EPrinter
 |   exception.
 | Created: 13.05.99 by P. Below
 +------------------------------------------------------------}
function PrintStrings(Lines : TStrings;
  const leftmargin, rightmargin,
  topmargin, bottommargin: single;
  const linesPerInch: single;
  aFont: TFont;
  measureonly: Boolean;
  OnPrintheader,
  OnPrintfooter: THeaderFooterProc): Integer;
var
  continuePrint: Boolean;     { continue/abort flag for callbacks }
  pagecount: Integer;     { number of current page }
  textrect: TRect;       { output area, in canvas coordinates }
  headerrect: TRect;       { area for header, in canvas
coordinates }
  footerrect: TRect;       { area for footes, in canvas
coordinates }
  lineheight: Integer;     { line spacing in dots }
  charheight: Integer;     { font height in dots  }
  textstart: Integer;     { index of first line to print on
                                  current page, 0-based. }

  { Calculate text output and header/footer rectangles. }
  procedure CalcPrintRects;
  var
    X_resolution : Integer;  { horizontal printer resolution, in dpi }
    Y_resolution : Integer;  { vertical printer resolution, in dpi }
    pagerect : TRect;    { total page, in paper coordinates }
    printorigin : TPoint;   { origin of canvas coordinate system in
                                paper coordinates. }

    { Get resolution, paper size and non-printable margin from
      printer driver. }
    procedure GetPrinterParameters;
    begin
      with Printer.Canvas do
      begin
        X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
        Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
        printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
        printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
        pagerect.Left := 0;
        pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
        pagerect.Top := 0;
        pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
      end; { With }
    end; { GetPrinterParameters }

    { Calculate area between the requested margins, paper-relative.
      Adjust margins if they fall outside the printable area.
      Validate the margins, raise EPrinter exception if no text area
      is left. }
    procedure CalcRects;
    var
      max : integer;
    begin
      with textrect do
      begin
        { Figure textrect in paper coordinates }
        Left := Round(leftmargin * X_resolution);
        if Left < printorigin.x then
          Left := printorigin.x;

        Top := Round(topmargin * Y_resolution);
        if Top < printorigin.y then
          Top := printorigin.y;

          { Printer.PageWidth and PageHeight return the size of the
            printable area, we need to add the printorigin to get the
            edge of the printable area in paper coordinates. }
        Right := pagerect.Right - Round(rightmargin * X_resolution);
        max := Printer.PageWidth + printorigin.X;
        if Right > max then
          Right := max;

        Bottom := pagerect.Bottom - Round(bottommargin *
          Y_resolution);
        max := Printer.PageHeight + printorigin.Y;
        if Bottom > max then
          Bottom := max;

        { Validate the margins. }
        if (Left >= Right) or (Top >= Bottom) then
          raise EPrinter.Create('PrintString: the supplied margins are too large, there
            ' +
            'is no area to print left on the page.');
      end; { With }

      { Convert textrect to canvas coordinates. }
      OffsetRect(textrect, - printorigin.X, - printorigin.Y);

      { Build header and footer rects. }
      headerrect := Rect(textrect.Left, 0,
        textrect.Right, textrect.Top);
      footerrect := Rect(textrect.Left, textrect.Bottom,
        textrect.Right, Printer.PageHeight);
    end; { CalcRects }
  begin { CalcPrintRects }
    GetPrinterParameters;
    CalcRects;
    lineheight := round(Y_resolution / linesPerInch);
  end; { CalcPrintRects }

  { Print a page with headers and footers. }
  procedure PrintPage;
    procedure FireHeaderFooterEvent(event : THeaderFooterProc; r : TRect);
    begin
      if Assigned(event) then
      begin
        event(Printer.Canvas,
          pagecount,
          r,
          ContinuePrint);
          { Revert to our font, in case event handler changed
            it. }
        Printer.Canvas.Font := aFont;
      end; { If }
    end; { FireHeaderFooterEvent }

    procedure DoHeader;
    begin
      FireHeaderFooterEvent(OnPrintHeader, headerrect);
    end; { DoHeader }

    procedure DoFooter;
    begin
      FireHeaderFooterEvent(OnPrintFooter, footerrect);
    end; { DoFooter }

    procedure DoPage;
    var
      y : integer;
    begin
      y := textrect.Top;
      while (textStart < Lines.Count) and
        (y <= (textrect.Bottom - charheight)) do
      begin
          { Note: use TextRect instead of TextOut to effect clipping
            of the line on the right margin. It is a bit slower,
            though. The clipping rect would be
            Rect( textrect.left, y, textrect.right, y+charheight). }
        printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
        Inc(textStart);
        Inc(y, lineheight);
      end; { While }
    end; { DoPage }
  begin { PrintPage }
    DoHeader;
    if ContinuePrint then
    begin
      DoPage;
      DoFooter;
      if (textStart < Lines.Count) and ContinuePrint then
      begin
        Inc(pagecount);
        Printer.NewPage;
      end; { If }
    end;
  end; { PrintPage }
begin { PrintStrings }
  Assert(Assigned(afont),
    'PrintString: requires a valid aFont parameter!');

  continuePrint := True;
  pagecount := 1;
  textstart := 0;
  Printer.BeginDoc;
  try
    CalcPrintRects;
    {$IFNDEF WIN32}
    { Fix for Delphi 1 bug. }
    Printer.Canvas.Font.PixelsPerInch := Y_resolution;
    {$ENDIF }
    Printer.Canvas.Font := aFont;
    charheight := printer.Canvas.TextHeight('Äy');
    while (textstart < Lines.Count) and ContinuePrint do
      PrintPage;
  finally
    if continuePrint and not measureonly then
      Printer.EndDoc
    else
    begin
      Printer.Abort;
    end;
  end;

  if continuePrint then
    Result := pagecount
  else
    Result := 0;
end; { PrintStrings }


procedure TForm1.Button1Click(Sender : TObject);
begin
  ShowMessage(Format('%d pages printed',
    [PrintStrings(memo1.Lines,
    0.75, 0.5, 0.75, 1,
    6,
    memo1.Font,
    False,
    PrintHeader, PrintFooter)
    ]));
end;

procedure TForm1.PrintFooter(aCanvas : TCanvas; aPageCount : integer;
  aTextrect : TRect; var Continue : boolean);
var
  S: string;
  res: integer;
begin
  with aCanvas do
  begin
    { Draw a gray line one point wide below the text }
    res := GetDeviceCaps(Handle, LOGPIXELSY);
    pen.Style := psSolid;
    pen.Color := clGray;
    pen.Width := Round(res / 72);
    MoveTo(aTextRect.Left, aTextRect.Top);
    LineTo(aTextRect.Right, aTextRect.Top);
    { Print the page number in Arial 8pt, gray, on right side of
      footer rect. }
    S := Format('Page %d', [aPageCount]);
    Font.Name := 'Arial';
    Font.Size := 8;
    Font.Color := clGray;
    TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
      18,
      S);
  end;
end;

procedure TForm1.PrintHeader(aCanvas : TCanvas; aPageCount : integer;
  aTextrect : TRect; var Continue : boolean);
var
  res: Integer;
begin
  with aCanvas do
  begin
    { Draw a gray line one point wide 4 points above the text }
    res := GetDeviceCaps(Handle, LOGPIXELSY);
    pen.Style := psSolid;
    pen.Color := clGray;
    pen.Width := Round(res / 72);
    MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
    LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
    { Print the company name in Arial 8pt, gray, on left side of
      footer rect. }
    Font.Name := 'Arial';
    Font.Size := 8;
    Font.Color := clGray;
    TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
      TextHeight('W'),
      'W. W. Shyster & Cie.');
  end;
end;

end.