Print Strings & TStrings

uses Printers

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);
      
type
  THeaderFooterProc =
    procedure(aCanvas : TCanvas; aPageCount : integer;
    aTextrect : TRect; var Continue : boolean) of object;
    
//

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;

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;

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;