Печать TMemo, TStringList или TStrings

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

Другое по теме:

• Escape код PASSTHROUGH
• Вместо печати графики использовать резидентный шрифт принтера
• Вывести все способы подачи бумаги для печати