delphi 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
+------------------------------------------------------------}

{ 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('膟');
    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.