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

Советы » Принтеры и Печать » Печать 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

.

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

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com