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 get the names, ID's and sizes for paper formats and bins supported by a p 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
07-Oct-02
Category
Reporting /Printing
Language
Delphi 2.x
Views
185
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Jonas Bilinkevicius

I'm trying to get a list of paper sizes for a given printer. The same list that's 
in the drop downs in the printer setup dialogs. It appears to be printer dependent. 
I tried EnumForms (in Win2000) but that gave a very large list (139 items). The 
printer setup dlg only lists about a dozen for each printer. This list seems to be 
the same list via Control Panel | Printers | Server Properties | Forms. Also, the 
names are slightly different in the printer setup dialog. instead of "Letter" the 
dialog has "Letter 81/2 x 11 in" (for some of my printers). I also tried 
DeviceCapabilities with the DC_PAPERNAMES flag, but that only returned the current 
paper size, though with the more user-friendly dialog paper size name ("Letter 81/2 
x 11 in"). Frankly I expected DeviceCapabilities to be the solution. EnumForms is a 
WinNT call. I assume there's another API for Win9x.

Answer:

Pick what you need from the unit below:


1   {
2   PrintUtils:
3   This unit collects a number of printer-related helper routines.
4   Author: Dr. Peter Below
5   Version 1.0 created 26.11.2001
6   Current revision: 1.01
7   Last modified: 03.12.2001
8   }
9   
10  {$BOOLEVAL OFF} {Unit depends on shortcut boolean evaluation}
11  unit PrintUtils;
12  
13  interface
14  
15  uses
16    Windows, Classes, DblRect;
17  
18  type
19    TPaperName = array[0..63] of Char;
20    TPaperInfo = packed record
21      papername: TPapername; { display name of the paper }
22      paperID: Word; { DMPAPER_* ID }
23      papersize: TPoint; { Size in 0.1 mm }
24    end;
25    TPaperInfos = array of TPaperInfo;
26    TPaperSizes = array of TPoint;
27    TPageInfo = record
28      width, height: Integer; { physical width and height, in dots }
29      offsetX, offsetY: Integer; { nonprintable margin, in dots }
30      resX, resY: Integer; { logical resolution, dots per inch }
31    end;
32  
33    {Return the names, IDs, and sizes for all paper formats supported by a printer. 
34  Index is the index of the printer in the Printers array, or -1 if the default 
35  printer should be examined.}
36  procedure GetPaperInfo(var infos: TPaperInfos; index: Integer = -1);
37  {Return the names and IDs for all bins supported by a printer. The IDs are returned 
38  in the
39  strings Objects property. Index is the index of the printer in the Printers array, 
40  or -1 if the default printer should be examined.}
41  procedure GetBinnames(sl: TStrings; index: Integer = -1);
42  {Return the names and IDs for all paper formats supported by a printer. The IDs are 
43  returned in the strings Objects property. Index is the index of the printer in the 
44  Printers array, or -1 if the default printer should be examined.}
45  procedure GetPapernames(sl: TStrings; index: Integer = -1);
46  {Return page information for the selected printer.}
47  procedure GetPageinfo(var info: TPageInfo; index: Integer = -1);
48  {Convert a page-relative position in mm to a printer canvas position in dots. The 
49  page coordinate system is oriented the same as the MM_TEXT canvas coordinate 
50  system, origin at top left of  page, positive Y axis downwards.}
51  function PointMMtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
52  {Convert a printer canvas position in dots to a page-relative position in mm. The 
53  page coordinate system is oriented the same as the MM_TEXT canvas coordinate 
54  system, origin at top left of page, positive Y axis downwards.}
55  function PointDotsToMM(const pt: TPoint; const info: TPageInfo): TDoublePoint;
56  {Convert a page-relative position in inch to a printer canvas position in dots. The 
57  page coordinate system is oriented the same as the MM_TEXT canvas coordinate 
58  system, origin at top left of page, positive Y axis downwards.}
59  function PointInchtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
60  {Convert a printer canvas position in dots to a page-relative position in inch. The 
61  page coordinate system is oriented the same as the MM_TEXT canvas coordinate 
62  system, origin at top left of page, positive Y axis downwards.}
63  function PointDotsToInch(const pt: TPoint; const info: TPageInfo): TDoublePoint;
64  {Convert inches to mm}
65  function InchToMM(const value: Double): Double;
66  {Convert mm to inches}
67  function MMToInch(const value: Double): Double;
68  {Select a printer bin. The parameter is the DMBIN_* index to use. The current 
69  printer is always used.}
70  procedure SelectPrinterBin(binID: SmallInt);
71  {Select a standard paper size. The parameter is the DMPAPER_* index to use. The 
72  current printer
73  is always used.}
74  procedure SelectPaper(paperID: SmallInt);
75  {Reload a printers DEVMODE record.}
76  procedure ResetPrinter;
77  
78  implementation
79  
80  uses
81    WinSpool, Sysutils, Printers;
82  
83  procedure GetBinnames(sl: TStrings; index: Integer);
84  type
85    TBinName = array[0..23] of Char;
86    TBinNameArray = array[1..High(Integer) div Sizeof(TBinName)] of TBinName;
87    PBinnameArray = ^TBinNameArray;
88    TBinArray = array[1..High(Integer) div Sizeof(Word)] of Word;
89    PBinArray = ^TBinArray;
90  var
91    Device, Driver, Port: array[0..255] of Char;
92    hDevMode: THandle;
93    i, numBinNames, numBins, temp: Integer;
94    pBinNames: PBinnameArray;
95    pBins: PBinArray;
96  begin
97    Assert(Assigned(sl));
98    Printer.PrinterIndex := index;
99    Printer.GetPrinter(Device, Driver, Port, hDevmode);
100   numBinNames := WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, nil, nil);
101   numBins := WinSpool.DeviceCapabilities(Device, Port, DC_BINS, nil, nil);
102   if numBins <> numBinNames then
103   begin
104     raise Exception.Create('DeviceCapabilities reports different number of bins and 
105 '+  'bin names!');
106   end;
107   if numBinNames > 0 then
108   begin
109     GetMem(pBinNames, numBinNames * Sizeof(TBinname));
110     GetMem(pBins, numBins * Sizeof(Word));
111     try
112       WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, Pchar(pBinNames), nil);
113       WinSpool.DeviceCapabilities(Device, Port, DC_BINS, Pchar(pBins), nil);
114       sl.clear;
115       for i := 1 to numBinNames do
116       begin
117         temp := pBins^[i];
118         sl.addObject(pBinNames^[i], TObject(temp));
119       end;
120     finally
121       FreeMem(pBinNames);
122       if pBins <> nil then
123         FreeMem(pBins);
124     end;
125   end;
126 end;
127 
128 procedure GetPapernames(sl: TStrings; index: Integer);
129 type
130   TPaperNameArray = array[1..High(Integer) div Sizeof(TPaperName)] of TPaperName;
131   PPapernameArray = ^TPaperNameArray;
132   TPaperArray = array[1..High(Integer) div Sizeof(Word)] of Word;
133   PPaperArray = ^TPaperArray;
134 var
135   Device, Driver, Port: array[0..255] of Char;
136   hDevMode: THandle;
137   i, numPaperNames, numPapers, temp: Integer;
138   pPaperNames: PPapernameArray;
139   pPapers: PPaperArray;
140 begin
141   Assert(Assigned(sl));
142   Printer.PrinterIndex := index;
143   Printer.GetPrinter(Device, Driver, Port, hDevmode);
144   numPaperNames := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, 
145 nil);
146   numPapers := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, nil, nil);
147   if numPapers <> numPaperNames then
148   begin
149     raise Exception.Create('DeviceCapabilities reports different number
150       of papers and '
151   end;
152   if numPaperNames > 0 then
153   begin
154     GetMem(pPaperNames, numPaperNames * Sizeof(TPapername));
155     GetMem(pPapers, numPapers * Sizeof(Word));
156     try
157       WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, Pchar(pPaperNames),
158         nil);
159       WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, Pchar(pPapers), nil);
160       sl.clear;
161       for i := 1 to numPaperNames do
162       begin
163         temp := pPapers^[i];
164         sl.addObject(pPaperNames^[i], TObject(temp));
165       end;
166     finally
167       FreeMem(pPaperNames);
168       if pPapers <> nil then
169         FreeMem(pPapers);
170     end;
171   end;
172 end;
173 
174 procedure GetPapersizes(var sizes: TPaperSizes; index: Integer);
175 var
176   Device, Driver, Port: array[0..255] of Char;
177   hDevMode: THandle;
178   numPapers: Integer;
179 begin
180   Printer.PrinterIndex := index;
181   Printer.GetPrinter(Device, Driver, Port, hDevmode);
182   numPapers := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, nil, nil);
183   SetLength(sizes, numPapers);
184   if numPapers > 0 then
185     WinSpool.DeviceCapabilities(Device, Port, DC_PAPERSIZE, PChar(@sizes[0]), nil);
186 end;
187 
188 procedure GetPaperInfo(var infos: TPaperInfos; index: Integer);
189 var
190   sizes: TPaperSizes;
191   sl: TStringlist;
192   i: Integer;
193 begin
194   sl := Tstringlist.Create;
195   try
196     GetPaperNames(sl, index);
197     GetPaperSizes(sizes, index);
198     Assert(sl.count = Length(sizes));
199     SetLength(infos, sl.count);
200     for i := 0 to sl.count - 1 do
201     begin
202       StrPLCopy(infos[i].papername, sl[i], Sizeof(TPapername) - 1);
203       infos[i].paperID := LoWord(Longword(sl.Objects[i]));
204       infos[i].papersize := sizes[i];
205     end;
206   finally
207     sl.Free;
208   end;
209 end;
210 
211 procedure GetPageinfo(var info: TPageInfo; index: Integer = -1);
212 begin
213   if index > -1 then
214     Printer.PrinterIndex := index;
215   with Printer do
216   begin
217     info.resX := GetDeviceCaps(handle, LOGPIXELSX);
218     info.resY := GetDeviceCaps(handle, LOGPIXELSY);
219     info.offsetX := GetDeviceCaps(handle, PHYSICALOFFSETX);
220     info.offsetY := GetDeviceCaps(handle, PHYSICALOFFSETY);
221     info.width := GetDeviceCaps(handle, PHYSICALWIDTH);
222     info.height := GetDeviceCaps(handle, PHYSICALHEIGHT);
223   end;
224 end;
225 
226 function PointMMtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
227 var
228   dp: TDoublePoint;
229 begin
230   dp.X := MMToInch(pt.X);
231   dp.Y := MMToInch(pt.Y);
232   Result := PointInchtoDots(dp, info);
233 end;
234 
235 function PointDotsToMM(const pt: TPoint; const info: TPageInfo): TDoublePoint;
236 begin
237   Result := PointDotsToInch(pt, info);
238   Result.X := InchToMM(Result.X);
239   Result.Y := InchToMM(Result.Y);
240 end;
241 
242 function PointInchtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
243 begin
244   Result.X := Round(pt.X * info.resX) - info.offsetX;
245   Result.Y := Round(pt.Y * info.resY) - info.offsetY;
246 end;
247 
248 function PointDotsToInch(const pt: TPoint; const info: TPageInfo): TDoublePoint;
249 begin
250   Result.X := (pt.X + info.offsetX) / info.resX;
251   Result.Y := (pt.Y + info.offsetY) / info.resY;
252 end;
253 
254 const
255   mmPerInch = 25.4;
256 
257 function InchToMM(const value: Double): Double;
258 begin
259   Result := value * mmPerInch;
260 end;
261 
262 function MMToInch(const value: Double): Double;
263 begin
264   Result := value / mmPerInch;
265 end;
266 
267 procedure SelectPrinterBin(binID: SmallInt);
268 var
269   Device, Driver, Port: array[0..127] of char;
270   hDeviceMode: THandle;
271   pDevMode: PDeviceMode;
272 begin
273   with Printer do
274   begin
275     GetPrinter(Device, Driver, Port, hDeviceMode);
276     pDevMode := GlobalLock(hDevicemode);
277     if pDevMode <> nil then
278     try
279       with pDevMode^ do
280       begin
281         dmFields := dmFields or DM_DEFAULTSOURCE;
282         dmDefaultSource := binID;
283       end;
284     finally
285       GlobalUnlock(hDevicemode);
286     end;
287   end;
288 end;
289 
290 procedure SelectPaper(paperID: SmallInt);
291 var
292   Device, Driver, Port: array[0..127] of char;
293   hDeviceMode: THandle;
294   pDevMode: PDeviceMode;
295 begin
296   with Printer do
297   begin
298     GetPrinter(Device, Driver, Port, hDeviceMode);
299     pDevMode := GlobalLock(hDevicemode);
300     if pDevMode <> nil then
301     try
302       with pDevMode^ do
303       begin
304         dmFields := dmFields or DM_PAPERSIZE;
305         dmPapersize := paperID;
306       end;
307     finally
308       GlobalUnlock(hDevicemode);
309     end;
310   end;
311 end;
312 
313 procedure ResetPrinter;
314 var
315   Device, Driver, Port: array[0..80] of Char;
316   DevMode: THandle;
317 begin
318   Printer.GetPrinter(Device, Driver, Port, DevMode);
319   Printer.SetPrinter(Device, Driver, Port, 0)
320 end;
321 
322 end.
323 
324 {
325 DblRect:
326 This unit defines point and rect types which store their boundaries as doubles, 
327 plus some routines
328 to work with these types.
329 Author: Dr. Peter Below
330 Version 1.0 created 22.02.1997
331 Version 1.01 created 04.12.2001, added InflateDoubleRect and modified comments for 
332 Time2Help.
333 Current revision: 1.01
334 Last modified: 4 Dezember 2001
335 }
336 
337 {$BOOLEVAL OFF} {Unit depends on shortcut boolean evaluation}
338 unit DblRect;
339 
340 interface
341 
342 uses
343   WinTypes;
344 
345 type
346   TDoublePoint = record
347     X, Y: Double;
348   end;
349   TDoubleRect = record
350     case Byte of
351       0: (Left, Top, Right, Bottom: Double);
352       1: (topleft, bottomright: TDoublePoint);
353       2: (X1, Y1, X2, Y2: Double);
354   end;
355 
356 const
357   EmptyDoubleRect: TDoubleRect = (Left: 0.0; Top: 0.0; Right: 0.0; Bottom: 0.0);
358   EmptyPoint: TDoublePoint = (X: 0.0; Y: 0.0);
359 
360 {$IFDEF WIN32}
361 var
362 {$ENDIF}
363   DefaultEpsilon: Double = 1.0 e - 8;
364 
365 function DoublePoint(const aX, aY: Double): TDoublePoint;
366 function AreDoublePointsEqual(const P1, P2: TDoublePoint): Boolean;
367 procedure OffsetDoublePoint(var P: TDoublePoint; dx, dy: Double);
368 procedure ScaleDoublePoint(var P: TDoublePoint; factor: DOuble);
369 function DoublePointDistance(const P1, P2: TDoublePoint): Double;
370 function PointFromDoublePoint(const P: TDoublePoint): TPoint;
371 function DoublePointFromPoint(const P: TPoint): TDoublePoint;
372 function DoubleRect(const L, T, R, B: Double): TDoubleRect;
373 procedure VerifyDoubleRect(var R: TDoubleRect);
374 function AreDoubleRectsEqual(const R1, R2: TDoubleRect): Boolean;
375 procedure OffsetDoubleRect(var R: TDoubleRect; dx, dy: Double);
376 procedure ScaleDoubleRect(var R: TDoubleRect; cx, cy: Double);
377 procedure InflateDoubleRect(var R: TDoubleRect; dx, dy: Double);
378 procedure IntersectDoubleRect(const R1, R2: TDoubleRect; var isect: TDoubleRect);
379 function IsDoubleRectEmpty(const R: TDoubleRect): Boolean;
380 function RectFromDoubleRect(const R: TDoubleRect): TRect;
381 function DoubleRectFromRect(const R: TRect): TDoubleRect;
382 function DoublePointInRect(const P: TDOublePoint; const R: TDoubleRect): Boolean;
383 function ULeft(const R: TDoubleRect): TDoublePoint;
384 function URight(const R: TDoubleRect): TDoublePoint;
385 function LLeft(const R: TDoubleRect): TDoublePoint;
386 function LRight(const R: TDoubleRect): TDoublePoint;
387 
388 implementation
389 
390 {Returns a TDoublePoint constructed from the passed coordinates.}
391 
392 function DoublePoint(const aX, aY: Double): TDoublePoint;
393 begin
394   with Result do
395   begin
396     X := aX;
397     Y := aY;
398   end;
399 end;
400 
401 {Compares the two passed points and returns true if they are considered equal, 
402 false otherwise.
403 The points are equal if their coordinates differ less than the DefaultEpsilon.}
404 
405 function AreDoublePointsEqual(const P1, P2: TDoublePoint): Boolean;
406 begin
407   Result := (Abs(P1.X - P2.X) < DefaultEpsilon) and (Abs(P1.Y - P2.Y) <
408     DefaultEpsilon);
409 end;
410 
411 {: Moves the passed point by the passed increments.}
412 
413 procedure OffsetDoublePoint(var P: TDoublePoint; dx, dy: Double);
414 begin
415   with P do
416   begin
417     X := X + dx;
418     Y := Y + dy;
419   end;
420 end;
421 
422 {Multiplies the passed points coordinates by factor.}
423 
424 procedure ScaleDoublePoint(var P: TDoublePoint; factor: DOuble);
425 begin
426   with P do
427   begin
428     X := X * factor;
429     Y := Y * factor;
430   end;
431 end;
432 
433 {Returns the distance between the passed points. This will always be a positive 
434 number.}
435 
436 function DoublePointDistance(const P1, P2: TDoublePoint): Double;
437 begin
438   Result := Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y));
439 end;
440 
441 {Converts the passed TDoublePoint to a TPoint and returns the result.}
442 
443 function PointFromDoublePoint(const P: TDoublePoint): TPoint;
444 begin
445   with Result do
446   begin
447     X := Round(P.X);
448     Y := Round(P.Y);
449   end;
450 end;
451 
452 {Converts the passed TPoint to a TDoublePoint and returns the result.}
453 
454 function DoublePointFromPoint(const P: TPoint): TDoublePoint;
455 begin
456   with Result do
457   begin
458     X := P.X;
459     Y := P.Y;
460   end;
461 end;
462 
463 {Returns a TDoubleRect made from the passed parameters. Makes certain that the 
464 resulting rect meets the criteria Left < Right and Top < Bottom, boundaries may be 
465 swapped to achieve this.}
466 
467 function DoubleRect(const L, T, R, B: Double): TDoubleRect;
468 begin
469   with Result do
470   begin
471     if L <= R then
472     begin
473       Left := L;
474       Right := R;
475     end
476     else
477     begin
478       Left := R;
479       Right := L;
480     end;
481     if T <= B then
482     begin
483       Top := T;
484       Bottom := B;
485     end
486     else
487     begin
488       Top := B;
489       Bottom := T;
490     end;
491   end;
492 end;
493 
494 {Makes sure the passed rectangle meets the constraints Left < Right and Top < 
495 Bottom.
496 If needed, boundaries will be swapped.}
497 
498 procedure VerifyDoubleRect(var R: TDoubleRect);
499 var
500   temp: Double;
501 begin
502   with R do
503   begin
504     if Left > Right then
505     begin
506       temp := Left;
507       Left := right;
508       Right := temp;
509     end;
510     if Top > Bottom then
511     begin
512       temp := Top;
513       Top := Bottom;
514       Bottom := temp;
515     end;
516   end;
517 end;
518 
519 {Returns True if the two passed rects R1 and R2 are equal, false otherwise. Equal 
520 in this case means that each of the four coordinates of P1 has a difference of less 
521 than DefaultEpsilon from the corresponding coordinate of P2.}
522 
523 function AreDoubleRectsEqual(const R1, R2: TDoubleRect): Boolean;
524 begin
525   Result := (Abs(R1.X1 - R2.X1) < DefaultEpsilon) and (Abs(R1.Y1 - R2.Y1) <
526     DefaultEpsilon) and
527     (Abs(R1.X2 - R2.X2) < DefaultEpsilon) and (Abs(R1.Y2 - R2.Y2) < DefaultEpsilon);
528 end;
529 
530 {Moves the passed rectangle by the given increments.}
531 
532 procedure OffsetDoubleRect(var R: TDoubleRect; dx, dy: Double);
533 begin
534   with R do
535   begin
536     X1 := X1 + dx;
537     Y1 := Y1 + dy;
538     X2 := X2 + dx;
539     Y2 := Y2 + dy;
540   end;
541 end;
542 
543 {Scales the passed rectangle by the factors given. This changes only the size of 
544 the rectangle, the upper left corner coordinates stay fixed.}
545 
546 procedure ScaleDoubleRect(var R: TDoubleRect; cx, cy: Double);
547 begin
548   with R do
549   begin
550     X2 := (X2 - X1) * cx + X1;
551     Y2 := (Y2 - Y1) * cy + Y1;
552   end;
553 end;
554 
555 {
556 InflateDoubleRect:
557 Change the size of a double rect.
558 Param R is the rect to change
559 Param dx is the horizontal size increment to apply
560 Param dy is the vertical size increment to apply
561 Like the API function InflateRect this procedure will subtract dx from the r.left, 
562 add dx to r.right, subtract dy
563 from r.top and add dy to r.bottom. So the rectangle width and height changes by 2 
564 times the increment.
565 Created 04.12.2001 by P. Below
566 }
567 
568 procedure InflateDoubleRect(var R: TDoubleRect; dx, dy: Double);
569 begin
570   r.Left := r.Left - dx;
571   r.Right := r.Right + dx;
572   r.Top := r.Top - dy;
573   r.Bottom := r.Bottom + dy;
574 end;
575 
576 {Calculates the intersection of the two rectangles passed and returns the result in 
577 isect. The result will be empty if the rectangles are disjunct. Note that this 
578 procedure assumes that the rectangles obey the constraints Left <= Right and Top <= 
579 Bottom !}
580 
581 procedure IntersectDoubleRect(const R1, R2: TDoubleRect; var isect: TDoubleRect);
582 begin
583   if (R1.Left > R2.Right) or (R1.Right < R2.Left) or (R1.Top > R2.Bottom) or 
584 (R1.Bottom
585     < R2.Top) then
586   begin
587     {The two rectangles do not intersect}
588     isect := EmptyDoubleRect;
589   end
590   else
591   begin
592     {Figure out placement of left border of result rectangle, which is the 
593 rightmost of the two left borders of the source rectangles.}
594     if R1.Left < R2.Left then
595       isect.Left := R2.Left
596     else
597       isect.Left := R1.Left;
598     {Figure out placement of top border of result rectangle, which is the 
599 bottommost of the two top borders of the source rectangles.}
600     if R1.Top < R2.Top then
601       isect.Top := R2.top
602     else
603       isect.Top := R1.Top;
604     {Figure out placement of right border of result rectangle, which is the 
605 leftmost of the two Right borders of the source rectangles.}
606     if R1.Right > R2.Right then
607       isect.Right := R2.Right
608     else
609       isect.Right := R1.Right;
610     {Figure out placement of Bottom border of result rectangle, which is the 
611 topmost of the two Bottom borders of the source rectangles.}
612     if R1.Bottom > R2.Bottom then
613       isect.Bottom := R2.Bottom
614     else
615       isect.Bottom := R1.Bottom;
616   end;
617 end;
618 
619 {Returns True if the passed rect spans no area, meaning the TopLeft and BottomRight 
620 corners are equal inside the precision given by the default threshold value 
621 DefaultEpsilon}
622 
623 function IsDoubleRectEmpty(const R: TDoubleRect): Boolean;
624 begin
625   Result := AreDoublePointsEqual(R.TopLeft, R.BottomRight);
626 end;
627 
628 {Constructs a TRect from the passed TDoubleRect and returns it. The standard Round 
629 function is used to convert floating point to integer.}
630 
631 function RectFromDoubleRect(const R: TDoubleRect): TRect;
632 begin
633   with Result do
634   begin
635     Left := Round(R.Left);
636     Top := Round(R.Top);
637     Right := Round(R.Right);
638     Bottom := Round(R.Bottom);
639   end;
640 end;
641 
642 {Constructs a TDoubleRect from the passed rect, validates it and returns it.}
643 
644 function DoubleRectFromRect(const R: TRect): TDoubleRect;
645 begin
646   with Result do
647   begin
648     Left := R.Left;
649     Top := R.Top;
650     Right := R.Right;
651     Bottom := R.Bottom;
652   end;
653   VerifyDoubleRect(Result);
654 end;
655 
656 {Performs a point-in-rectangle test and returns True, if the passed point is inside 
657 the rectangle or on one of its borders, false otherwise. The rectangle must meet 
658 the constraints  Left <= Right and Top <= Bottom !}
659 
660 function DoublePointInRect(const P: TDOublePoint; const R: TDoubleRect): Boolean;
661 begin
662   with R, P do
663   begin
664     Result := (X >= Left) and (X <= Right) and (Y >= Top) and (Y <= Bottom);
665   end;
666 end;
667 
668 {Returns the upper left corner of the passed rectangle}
669 
670 function ULeft(const R: TDoubleRect): TDoublePoint;
671 begin
672   Result := R.TopLeft;
673 end;
674 
675 {Returns the upper right corner of the passed rectangle}
676 
677 function URight(const R: TDoubleRect): TDoublePoint;
678 begin
679   with R, Result do
680   begin
681     X := Right;
682     Y := Top;
683   end;
684 end;
685 
686 {Returns the lower left corner of the passed rectangle}
687 
688 function LLeft(const R: TDoubleRect): TDoublePoint;
689 begin
690   with R, Result do
691   begin
692     X := Left;
693     Y := Bottom;
694   end;
695 end;
696 
697 {Returns the lower right corner of the passed rectangle}
698 
699 function LRight(const R: TDoubleRect): TDoublePoint;
700 begin
701   Result := R.BottomRight;
702 end;
703 
704 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