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