home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d123456 / DFS.ZIP / PgSetup.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-06-28  |  34.0 KB  |  1,051 lines
  1. {$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }
  2.  
  3. {------------------------------------------------------------------------------}
  4. { TdfsPageSetupDialog v2.14                                                    }
  5. {------------------------------------------------------------------------------}
  6. { A component to wrap the Win95 PageSetupDlg common dialog API function.       }
  7. { Borland seems to have forgotten this new common dialog in Delphi 2.0.        }
  8. {                                                                              }
  9. { Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
  10. {                                                                              }
  11. { Copyright:                                                                   }
  12. { All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
  13. { Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
  14. { property of the author.                                                      }
  15. {                                                                              }
  16. { Distribution Rights:                                                         }
  17. { You are granted a non-exlusive, royalty-free right to produce and distribute }
  18. { compiled binary files (executables, DLLs, etc.) that are built with any of   }
  19. { the DFS source code unless specifically stated otherwise.                    }
  20. { You are further granted permission to redistribute any of the DFS source     }
  21. { code in source code form, provided that the original archive as found on the }
  22. { DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
  23. { example, if you create a descendant of TDFSColorButton, you must include in  }
  24. { the distribution package the colorbtn.zip file in the exact form that you    }
  25. { downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
  26. {                                                                              }
  27. { Restrictions:                                                                }
  28. { Without the express written consent of the author, you may not:              }
  29. {   * Distribute modified versions of any DFS source code by itself. You must  }
  30. {     include the original archive as you found it at the DFS site.            }
  31. {   * Sell or lease any portion of DFS source code. You are, of course, free   }
  32. {     to sell any of your own original code that works with, enhances, etc.    }
  33. {     DFS source code.                                                         }
  34. {   * Distribute DFS source code for profit.                                   }
  35. {                                                                              }
  36. { Warranty:                                                                    }
  37. { There is absolutely no warranty of any kind whatsoever with any of the DFS   }
  38. { source code (hereafter "software"). The software is provided to you "AS-IS", }
  39. { and all risks and losses associated with it's use are assumed by you. In no  }
  40. { event shall the author of the softare, Bradley D. Stowers, be held           }
  41. { accountable for any damages or losses that may occur from use or misuse of   }
  42. { the software.                                                                }
  43. {                                                                              }
  44. { Support:                                                                     }
  45. { Support is provided via the DFS Support Forum, which is a web-based message  }
  46. { system.  You can find it at http://www.delphifreestuff.com/discus/           }
  47. { All DFS source code is provided free of charge. As such, I can not guarantee }
  48. { any support whatsoever. While I do try to answer all questions that I        }
  49. { receive, and address all problems that are reported to me, you must          }
  50. { understand that I simply can not guarantee that this will always be so.      }
  51. {                                                                              }
  52. { Clarifications:                                                              }
  53. { If you need any further information, please feel free to contact me directly.}
  54. { This agreement can be found online at my site in the "Miscellaneous" section.}
  55. {------------------------------------------------------------------------------}
  56. { The lateset version of my components are always available on the web at:     }
  57. {   http://www.delphifreestuff.com/                                            }
  58. { See PgSetup.txt for notes, known issues, and revision history.               }
  59. {------------------------------------------------------------------------------}
  60. { Date last modified:  June 28, 2001                                           }
  61. {------------------------------------------------------------------------------}
  62.  
  63.  
  64. // Make sure we have RTTI available for the TPSRect class below.
  65. {$M+}
  66.  
  67. unit PgSetup;
  68.  
  69. interface
  70.  
  71. {$IFNDEF DFS_WIN32}
  72.   ERROR!  This unit only available for Delphi 2.0 or later!!!
  73. {$ENDIF}
  74.  
  75. uses
  76.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  77. {$IFDEF DFS_DEBUG}
  78.   mmsystem,
  79. {$ENDIF}
  80.   CommDlg;
  81.  
  82.  
  83. const
  84.   { This shuts up C++Builder 3 about the redefiniton being different. There
  85.     seems to be no equivalent in C1.  Sorry. }
  86.   {$IFDEF DFS_CPPB_3_UP}
  87.   {$EXTERNALSYM DFS_COMPONENT_VERSION}
  88.   {$ENDIF}
  89.   DFS_COMPONENT_VERSION = 'TdfsPageSetupDialog v2.14';
  90.  
  91. type
  92.   TPageSetupOption = (
  93.        poDefaultMinMargins, poDisableMargins, poDisableOrientation,
  94.        poDisablePagePainting, poDisablePaper, poDisablePrinter, poNoWarning,
  95.        poShowHelp
  96.      );
  97.   TPageSetupOptions = set of TPageSetupOption;
  98.   TPSPaperType = (ptPaper, ptEnvelope);
  99.   TPSPaperOrientation = (poPortrait, poLandscape);
  100.   TPSPrinterType = (ptDotMatrix, ptHPPCL);
  101.   TPSPaintWhat = (pwFullPage, pwMinimumMargins, pwMargins,
  102.                   pwGreekText, pwEnvStamp, pwYAFullPage);
  103.  
  104.   TPSMeasureVal = Double;
  105.   TPSMeasurements = (pmDefault, pmMillimeters, pmInches);
  106.   TPSPrinterEvent = procedure(Sender: TObject; Wnd: HWND) of object;
  107.  
  108.   (* PPSDlgData is simply redeclared as PPageSetupDlg (COMMDLG.PAS) to prevent
  109.      compile errors in units that have this event.  They won't compile unless
  110.      you add CommDlg to their units.  This circumvents the problem.           *)
  111.   PPSDlgData = ^TPSDlgData;
  112.   TPSDlgData = TPageSetupDlg;
  113.   { PaperSize: See DEVMODE help topic, dmPaperSize member. DMPAPER_* constants.}
  114.   TPSInitPaintPageEvent = function(Sender: TObject; PaperSize: short;
  115.      PaperType: TPSPaperType; PaperOrientation: TPSPaperOrientation;
  116.      PrinterType: TPSPrinterType; pSetupData: PPSDlgData): boolean of object;
  117.   TPSPaintPageEvent = function(Sender: TObject; PaintWhat: TPSPaintWhat;
  118.      Canvas: TCanvas; Rect: TRect): boolean of object;
  119.  
  120.   (* TPSRect is used for published properties that would normally be of TRect
  121.      type.  Can't publish properties that are record types, so this is used.  *)
  122.   TPSRect = class(TPersistent)
  123.   private
  124.     FRect: TRect;
  125.  
  126.     {$IFDEF DFS_CPPB_4_UP}
  127.     function GetLeft: integer;
  128.     procedure SetLeft(Value: integer);
  129.     function GetRight: integer;
  130.     procedure SetRight(Value: integer);
  131.     function GetTop: integer;
  132.     procedure SetTop(Value: integer);
  133.     function GetBottom: integer;
  134.     procedure SetBottom(Value: integer);
  135.     {$ENDIF}
  136.   public
  137.     function Compare(Other: TPSRect): boolean;
  138.  
  139.     property Rect: TRect
  140.        read FRect
  141.        write FRect;
  142.   published
  143.     property Left: integer
  144.        read {$IFDEF DFS_CPPB_4_UP} GetLeft {$ELSE} FRect.Left {$ENDIF}
  145.        write {$IFDEF DFS_CPPB_4_UP} SetLeft {$ELSE} FRect.Left {$ENDIF};
  146.     property Right: integer
  147.        read {$IFDEF DFS_CPPB_4_UP} GetRight {$ELSE} FRect.Right {$ENDIF}
  148.        write {$IFDEF DFS_CPPB_4_UP} SetRight {$ELSE} FRect.Right {$ENDIF};
  149.     property Top: integer
  150.        read {$IFDEF DFS_CPPB_4_UP} GetTop {$ELSE} FRect.Top {$ENDIF}
  151.        write {$IFDEF DFS_CPPB_4_UP} SetTop {$ELSE} FRect.Top {$ENDIF};
  152.     property Bottom: integer
  153.        read {$IFDEF DFS_CPPB_4_UP} GetBottom {$ELSE} FRect.Bottom {$ENDIF}
  154.        write {$IFDEF DFS_CPPB_4_UP} SetBottom {$ELSE} FRect.Bottom {$ENDIF};
  155.   end;
  156.  
  157.   (* TPSPoint is needed for the same reason as TPSRect above.                 *)
  158.   TPSPoint = class(TPersistent)
  159.   private
  160.     FPoint: TPoint;
  161.   protected
  162.     function GetX: longint;
  163.     procedure SetX(Val: longint);
  164.     function GetY: longint;
  165.     procedure SetY(Val: longint);
  166.   public
  167.     function Compare(Other: TPSPoint): boolean;
  168.  
  169.     property Point: TPoint
  170.        read FPoint
  171.        write FPoint;
  172.   published
  173.     property X: longint
  174.        read GetX
  175.        write SetX;
  176.     property Y: longint
  177.        read GetY
  178.        write SetY;
  179.   end;
  180.  
  181.  
  182.   TdfsPageSetupDialog = class(TCommonDialog)
  183.   private
  184.     FGettingDefaults: boolean;
  185.     FCentered: boolean;
  186.     FOptions: TPageSetupOptions;
  187.     FCustomData: LPARAM;
  188.     FPaperSize: TPSPoint;
  189.     FMinimumMargins: TPSRect;
  190.     FMargins: TPSRect;
  191.     FMeasurements: TPSMeasurements;
  192.     FOnPrinter: TPSPrinterEvent;
  193.     FOnInitPaintPage: TPSInitPaintPageEvent;
  194.     FOnPaintPage: TPSPaintPageEvent;
  195.  
  196.     function DoPrinter(Wnd: HWND): boolean;
  197.     function DoExecute(Func: pointer): boolean;
  198.   protected
  199.     procedure SetName(const NewName: TComponentName); override;
  200.     function Printer(Wnd: HWND): boolean; virtual;
  201.  
  202.     procedure SetPaperSize(const Val: TPSPoint);
  203.     function StorePaperSize: boolean;
  204.     procedure SetMinimumMargins(const Val: TPSRect);
  205.     function StoreMinimumMargins: boolean;
  206.     procedure SetMargins(const Val: TPSRect);
  207.     function StoreMargins: boolean;
  208.     procedure SetMeasurements(Val: TPSMeasurements);
  209.     function GetDefaultMeasurements: TPSMeasurements;
  210.     function GetCurrentMeasurements: TPSMeasurements;
  211.     function GetVersion: string;
  212.     procedure SetVersion(const Val: string);
  213.     function GetPaperSizeType: short;
  214.     procedure SetPaperSizeType(Value: short);
  215.   public
  216.     constructor Create(AOwner: TComponent); override;
  217.     destructor Destroy; override;
  218.     { Delphi and C++Builder 3 finally got it right! }
  219.     function Execute: boolean;
  220.        {$IFDEF DFS_COMPILER_3_UP} override; {$ELSE} virtual; {$ENDIF}
  221.     function ReadCurrentValues: boolean; virtual;
  222.     function FromMeasurementVal(Val: integer): TPSMeasureVal;
  223.     function ToMeasurementVal(Val: TPSMeasureVal): integer;
  224.  
  225.     { Did the user select a user-defined size? }
  226.     property PaperSizeType: SHORT
  227.        read GetPaperSizeType
  228.        write SetPaperSizeType;
  229.     { How does the user's system like to measure things? }
  230.     property DefaultMeasurements: TPSMeasurements
  231.        read GetDefaultMeasurements;
  232.     { What are we using currently, i.e. translate pmDefault value }
  233.     property CurrentMeasurements: TPSMeasurements
  234.        read GetCurrentMeasurements;
  235.  
  236.     { It is the user's responsibility to clean up this pointer if necessary. }
  237.     property CustomData: LPARAM
  238.        read FCustomData
  239.        write FCustomData;
  240.   published
  241.     property Version: string
  242.        read GetVersion
  243.        write SetVersion
  244.        stored FALSE;
  245.     // Measurements property has to be declared before PaperSize, MinimumMargins
  246.     // and Margins because of streaming quirks.
  247.     property Measurements: TPSMeasurements
  248.        read FMeasurements
  249.        write SetMeasurements
  250.        nodefault;
  251.  
  252.     property PaperSize: TPSPoint
  253.        read FPaperSize
  254.        write SetPaperSize
  255.        stored StorePaperSize;
  256.     property MinimumMargins: TPSRect
  257.        read FMinimumMargins
  258.        write SetMinimumMargins
  259.        stored StoreMinimumMargins;
  260.     property Margins: TPSRect
  261.        read FMargins
  262.        write SetMargins
  263.        stored StoreMargins;
  264.  
  265.     property Centered: boolean
  266.        read FCentered
  267.        write FCentered
  268.        default TRUE;
  269.     property Options: TPageSetupOptions
  270.        read FOptions
  271.        write FOptions
  272.        default [poDefaultMinMargins, poShowHelp];
  273.  
  274.     { Events }
  275.     property OnPrinter: TPSPrinterEvent
  276.        read FOnPrinter
  277.        write FOnPrinter;
  278.     property OnInitPaintPage: TPSInitPaintPageEvent
  279.        read FOnInitPaintPage
  280.        write FOnInitPaintPage;
  281.     property OnPaintPage: TPSPaintPageEvent
  282.        read FOnPaintPage
  283.        write FOnPaintPage;
  284.   end;
  285.  
  286. implementation
  287.  
  288. uses
  289. {$IFDEF DFS_COMPILER_3_UP}
  290.   Dlgs,
  291. {$ENDIF}
  292.   Printers;
  293.  
  294. const
  295.   IDPRINTERBTN = {$IFDEF DFS_COMPILER_3_UP} Dlgs.psh3 {$ELSE} $0402 {$ENDIF};
  296.  
  297. { Private globals }
  298. var
  299.   NeedInitGlobals: boolean;
  300.   HelpMsg: Integer;
  301.   DefPaperSizeI: TPSPoint;
  302.   DefMinimumMarginsI: TPSRect;
  303.   DefMarginsI: TPSRect;
  304.   DefPaperSizeM: TPSPoint;
  305.   DefMinimumMarginsM: TPSRect;
  306.   DefMarginsM: TPSRect;
  307.   HookCtl3D: boolean;
  308.   PageSetupDialog: TdfsPageSetupDialog;
  309.  
  310.  
  311. procedure InitGlobals; forward;
  312.  
  313. { Center the given window on the screen }
  314. procedure CenterWindow(Wnd: HWnd);
  315. var
  316.   Rect: TRect;
  317. begin
  318.   GetWindowRect(Wnd, Rect);
  319.   SetWindowPos(Wnd, 0,
  320.      (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
  321.      (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 3,
  322.      0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
  323. end;
  324.  
  325. { Generic dialog hook. Centers the dialog on the screen in response to
  326.   the WM_INITDIALOG message }
  327. function DialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;
  328. begin
  329.   Result := 0;
  330.   case Msg of
  331.     WM_INITDIALOG:
  332.       begin
  333.         {$IFNDEF DFS_COMPILER_5_UP}
  334.         if HookCtl3D then
  335.         begin
  336.           // These were only stubbed in D5, and deprecated in D6.
  337.           Subclass3DDlg(Wnd, CTL3D_ALL);
  338.           SetAutoSubClass(True);
  339.         end;
  340.         {$ENDIF}
  341.         if PageSetupDialog.Centered then
  342.           CenterWindow(Wnd);
  343.         Result := 1;
  344.       end;
  345.     {$IFNDEF DFS_COMPILER_5_UP}
  346.     WM_DESTROY:
  347.       if HookCtl3D then
  348.         SetAutoSubClass(False);
  349.     {$ENDIF}
  350.   end;
  351. end;
  352.  
  353. function PageSetupDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM;
  354.                              LParam: LPARAM): UINT; stdcall;
  355. const
  356.   PagePaintWhat: array[WM_PSD_FULLPAGERECT..
  357.                        WM_PSD_YAFULLPAGERECT] of TPSPaintWhat = (
  358.     pwFullPage, pwMinimumMargins, pwMargins,
  359.     pwGreekText, pwEnvStamp, pwYAFullPage
  360.   );
  361.   PRINTER_MASK = $00000002;
  362.   ORIENT_MASK  = $00000004;
  363.   PAPER_MASK   = $00000008;
  364. var
  365.   PaperData: word;
  366.   Paper: TPSPaperType;
  367.   Orient: TPSPaperOrientation;
  368.   Printer: TPSPrinterType;
  369.   PaintRect: TRect;
  370.   PaintCanvas: TCanvas;
  371. begin
  372.   if (Msg = WM_COMMAND) and (LongRec(WParam).Lo = IDPRINTERBTN) and
  373.      (LongRec(WParam).Hi = BN_CLICKED) then
  374.   begin
  375.     // if hander is assigned, use it.  If not, let system do it.
  376.     Result := ord(PageSetupDialog.DoPrinter(Wnd));
  377.   end else begin
  378.     if assigned(PageSetupDialog.FOnInitPaintPage) and
  379.        assigned(PageSetupDialog.FOnPaintPage) then
  380.     begin
  381.       case Msg of
  382.         WM_PSD_PAGESETUPDLG:
  383.           begin
  384.             PaperData := HiWord(WParam);
  385.             if (PaperData AND PAPER_MASK > 0) then
  386.               Paper := ptEnvelope
  387.             else
  388.               Paper := ptPaper;
  389.             if (PaperData AND ORIENT_MASK > 0) then
  390.               Orient := poPortrait
  391.             else
  392.               Orient := poLandscape;
  393.             if (PaperData AND PAPER_MASK > 0) then
  394.               Printer := ptHPPCL
  395.             else
  396.               Printer := ptDotMatrix;
  397.             Result := Ord(PageSetupDialog.FOnInitPaintPage(PageSetupDialog,
  398.                LoWord(WParam), Paper, Orient, Printer, PPSDlgData(LParam)));
  399.           end;
  400.         WM_PSD_FULLPAGERECT,
  401.         WM_PSD_MINMARGINRECT,
  402.         WM_PSD_MARGINRECT,
  403.         WM_PSD_GREEKTEXTRECT,
  404.         WM_PSD_ENVSTAMPRECT,
  405.         WM_PSD_YAFULLPAGERECT:
  406.           begin
  407.             if LParam <> 0 then
  408.               PaintRect := PRect(LParam)^
  409.             else
  410.               PaintRect := Rect(0,0,0,0);
  411.             PaintCanvas := TCanvas.Create;
  412.             PaintCanvas.Handle := HDC(WParam);
  413.             try
  414.               Result := Ord(PageSetupDialog.FOnPaintPage(PageSetupDialog,
  415.                  PagePaintWhat[Msg], PaintCanvas, PaintRect));
  416.             finally
  417.               PaintCanvas.Free;   { This better not be deleting the DC! }
  418.             end;
  419.           end;
  420.       else
  421.         Result := DialogHook(Wnd, Msg, wParam, lParam);
  422.       end;
  423.     end else
  424.       Result := DialogHook(Wnd, Msg, wParam, lParam);
  425.   end;
  426. end;
  427.  
  428.  
  429. {$IFDEF DFS_CPPB_4_UP}
  430. function TPSRect.GetLeft: integer;
  431. begin
  432.   Result := FRect.Left;
  433. end;
  434.  
  435. procedure TPSRect.SetLeft(Value: integer);
  436. begin
  437.   FRect.Left := Value;
  438. end;
  439.  
  440. function TPSRect.GetRight: integer;
  441. begin
  442.   Result := FRect.Right;
  443. end;
  444.  
  445. procedure TPSRect.SetRight(Value: integer);
  446. begin
  447.   FRect.Right := Value;
  448. end;
  449.  
  450. function TPSRect.GetTop: integer;
  451. begin
  452.   Result := FRect.Top;
  453. end;
  454.  
  455. procedure TPSRect.SetTop(Value: integer);
  456. begin
  457.   FRect.Top := Value;
  458. end;
  459.  
  460. function TPSRect.GetBottom: integer;
  461. begin
  462.   Result := FRect.Bottom;
  463. end;
  464.  
  465. procedure TPSRect.SetBottom(Value: integer);
  466. begin
  467.   FRect.Bottom := Value;
  468. end;
  469.  
  470. {$ENDIF}
  471.  
  472. function TPSRect.Compare(Other: TPSRect): boolean;
  473. begin
  474.   Result := EqualRect(Rect, Other.Rect);
  475. end;
  476.  
  477. function TPSPoint.Compare(Other: TPSPoint): boolean;
  478. begin
  479.   Result := (X = Other.X) and (Y = Other.Y);
  480. end;
  481.  
  482. function TPSPoint.GetX: longint;
  483. begin
  484.   Result := FPoint.X;
  485. end;
  486.  
  487. procedure TPSPoint.SetX(Val: longint);
  488. begin
  489.   FPoint.X := Val;
  490. end;
  491.  
  492. function TPSPoint.GetY: longint;
  493. begin
  494.   Result := FPoint.Y;
  495. end;
  496.  
  497. procedure TPSPoint.SetY(Val: longint);
  498. begin
  499.   FPoint.Y := Val;
  500. end;
  501.  
  502.  
  503.  
  504. constructor TdfsPageSetupDialog.Create(AOwner: TComponent);
  505. begin
  506.   inherited Create(AOwner);
  507.  
  508.   InitGlobals;
  509.   FCentered := TRUE;
  510.   FOptions := [poDefaultMinMargins, poShowHelp];
  511.   FOnPrinter := NIL;
  512.   FOnInitPaintPage := NIL;
  513.   FOnPaintPage := NIL;
  514.   FCustomData := 0;
  515.   FMeasurements := pmDefault;
  516.   FPaperSize := TPSPoint.Create;
  517.   FMinimumMargins := TPSRect.Create;
  518.   FMargins := TPSRect.Create;
  519.   if CurrentMeasurements = pmInches then
  520.   begin
  521.     FPaperSize.Point := DefPaperSizeI.Point;
  522.     FMinimumMargins.Rect := DefMinimumMarginsI.Rect;
  523.     FMargins.Rect := DefMarginsI.Rect;
  524.   end else begin
  525.     FPaperSize.Point := DefPaperSizeM.Point;
  526.     FMinimumMargins.Rect := DefMinimumMarginsM.Rect;
  527.     FMargins.Rect := DefMarginsM.Rect;
  528.   end;
  529. end;
  530.  
  531. destructor TdfsPageSetupDialog.Destroy;
  532. begin
  533.   FPaperSize.Free;
  534.   FMinimumMargins.Free;
  535.   FMargins.Free;
  536.  
  537.   inherited Destroy;
  538. end;
  539.  
  540. procedure TdfsPageSetupDialog.SetName(const NewName: TComponentName);
  541. begin
  542.   inherited Setname(NewName);
  543.   if not (csLoading in ComponentState) then
  544.     ReadCurrentValues;
  545. end;
  546.  
  547. procedure TdfsPageSetupDialog.SetPaperSize(const Val: TPSPoint);
  548. begin
  549.   FPaperSize.Point := Val.Point;
  550. end;
  551.  
  552. function TdfsPageSetupDialog.StorePaperSize: boolean;
  553. begin
  554.   if CurrentMeasurements = pmInches then
  555.     Result := not PaperSize.Compare(DefPaperSizeI)
  556.   else
  557.     Result := not PaperSize.Compare(DefPaperSizeM);
  558. end;
  559.  
  560. procedure TdfsPageSetupDialog.SetMinimumMargins(const Val: TPSRect);
  561. begin
  562.   FMinimumMargins.Rect := Val.Rect;
  563. end;
  564.  
  565. function TdfsPageSetupDialog.StoreMinimumMargins: boolean;
  566. begin
  567.   if CurrentMeasurements = pmInches then
  568.     Result := not MinimumMargins.Compare(DefMinimumMarginsI)
  569.   else
  570.     Result := not MinimumMargins.Compare(DefMinimumMarginsM);
  571. end;
  572.  
  573. procedure TdfsPageSetupDialog.SetMargins(const Val: TPSRect);
  574. begin
  575.   FMargins.Rect := Val.Rect;
  576. end;
  577.  
  578. function TdfsPageSetupDialog.StoreMargins: boolean;
  579. begin
  580.   if CurrentMeasurements = pmInches then
  581.     Result := not Margins.Compare(DefMarginsI)
  582.   else
  583.     Result := not Margins.Compare(DefMarginsM);
  584. end;
  585.  
  586. procedure TdfsPageSetupDialog.SetMeasurements(Val: TPSMeasurements);
  587. var
  588.   TempVal: TPSMeasurements;
  589. begin
  590.   if Val = pmDefault then
  591.     TempVal := DefaultMeasurements
  592.   else
  593.     TempVal := Val;
  594.   if CurrentMeasurements <> TempVal then
  595.   begin
  596.     if TempVal = pmInches then
  597.     begin
  598.       // Convert to thousandths of an inch
  599.       PaperSize.X := Round(PaperSize.X / 2.54);
  600.       PaperSize.Y := Round(PaperSize.Y / 2.54);
  601.       MinimumMargins.Top := Round(MinimumMargins.Top / 2.54);
  602.       MinimumMargins.Left := Round(MinimumMargins.Left / 2.54);
  603.       MinimumMargins.Right := Round(MinimumMargins.Right / 2.54);
  604.       MinimumMargins.Bottom := Round(MinimumMargins.Bottom / 2.54);
  605.       Margins.Top := Round(Margins.Top / 2.54);
  606.       Margins.Left := Round(Margins.Left / 2.54);
  607.       Margins.Right := Round(Margins.Right / 2.54);
  608.       Margins.Bottom := Round(Margins.Bottom / 2.54);
  609.     end else begin
  610.       // Convert to millimeters
  611.       PaperSize.X := Round(PaperSize.X * 2.54);
  612.       PaperSize.Y := Round(PaperSize.Y * 2.54);
  613.       MinimumMargins.Top := Round(MinimumMargins.Top * 2.54);
  614.       MinimumMargins.Left := Round(MinimumMargins.Left * 2.54);
  615.       MinimumMargins.Right := Round(MinimumMargins.Right * 2.54);
  616.       MinimumMargins.Bottom := Round(MinimumMargins.Bottom * 2.54);
  617.       Margins.Top := Round(Margins.Top * 2.54);
  618.       Margins.Left := Round(Margins.Left * 2.54);
  619.       Margins.Right := Round(Margins.Right * 2.54);
  620.       Margins.Bottom := Round(Margins.Bottom * 2.54);
  621.     end;
  622.   end;
  623.   FMeasurements := Val;
  624.   if not (csLoading in ComponentState) then
  625.     ReadCurrentValues;
  626. end;
  627.  
  628. function TdfsPageSetupDialog.GetDefaultMeasurements: TPSMeasurements;
  629. begin
  630.   if GetLocaleChar(LOCALE_USER_DEFAULT,LOCALE_IMEASURE,'0') = '0' then
  631.     Result:= pmMillimeters
  632.   else
  633.     Result:= pmInches;
  634. end;
  635.  
  636. function TdfsPageSetupDialog.GetCurrentMeasurements: TPSMeasurements;
  637. begin
  638.   if FMeasurements = pmDefault then
  639.     Result := DefaultMeasurements
  640.   else
  641.     Result := FMeasurements;
  642. end;
  643.  
  644. procedure GetPrinter(var DeviceMode, DeviceNames: THandle);
  645. var
  646.   Device, Driver, Port: array[0..79] of char;
  647.   DevNames: PDevNames;
  648.   Offset: PChar;
  649. begin
  650.   Printer.GetPrinter(Device, Driver, Port, DeviceMode);
  651.   if DeviceMode <> 0 then
  652.   begin
  653.     DeviceNames := GlobalAlloc(GHND, SizeOf(TDevNames) + StrLen(Device) +
  654.        StrLen(Driver) + StrLen(Port) + 3);
  655.     DevNames := PDevNames(GlobalLock(DeviceNames));
  656.     try
  657.       Offset := PChar(DevNames) + SizeOf(TDevnames);
  658.       with DevNames^ do
  659.       begin
  660.         wDriverOffset := Longint(Offset) - Longint(DevNames);
  661.         Offset := StrECopy(Offset, Driver) + 1;
  662.         wDeviceOffset := Longint(Offset) - Longint(DevNames);
  663.         Offset := StrECopy(Offset, Device) + 1;
  664.         wOutputOffset := Longint(Offset) - Longint(DevNames);;
  665.         StrCopy(Offset, Port);
  666.       end;
  667.     finally
  668.       GlobalUnlock(DeviceNames);
  669.     end;
  670.   end;
  671. end;
  672.  
  673. procedure SetPrinter(DeviceMode, DeviceNames: THandle);
  674. var
  675.   DevNames: PDevNames;
  676. begin
  677.   DevNames := PDevNames(GlobalLock(DeviceNames));
  678.   try
  679.     with DevNames^ do
  680.       Printer.SetPrinter(PChar(DevNames) + wDeviceOffset, PChar(DevNames) +
  681.          wDriverOffset, PChar(DevNames) + wOutputOffset, DeviceMode);
  682.   finally
  683.     GlobalUnlock(DeviceNames);
  684.     GlobalFree(DeviceNames);
  685.   end;
  686. end;
  687.  
  688. function CopyData(Handle: THandle): THandle;
  689. var
  690.   Src, Dest: PChar;
  691.   Size: Integer;
  692. begin
  693.   if Handle <> 0 then
  694.   begin
  695.     Size := GlobalSize(Handle);
  696.     Result := GlobalAlloc(GHND, Size);
  697.     if Result <> 0 then
  698.       try
  699.         Src := GlobalLock(Handle);
  700.         Dest := GlobalLock(Result);
  701.         if (Src <> nil) and (Dest <> nil) then
  702.            Move(Src^, Dest^, Size);
  703.       finally
  704.         GlobalUnlock(Handle);
  705.         GlobalUnlock(Result);
  706.       end
  707.   end else
  708.     Result := 0;
  709. end;
  710.  
  711. function TdfsPageSetupDialog.DoExecute(Func: pointer): boolean;
  712. const
  713.   PageSetupOptions: array [TPageSetupOption] of DWORD = (
  714.      PSD_DEFAULTMINMARGINS, PSD_DISABLEMARGINS, PSD_DISABLEORIENTATION,
  715.      PSD_DISABLEPAGEPAINTING, PSD_DISABLEPAPER, PSD_DISABLEPRINTER,
  716.      PSD_NOWARNING, PSD_SHOWHELP
  717.     );
  718.   PageSetupMeasurements: array [TPSMeasurements] of DWORD = (
  719.      0, PSD_INHUNDREDTHSOFMILLIMETERS, PSD_INTHOUSANDTHSOFINCHES
  720.     );
  721. var
  722.   Option: TPageSetupOption;
  723.   PageSetup: TPageSetupDlg;
  724.   SavePageSetupDialog: TdfsPageSetupDialog;
  725.   DevHandle: THandle;
  726. begin
  727.   FillChar(PageSetup, SizeOf(PageSetup), 0);
  728.   with PageSetup do
  729.   try
  730.     // Make sure the user has a printer installed.  If not, calling PageSetupDlg
  731.     // will cause an error message to be displayed, so we'll avoid that.
  732.     if FGettingDefaults and (Printers.Printer.Printers.Count < 1) then
  733.     begin
  734.       // No printer installed, just fill with some semi-reasonable default values
  735.       ptPaperSize := Point(8500, 11000); // 8 1/2" X 11" letter size
  736.       rtMinMargin := Rect(250, 250, 250, 250); // 1/4"
  737.       rtMargin := rtMinMargin; // 1/4"
  738.       Result := TRUE;
  739.     end else begin
  740.       {$IFDEF DFS_COMPILER_2}
  741.       hInstance := System.HInstance;
  742.       {$ELSE}
  743.       hInstance := SysInit.HInstance;
  744.       {$ENDIF}
  745.       lStructSize := SizeOf(TPageSetupDlg);
  746.  
  747.       if FGettingDefaults then
  748.       begin
  749.         // Using millimeters always fails to retreive margins and minimum margins.
  750.         // Only inches seems to work so I use that and convert.
  751.         Flags := PSD_MARGINS or PSD_DEFAULTMINMARGINS or PSD_RETURNDEFAULT or
  752.            PSD_INTHOUSANDTHSOFINCHES;
  753.       end else begin
  754.         Flags := PSD_MARGINS;
  755.         Flags := Flags OR PageSetupMeasurements[CurrentMeasurements];
  756.         if not (poDefaultMinMargins in FOptions) then
  757.           Flags := Flags or PSD_MINMARGINS;
  758.  
  759.         if assigned(FOnPrinter) or assigned(FOnInitPaintPage) or
  760.            assigned(FOnPaintPage) or FCentered then
  761.         begin
  762.           Flags := Flags or PSD_ENABLEPAGESETUPHOOK;
  763.           lpfnPageSetupHook := PageSetupDialogHook;
  764.         end;
  765.  
  766.         for Option := Low(Option) to High(Option) do
  767.           if Option in FOptions then
  768.             Flags := Flags OR PageSetupOptions[Option];
  769.     {    if not assigned(FOnPrinter) then
  770.           Flags := Flags OR PSD_DISABLEPRINTER;}
  771.         if assigned(FOnInitPaintPage) and assigned(FOnPaintPage) then
  772.         begin
  773.           Flags := Flags OR PSD_ENABLEPAGEPAINTHOOK;
  774.           lpfnPagePaintHook := PageSetupDialogHook;
  775.         end;
  776.         HookCtl3D := Ctl3D;
  777.         lCustData := FCustomData;
  778.  
  779.         GetPrinter(DevHandle, hDevNames);
  780.         hDevMode := CopyData(DevHandle);
  781.  
  782.         // This appears to do nothing.
  783.         ptPaperSize := FPaperSize.Point;
  784.         rtMinMargin := FMinimumMargins.Rect;
  785.         rtMargin := FMargins.Rect;
  786.         if (Flags and PSD_MINMARGINS) <> 0 then
  787.         begin
  788.           // rtMargin can not be smaller than rtMinMargin or dialog call will fail!
  789.           if rtMargin.Left < rtMinMargin.Left then
  790.             rtMargin.Left := rtMinMargin.Left;
  791.           if rtMargin.Right < rtMinMargin.Right then
  792.             rtMargin.Right := rtMinMargin.Right;
  793.           if rtMargin.Top < rtMinMargin.Top then
  794.             rtMargin.Top := rtMinMargin.Top;
  795.           if rtMargin.Bottom < rtMinMargin.Bottom then
  796.             rtMargin.Bottom := rtMinMargin.Bottom;
  797.         end;
  798.       end;
  799.  
  800.       hWndOwner := Application.Handle;
  801.  
  802.       SavePageSetupDialog := PageSetupDialog;
  803.       PageSetupDialog := Self;
  804.       if FGettingDefaults then
  805.         Result := PageSetupDlg(PageSetup)
  806.       else
  807.         Result := TaskModalDialog(Func, PageSetup);
  808.       PageSetupDialog := SavePageSetupDialog;
  809.     end;
  810.  
  811.     if Result then
  812.     begin
  813.       // don't stomp on values that don't match defaults!
  814.       if FGettingDefaults and (CurrentMeasurements = pmMillimeters) then
  815.       begin
  816.         // Defaults are always retreived in inches because the API won't
  817.         // cooperate with defaults in millimeters.  Have to convert by hand.
  818.         if (csLoading in ComponentState) or
  819.            (DefPaperSizeM.Compare(FPaperSize)) then
  820.         begin
  821.           FPaperSize.X := Round(ptPaperSize.X * 2.54);
  822.           FPaperSize.Y := Round(ptPaperSize.Y * 2.54);
  823.         end;
  824.         if (csLoading in ComponentState) or
  825.            (DefMinimumMarginsM.Compare(FMinimumMargins)) then
  826.         begin
  827.           FMinimumMargins.Left := Round(rtMinMargin.Left * 2.54);
  828.           FMinimumMargins.Top := Round(rtMinMargin.Top * 2.54);
  829.           FMinimumMargins.Right := Round(rtMinMargin.Right * 2.54);
  830.           FMinimumMargins.Bottom := Round(rtMinMargin.Bottom * 2.54);
  831.         end;
  832.         if (csLoading in ComponentState) or
  833.            (DefMarginsM.Compare(FMargins)) then
  834.         begin
  835.           FMargins.Left := Round(rtMargin.Left * 2.54);
  836.           FMargins.Top := Round(rtMargin.Top * 2.54);
  837.           FMargins.Right := Round(rtMargin.Right * 2.54);
  838.           FMargins.Bottom := Round(rtMargin.Bottom * 2.54);
  839.         end;
  840.       end else begin
  841.         FPaperSize.Point := ptPaperSize;
  842.         FMinimumMargins.Rect := rtMinMargin;
  843.         FMargins.Rect := rtMargin;
  844.       end;
  845.  
  846.       // Only do this if not getting defaults
  847.       if not FGettingDefaults then
  848.         SetPrinter(hDevMode, hDevNames);
  849.     end else begin
  850.       if hDevMode <> 0 then GlobalFree(hDevMode);
  851.       if hDevNames <> 0 then GlobalFree(hDevNames);
  852.     end;
  853.   finally
  854.     { Nothing yet }
  855.   end;
  856. end;
  857.  
  858. function TdfsPageSetupDialog.ReadCurrentValues: boolean;
  859. begin
  860.   FGettingDefaults := TRUE;
  861.   try
  862.     Result := DoExecute(@PageSetupDlg)
  863.   finally
  864.     FGettingDefaults := FALSE;
  865.   end;
  866. end;
  867.  
  868. const
  869.   MeasurementsDiv : array [pmMillimeters..pmInches] of TPSMeasureVal = (
  870.      100.0,1000.0
  871.   );
  872.  
  873. function TdfsPageSetupDialog.FromMeasurementVal(Val: integer): TPSMeasureVal;
  874. begin
  875.   Result := Val / MeasurementsDiv[CurrentMeasurements];
  876. end;
  877.  
  878. function TdfsPageSetupDialog.ToMeasurementVal(Val: TPSMeasureVal): integer;
  879. const
  880.   MeasurementsDiv : array [pmMillimeters..pmInches] of TPSMeasureVal = (
  881.      100.0,1000.0
  882.   );
  883. begin
  884.   Result := Round(Val * MeasurementsDiv[CurrentMeasurements]);
  885. end;
  886.  
  887. function TdfsPageSetupDialog.Execute: boolean;
  888. begin
  889.   FGettingDefaults := FALSE; // just in case
  890.   Result := DoExecute(@PageSetupDlg);
  891. end;
  892.  
  893. function TdfsPageSetupDialog.Printer(Wnd: HWND): boolean;
  894. begin
  895.   Result :=  assigned(FOnPrinter);
  896.   if Result then
  897.     FOnPrinter(Self, Wnd);
  898. end;
  899.  
  900. function TdfsPageSetupDialog.DoPrinter(Wnd: HWND): boolean;
  901. begin
  902.   try
  903.     Result := Printer(Wnd);
  904.   except
  905.     Result := FALSE;
  906.     Application.HandleException(Self);
  907.   end;
  908. end;
  909.  
  910. function TdfsPageSetupDialog.GetPaperSizeType: SHORT;
  911. var
  912.   Device, Driver, Port: array[0..79] of char;
  913.   HDevMode: THandle;
  914.   PDevMode: PDeviceMode;
  915. begin
  916.   Result := 0;
  917.   Printers.Printer.GetPrinter(Device, Driver, Port, HDevMode);
  918.   if HDevMode <> 0 then
  919.   begin
  920.     try
  921.       PDevMode := GlobalLock(HDevMode);
  922.       Result := PDevMode.dmPaperSize;
  923.     finally
  924.       GlobalUnlock(HDevMode);
  925.     end;
  926.   end;
  927. end;
  928.  
  929. procedure TdfsPageSetupDialog.SetPaperSizeType(Value: short);
  930. var
  931.   Device, Driver, Port: array[0..79] of char;
  932.   HDevMode: THandle;
  933.   PDevMode: PDeviceMode;
  934. begin
  935.   Printers.Printer.GetPrinter(Device, Driver, Port, HDevMode);
  936.   if HDevMode <> 0 then
  937.   begin
  938.     try
  939.       PDevMode := GlobalLock(HDevMode);
  940.       PDevMode.dmPaperSize := Value;
  941.     finally
  942.       GlobalUnlock(HDevMode);
  943.     end;
  944.   end;
  945. end;
  946.  
  947. function TdfsPageSetupDialog.GetVersion: string;
  948. begin
  949.   Result := DFS_COMPONENT_VERSION;
  950. end;
  951.  
  952. procedure TdfsPageSetupDialog.SetVersion(const Val: string);
  953. begin
  954.   { empty write method, just needed to get it to show up in Object Inspector }
  955. end;
  956.  
  957.  
  958.  
  959. { Initialization and cleanup }
  960.  
  961. procedure InitGlobals;
  962. var
  963.   PageSetup: TPageSetupDlg;
  964. begin
  965.   if not NeedInitGlobals then exit;
  966.   
  967.   NeedInitGlobals := FALSE;
  968.   HelpMsg := RegisterWindowMessage(HelpMsgString);
  969.  
  970.   DefPaperSizeI := TPSPoint.Create;
  971.   DefMinimumMarginsI := TPSRect.Create;
  972.   DefMarginsI := TPSRect.Create;
  973.  
  974.   // Make sure the user has a printer installed.  If not, calling PageSetupDlg
  975.   // will cause an error message to be displayed, so we'll avoid that.
  976.   if Printers.Printer.Printers.Count > 0 then
  977.   begin
  978.     FillChar(PageSetup, SizeOf(PageSetup), 0);
  979.     PageSetup.hInstance := HInstance;
  980.     with PageSetup do
  981.     begin
  982.       lStructSize := SizeOf(TPageSetupDlg);
  983.       hWndOwner := Application.Handle;
  984.       Flags := PSD_MARGINS or PSD_DEFAULTMINMARGINS or PSD_INTHOUSANDTHSOFINCHES
  985.          or PSD_RETURNDEFAULT;
  986.       if PageSetupDlg(PageSetup) then
  987.       begin
  988.         DefPaperSizeI.Point := ptPaperSize;
  989.         DefMinimumMarginsI.Rect := rtMinMargin;
  990.         DefMarginsI.Rect := rtMargin;
  991.       end;
  992.       if hDevMode <> 0 then GlobalFree(hDevMode);
  993.       if hDevNames <> 0 then GlobalFree(hDevNames);
  994.     end;
  995.   end else begin
  996.     // No printer installed, just fill with some semi-reasonable default values
  997.     DefPaperSizeI.Point := Point(8500, 11000); // 8 1/2" X 11" letter size
  998.     DefMinimumMarginsI.Rect := Rect(250, 250, 250, 250); // 1/4"
  999.     DefMarginsI.Rect := DefMinimumMarginsI.Rect; // 1/4"
  1000.   end;
  1001.  
  1002.   DefPaperSizeM := TPSPoint.Create;
  1003.   DefMinimumMarginsM := TPSRect.Create;
  1004.   DefMarginsM := TPSRect.Create;
  1005.  
  1006.   // convert 1/1000 of inches to 1/100 of millimeters
  1007.   DefPaperSizeM.X := Round(DefPaperSizeI.X * 2.54);
  1008.   DefPaperSizeM.Y := Round(DefPaperSizeI.Y * 2.54);
  1009.   DefMinimumMarginsM.Top := Round(DefMinimumMarginsI.Top * 2.54);
  1010.   DefMinimumMarginsM.Left := Round(DefMinimumMarginsI.Left * 2.54);
  1011.   DefMinimumMarginsM.Right := Round(DefMinimumMarginsI.Right * 2.54);
  1012.   DefMinimumMarginsM.Bottom := Round(DefMinimumMarginsI.Bottom * 2.54);
  1013.   DefMarginsM.Top := Round(DefMarginsI.Top * 2.54);
  1014.   DefMarginsM.Left := Round(DefMarginsI.Left * 2.54);
  1015.   DefMarginsM.Right := Round(DefMarginsI.Right * 2.54);
  1016.   DefMarginsM.Bottom := Round(DefMarginsI.Bottom * 2.54);
  1017. end;
  1018.  
  1019. procedure DoneGlobals;
  1020. begin
  1021.   if not NeedInitGlobals then
  1022.   begin
  1023.     NeedInitGlobals := TRUE;
  1024.     DefPaperSizeI.Free;
  1025.     DefMinimumMarginsI.Free;
  1026.     DefMarginsI.Free;
  1027.     DefPaperSizeM.Free;
  1028.     DefMinimumMarginsM.Free;
  1029.     DefMarginsM.Free;
  1030.   end;
  1031. end;
  1032.  
  1033. {$IFDEF DFS_DEBUG}
  1034. var
  1035.   t: dword;
  1036. {$ENDIF}
  1037.  
  1038. initialization
  1039. {$IFDEF DFS_DEBUG}
  1040.   t := timegettime;
  1041. {$ENDIF}
  1042.   NeedInitGlobals := TRUE;
  1043. {$IFDEF DFS_DEBUG}
  1044. //  odm('Milliseconds: ', timegettime - t);
  1045. {$ENDIF}
  1046.  
  1047. finalization
  1048.   DoneGlobals;
  1049. end.
  1050.  
  1051.