Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
How to Print a TMemo, TStringlist, TStrings Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
14-Apr-04
Category
Reporting /Printing
Language
Delphi 5.x
Views
174
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Peter Below

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.

1   unit PrintStringsUnit1;
2   
3   interface
4   
5   uses
6     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
7     Dialogs,
8     StdCtrls;
9   
10  type
11    TForm1 = class(TForm)
12      Memo1: TMemo;
13      Button1: TButton;
14      procedure Button1Click(Sender: TObject);
15    private
16      { Private declarations }
17      procedure PrintHeader(aCanvas: TCanvas; aPageCount: integer;
18        aTextrect: TRect; var Continue: boolean);
19      procedure PrintFooter(aCanvas: TCanvas; aPageCount: integer;
20        aTextrect: TRect; var Continue: boolean);
21    public
22      { Public declarations }
23    end;
24  
25  var
26    Form1: TForm1;
27  
28  implementation
29  
30  uses Printers;
31  {$R *.DFM}
32  
33  type
34    THeaderFooterProc =
35      procedure(aCanvas: TCanvas; aPageCount: integer;
36      aTextrect: TRect; var Continue: boolean) of object;
37    { Prototype for a callback method that PrintString will call
38      when it is time to print a header or footer on a page. The
39      parameters that will be passed to the callback are:
40      aCanvas   : the canvas to output on
41      aPageCount: page number of the current page, counting from 1
42      aTextRect : output rectangle that should be used. This will be
43                  the area available between non-printable margin and
44                  top or bottom margin, in device units (dots). Output
45                  is not restricted to this area, though.
46      continue  : will be passed in as True. If the callback sets it
47                  to false the print job will be aborted. }
48  
49  {+------------------------------------------------------------
50  | Function PrintStrings
51  |
52  | Parameters :
53  |   lines:
54  |     contains the text to print, already formatted into
55  |     lines of suitable length. No additional wordwrapping
56  |     will be done by this routine and also no text clipping
57  |     on the right margin!
58  |   leftmargin, topmargin, rightmargin, bottommargin:
59  |     define the print area. Unit is inches, the margins are
60  |     measured from the edge of the paper, not the printable
61  |     area, and are positive values! The margin will be adjusted
62  |     if it lies outside the printable area.
63  |   linesPerInch:
64  |     used to calculate the line spacing independent of font
65  |     size.
66  |   aFont:
67  |     font to use for printout, must not be Nil.
68  |   measureonly:
69  |     If true the routine will only count pages and not produce any
70  |     output on the printer. Set this parameter to false to actually
71  |     print the text.
72  |   OnPrintheader:
73  |     can be Nil. Callback that will be called after a new page has
74  |     been started but before any text has been output on that page.
75  |     The callback should be used to print a header and/or a watermark
76  |     on the page.
77  |   OnPrintfooter:
78  |     can be Nil. Callback that will be called after all text for one
79  |     page has been printed, before a new page is started. The  callback
80  |     should be used to print a footer on the page.
81  | Returns:
82  |   number of pages printed. If the job has been aborted the return
83  |   value will be 0.
84  | Description:
85  |   Uses the Canvas.TextOut function to perform text output in
86  |   the rectangle defined by the margins. The text can span
87  |   multiple pages.
88  | Nomenclature:
89  |   Paper coordinates are relative to the upper left corner of the
90  |   physical page, canvas coordinates (as used by Delphis  Printer.Canvas)
91  |   are relative to the upper left corner of the printable area. The
92  |   printorigin variable below holds the origin of the canvas  coordinate
93  |   system in paper coordinates. Units for both systems are printer
94  |   dots, the printers device unit, the unit for resolution is dots
95  |   per inch (dpi).
96  | Error Conditions:
97  |   A valid font is required. Margins that are outside the printable
98  |   area will be corrected, invalid margins will raise an EPrinter
99  |   exception.
100 | Created: 13.05.99 by P. Below
101 +------------------------------------------------------------}
102 
103 function PrintStrings(Lines: TStrings;
104   const leftmargin, rightmargin,
105   topmargin, bottommargin: single;
106   const linesPerInch: single;
107   aFont: TFont;
108   measureonly: Boolean;
109   OnPrintheader,
110   OnPrintfooter: THeaderFooterProc): Integer;
111 var
112   continuePrint: Boolean; { continue/abort flag for callbacks }
113   pagecount: Integer; { number of current page }
114   textrect: TRect; { output area, in canvas coordinates }
115   headerrect: TRect; { area for header, in canvas
116   coordinates }
117   footerrect: TRect; { area for footes, in canvas
118   coordinates }
119   lineheight: Integer; { line spacing in dots }
120   charheight: Integer; { font height in dots  }
121   textstart: Integer; { index of first line to print on
122   current page, 0-based. }
123 
124 { Calculate text output and header/footer rectangles. }
125   procedure CalcPrintRects;
126   var
127     X_resolution: Integer; { horizontal printer resolution, in dpi }
128     Y_resolution: Integer; { vertical printer resolution, in dpi }
129     pagerect: TRect; { total page, in paper coordinates }
130     printorigin: TPoint; { origin of canvas coordinate system in
131     paper coordinates. }
132 
133 { Get resolution, paper size and non-printable margin from
134 printer driver. }
135     procedure GetPrinterParameters;
136     begin
137       with Printer.Canvas do
138       begin
139         X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
140         Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
141         printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
142         printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
143         pagerect.Left := 0;
144         pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
145         pagerect.Top := 0;
146         pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
147       end; { With }
148     end; { GetPrinterParameters }
149 
150     { Calculate area between the requested margins, paper-relative.
151       Adjust margins if they fall outside the printable area.
152       Validate the margins, raise EPrinter exception if no text area
153       is left. }
154     procedure CalcRects;
155     var
156       max: integer;
157     begin
158       with textrect do
159       begin
160         { Figure textrect in paper coordinates }
161         Left := Round(leftmargin * X_resolution);
162         if Left < printorigin.x then
163           Left := printorigin.x;
164 
165         Top := Round(topmargin * Y_resolution);
166         if Top < printorigin.y then
167           Top := printorigin.y;
168 
169         { Printer.PageWidth and PageHeight return the size of the
170           printable area, we need to add the printorigin to get the
171           edge of the printable area in paper coordinates. }
172         Right := pagerect.Right - Round(rightmargin * X_resolution);
173         max := Printer.PageWidth + printorigin.X;
174         if Right > max then
175           Right := max;
176 
177         Bottom := pagerect.Bottom - Round(bottommargin *
178           Y_resolution);
179         max := Printer.PageHeight + printorigin.Y;
180         if Bottom > max then
181           Bottom := max;
182 
183         { Validate the margins. }
184         if (Left >= Right) or (Top >= Bottom) then
185           raise
186             EPrinter.Create('PrintString: the supplied margins are too large, there
187             '
188             'is no area to print left on the page.');
189       end; { With }
190 
191       { Convert textrect to canvas coordinates. }
192       OffsetRect(textrect, -printorigin.X, -printorigin.Y);
193 
194       { Build header and footer rects. }
195       headerrect := Rect(textrect.Left, 0,
196         textrect.Right, textrect.Top);
197       footerrect := Rect(textrect.Left, textrect.Bottom,
198         textrect.Right, Printer.PageHeight);
199     end; { CalcRects }
200   begin { CalcPrintRects }
201     GetPrinterParameters;
202     CalcRects;
203     lineheight := round(Y_resolution / linesPerInch);
204   end; { CalcPrintRects }
205 
206   { Print a page with headers and footers. }
207   procedure PrintPage;
208     procedure FireHeaderFooterEvent(event: THeaderFooterProc; r: TRect);
209     begin
210       if Assigned(event) then
211       begin
212         event(Printer.Canvas,
213           pagecount,
214           r,
215           ContinuePrint);
216         { Revert to our font, in case event handler changed
217           it. }
218         Printer.Canvas.Font := aFont;
219       end; { If }
220     end; { FireHeaderFooterEvent }
221 
222     procedure DoHeader;
223     begin
224       FireHeaderFooterEvent(OnPrintHeader, headerrect);
225     end; { DoHeader }
226 
227     procedure DoFooter;
228     begin
229       FireHeaderFooterEvent(OnPrintFooter, footerrect);
230     end; { DoFooter }
231 
232     procedure DoPage;
233     var
234       y: integer;
235     begin
236       y := textrect.Top;
237       while (textStart < Lines.Count) and
238         (y <= (textrect.Bottom - charheight)) do
239       begin
240         { Note: use TextRect instead of TextOut to effect clipping
241           of the line on the right margin. It is a bit slower,
242           though. The clipping rect would be
243           Rect( textrect.left, y, textrect.right, y+charheight). }
244         printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
245         Inc(textStart);
246         Inc(y, lineheight);
247       end; { While }
248     end; { DoPage }
249   begin { PrintPage }
250     DoHeader;
251     if ContinuePrint then
252     begin
253       DoPage;
254       DoFooter;
255       if (textStart < Lines.Count) and ContinuePrint then
256       begin
257         Inc(pagecount);
258         Printer.NewPage;
259       end; { If }
260     end;
261   end; { PrintPage }
262 begin { PrintStrings }
263   Assert(Assigned(afont),
264     'PrintString: requires a valid aFont parameter!');
265 
266   continuePrint := True;
267   pagecount := 1;
268   textstart := 0;
269   Printer.BeginDoc;
270   try
271     CalcPrintRects;
272 {$IFNDEF WIN32}
273     { Fix for Delphi 1 bug. }
274     Printer.Canvas.Font.PixelsPerInch := Y_resolution;
275 {$ENDIF }
276     Printer.Canvas.Font := aFont;
277     charheight := printer.Canvas.TextHeight('Äy');
278     while (textstart < Lines.Count) and ContinuePrint do
279       PrintPage;
280   finally
281     if continuePrint and not measureonly then
282       Printer.EndDoc
283     else
284     begin
285       Printer.Abort;
286     end;
287   end;
288 
289   if continuePrint then
290     Result := pagecount
291   else
292     Result := 0;
293 end; { PrintStrings }
294 
295 procedure TForm1.Button1Click(Sender: TObject);
296 begin
297   ShowMessage(Format('%d pages printed',
298     [PrintStrings(memo1.Lines,
299       0.75, 0.5, 0.75, 1,
300       6,
301       memo1.Font,
302       False,
303       PrintHeader, PrintFooter)
304     ]));
305 end;
306 
307 procedure TForm1.PrintFooter(aCanvas: TCanvas; aPageCount: integer;
308   aTextrect: TRect; var Continue: boolean);
309 var
310   S: string;
311   res: integer;
312 begin
313   with aCanvas do
314   begin
315     { Draw a gray line one point wide below the text }
316     res := GetDeviceCaps(Handle, LOGPIXELSY);
317     pen.Style := psSolid;
318     pen.Color := clGray;
319     pen.Width := Round(res / 72);
320     MoveTo(aTextRect.Left, aTextRect.Top);
321     LineTo(aTextRect.Right, aTextRect.Top);
322     { Print the page number in Arial 8pt, gray, on right side of
323       footer rect. }
324     S := Format('Page %d', [aPageCount]);
325     Font.Name := 'Arial';
326     Font.Size := 8;
327     Font.Color := clGray;
328     TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
329       18,
330       S);
331   end;
332 end;
333 
334 procedure TForm1.PrintHeader(aCanvas: TCanvas; aPageCount: integer;
335   aTextrect: TRect; var Continue: boolean);
336 var
337   res: Integer;
338 begin
339   with aCanvas do
340   begin
341     { Draw a gray line one point wide 4 points above the text }
342     res := GetDeviceCaps(Handle, LOGPIXELSY);
343     pen.Style := psSolid;
344     pen.Color := clGray;
345     pen.Width := Round(res / 72);
346     MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
347     LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
348     { Print the company name in Arial 8pt, gray, on left side of
349       footer rect. }
350     Font.Name := 'Arial';
351     Font.Size := 8;
352     Font.Color := clGray;
353     TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
354       TextHeight('W'),
355       'W. W. Shyster & Cie.');
356   end;
357 end;
358 
359 end.


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC