Print a TMemo, TStringlist, TStrings

Problem/Question/Abstract:

How to print a TMemo, TStringlist or TStrings?

Answer:

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.