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