Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 
  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.