Title: How to print a TMemo, TStringlist, TStrings
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 .x then
Left := printorigin.x;
Top := Round(topmargin * Y_resolution);
if Top .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 .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 .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 .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;