home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 February / Chip_2003-02_cd1.bin / zkuste / delphi / kompon / d3456 / PREVIEW.ZIP / Preview.pas < prev    next >
Pascal/Delphi Source File  |  2002-05-11  |  63KB  |  2,001 lines
  1. {------------------------------------------------------------------------------}
  2. {                                                                              }
  3. {  TPrintPreview v4.01 & TPaperPreview v1.01                                   }
  4. {  by Kambiz R. Khojasteh                                                      }
  5. {                                                                              }
  6. {  kambiz@delphiarea.com                                                       }
  7. {  http://www.delphiarea.com                                                   }
  8. {                                                                              }
  9. {  Special thanks to:                                                          }
  10. {    Rinaldo Andrea (Italy)  <laser@nuovacs.it>                                }
  11. {    Jens Christian Fogtmann <jefo@post2.tele.dk>                              }
  12. {    Damian Tarnawsky        <tarnawsky@ali.com.au>                            }
  13. {    Bill Miller             <w2m@netheaven.com>                               }
  14. {    Wen Shihong             <wenshihong@justep.com>                           }
  15. {    Peter Hedlund           <peter@peterandlinda.com>                         }
  16. {    Pavel Zidek (Czech)     <delphi@kopr.cz>              (SaveZoomPos)       }
  17. {                                                                              }
  18. {------------------------------------------------------------------------------}
  19.  
  20. unit Preview;
  21.  
  22. interface
  23.  
  24. uses
  25.   Windows, WinSpool, Messages, Classes, Graphics, Controls, SysUtils, Forms,
  26.   Dialogs, StdCtrls, ExtCtrls, Menus, Printers;
  27.  
  28. const
  29.   crHand = 10;
  30.  
  31. type
  32.  
  33.   EInvalidPreviewData = class(Exception);
  34.  
  35.   { TMetaFileList }
  36.  
  37.   TMetaFileList = class(TObject)
  38.   private
  39.     FRecords: TList;
  40.     FDataStream: TStream;
  41.     FMetaFile: TMetaFile;
  42.     FUseTempFile: Boolean;
  43.     FTempFile: String;
  44.     FOnChange: TNotifyEvent;
  45.     function GetCount: Integer;
  46.     function GetItems(Index: Integer): TMetaFile;
  47.     procedure SetUseTempFile(Value: Boolean);
  48.     function CreateMetaFileStream: TStream;
  49.   public
  50.     constructor Create;
  51.     destructor Destroy; override;
  52.     procedure Clear;
  53.     function Add(AMetaFile: TMetaFile): Integer;
  54.     procedure LoadFromStream(Stream: TStream);
  55.     procedure SaveToStream(Stream: TStream);
  56.     procedure LoadFromFile(const FileName: String);
  57.     procedure SaveToFile(const FileName: String);
  58.     property Count: Integer read GetCount;
  59.     property Items[Index: Integer]: TMetaFile read GetItems; default;
  60.     property UseTempFile: Boolean read FUseTempFile write SetUseTempFile;
  61.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  62.   end;
  63.  
  64.   { TPaperPreview }
  65.  
  66.   TPaperPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; PageRect: TRect) of object;
  67.  
  68.   TPaperPreview = class(TCustomControl)
  69.   private
  70.     FPaperColor: TColor;
  71.     FBorderColor: TColor;
  72.     FBorderSize: TBorderWidth;
  73.     FShadowColor: TColor;
  74.     FShadowSize: TBorderWidth;
  75.     FOnResize: TNotifyEvent;
  76.     FOnPaint: TPaperPaintEvent;
  77.     FOffScreen: TBitmap;
  78.     procedure SetPaperWidth(Value: Integer);
  79.     function GetPaperWidth: Integer;
  80.     procedure SetPaperHeight(Value: Integer);
  81.     function GetPaperHeight: Integer;
  82.     procedure SetPaperColor(Value: TColor);
  83.     procedure SetBorderColor(Value: TColor);
  84.     procedure SetBorderSize(Value: TBorderWidth);
  85.     procedure SetShadowColor(Value: TColor);
  86.     procedure SetShadowSize(Value: TBorderWidth);
  87.   protected
  88.     property Canvas;
  89.     procedure Paint; override;
  90.     function PageRect: TRect; dynamic;
  91.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  92.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  93.     function ActualWidth(APaperWidth: Integer): Integer;
  94.     function ActualHeight(APaperHeight: Integer): Integer;
  95.   public
  96.     constructor Create(AOwner: TComponent); override;
  97.     destructor Destroy; override;
  98.   published
  99.     property Align;
  100.     property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
  101.     property BorderSize: TBorderWidth read FBorderSize write SetBorderSize default 1;
  102.     property Color;
  103.     property Cursor;
  104.     property DragCursor;
  105.     property DragMode;
  106.     property ParentColor;
  107.     property ParentShowHint;
  108.     property PopupMenu;
  109.     property PaperColor: TColor read FPaperColor write SetPaperColor default clWhite;
  110.     property PaperWidth: Integer read GetPaperWidth write SetPaperWidth;
  111.     property PaperHeight: Integer read GetPaperHeight write SetPaperHeight;
  112.     property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
  113.     property ShadowSize: TBorderWidth read FShadowSize write SetShadowSize default 3;
  114.     property ShowHint;
  115.     property TabOrder;
  116.     property TabStop;
  117.     property Visible;
  118.     property OnClick;
  119.     property OnDblClick;
  120.     property OnDragDRop;
  121.     property OnDragOver;
  122.     property OnKeyDown;
  123.     property OnKeyPress;
  124.     property OnKeyUp;
  125.     property OnMouseDown;
  126.     property OnMouseMove;
  127.     property OnMouseUp;
  128.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  129.     property OnPaint: TPaperPaintEvent read FOnPaint write FOnPaint;
  130.   end;
  131.  
  132.   { TPaperPreviewOptions }
  133.  
  134.   TPaperPreviewOptions = class(TPersistent)
  135.   private
  136.     FPaperColor: TColor;
  137.     FBorderColor: TColor;
  138.     FBorderWidth: TBorderWidth;
  139.     FShadowColor: TColor;
  140.     FShadowWidth: TBorderWidth;
  141.     FCursor: TCursor;
  142.     FDragCursor: TCursor;
  143.     FPopupMenu: TPopupMenu;
  144.     FOnChange: TNotifyEvent;
  145.     procedure SetPaperColor(Value: TColor);
  146.     procedure SetBorderColor(Value: TColor);
  147.     procedure SetBorderWidth(Value: TBorderWidth);
  148.     procedure SetShadowColor(Value: TColor);
  149.     procedure SetShadowWidth(Value: TBorderWidth);
  150.     procedure SetCursor(Value: TCursor);
  151.     procedure SetDragCursor(Value: TCursor);
  152.     procedure SetPopupMenu(Value: TPopupMenu);
  153.   protected
  154.     procedure DoChange;
  155.   public
  156.     constructor Create;
  157.     procedure Assign(Source: TPersistent); override;
  158.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  159.   published
  160.     property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
  161.     property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 1;
  162.     property Cursor: TCursor read FCursor write SetCursor default crDefault;
  163.     property DragCursor: TCursor read FDragCursor write SetDragCursor default crHand;
  164.     property PaperColor: TColor read FPaperColor write SetPaperColor default clWhite;
  165.     property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
  166.     property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;
  167.     property ShadowWidth: TBorderWidth read FShadowWidth write SetShadowWidth default 3;
  168.   end;
  169.  
  170.   { TPrintPreview}
  171.  
  172.   TPreviewPrintProgress = procedure(Sender: TObject; PageNum, Progress: Integer;
  173.     var AbortIt: Boolean) of object;
  174.  
  175.   TPreviewState = (psReady, psCreating, psPrinting);
  176.   TZoomState = (zsZoomOther, zsZoomToWidth, zsZoomToHeight, zsZoomToFit);
  177.   TUnits = (mmPixel, mmLoMetric, mmHiMetric, mmLoEnglish, mmHiEnglish, mmTWIPS);
  178.   TPaperType = (pLetter, pLetterSmall, pTabloid, pLedger, pLegal, pStatement,
  179.     pExecutive, pA3, pA4, pA4Small, pA5, pB4, pB5, pFolio, pQuatro, p10x14,
  180.     p11x17, pNote, pEnv9, pEnv10, pEnv11, pEnv12, pEnv14, pCSheet, pDSheet,
  181.     pESheet, pEnvDL, pEnvC5, pEnvC3, pEnvC4, pEnvC6, pEnvC65, pEnvB4, pEnvB5,
  182.     pEnvB6, pEnvItaly, pEnvMonarch, pEnvPersonal, pFanfoldUSStd, pFanfoldGermanStd,
  183.     pFanfoldGermanLegal, pB4ISO, pJapanesePostcard, p9x11, p10x11, p15x11,
  184.     pEnvInvite, pLetterExtra, pLegalExtra, TabloidExtra, pA4Extra, pLetterTransverse,
  185.     pA4Transverse, pLetterExtraTransverse, pAPlus, pBPlus, pLetterPlus, pA4Plus,
  186.     pA5Transverse, pB5Transverse, pA3Extra, pA5Extra, pB5Extra, pA2, pA3Transverse,
  187.     pA3ExtraTransverse, pCustom);
  188.  
  189.   TPrintPreview = class(TScrollBox)
  190.   private
  191.     FPaperView: TPaperPreview;
  192.     FPaperViewOptions: TPaperPreviewOptions;
  193.     FPrintJobTitle: String;
  194.     FPages: TMetaFileList;
  195.     FCanvas: TCanvas;
  196.     FUnits: TUnits;
  197.     FPixels: TPoint;
  198.     FAborted: Boolean;
  199.     FOrientation: TPrinterOrientation;
  200.     FCurrentPage: Integer;
  201.     FPaperType: TPaperType;
  202.     FPaperWidth: Integer;
  203.     FPaperHeight: Integer;
  204.     FState: TPreviewState;
  205.     FZoom: Integer;
  206.     FZoomState: TZoomState;
  207.     FFastPrint: Boolean;
  208.     FOnBeginDoc: TNotifyEvent;
  209.     FOnEndDoc: TNotifyEvent;
  210.     FOnNewPage: TNotifyEvent;
  211.     FOnAbort: TNotifyEvent;
  212.     FOnChange: TNotifyEvent;
  213.     FOnPrintProgress: TPreviewPrintProgress;
  214.     FOnBeforePrint: TNotifyEvent;
  215.     FOnAfterPrint: TNotifyEvent;
  216.     MetaFile: TMetafile;
  217.     FOldMousePos: TPoint;
  218.     FCanScrollHorz: Boolean;
  219.     FCanScrollVert: Boolean;
  220.     FZoomSavePos: Boolean;
  221.     procedure SetPaperViewOptions(Value: TPaperPreviewOptions);
  222.     procedure SetUnits(Value: TUnits);
  223.     procedure SetPaperType(Value: TPaperType);
  224.     procedure SetPaperWidth(Value: Integer);
  225.     procedure SetPaperHeight(Value: Integer);
  226.     procedure SetOrientation(Value: TPrinterOrientation);
  227.     procedure SetZoomState(Value: TZoomState);
  228.     procedure SetZoom(Value: Integer);
  229.     procedure SetCurrentPage(Value: Integer);
  230.     function GetUseTempFile: Boolean;
  231.     procedure SetUseTempFile(Value: Boolean);
  232.     function GetTotalPages: Integer;
  233.     function GetPages(PageNo: Integer): TMetaFile;
  234.     function GetCanvas: TCanvas;
  235.     function GetPrinterInstalled: Boolean;
  236.     function CalculateViewSize(const Space: TPoint): TPoint;
  237.     function IsCustomPaper: Boolean;
  238.     procedure PaperClick(Sender: TObject);
  239.     procedure PaperDblClick(Sender: TObject);
  240.     procedure PaperMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  241.     procedure PaperMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  242.     procedure PaperMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  243.     procedure PaperViewOptionsChanged(Sender: TObject);
  244.     procedure PagesChanged(Sender: TObject);
  245.   protected
  246.     procedure CNKeyDown(var Message: TWMKey); message CN_KEYDOWN;
  247.     procedure Loaded; override;
  248.     procedure Resize; override;
  249.     procedure DoProgress(Current, Done, Total: Integer); virtual;
  250.     procedure PaintPage(Sender: TObject; Canvas: TCanvas; PageRect: TRect); virtual;
  251.     procedure SetPrinterParameters; virtual;
  252.     procedure CreateMetaFileCanvas; virtual;
  253.     procedure CloseMetaFileCanvas; virtual;
  254.     procedure AdjustCanvasView; virtual;
  255.   public
  256.     constructor Create(AOwner: TComponent); override;
  257.     destructor Destroy; override;
  258.     function ConvertUnit(Value: Integer; FromUnit, ToUnit: TUnits): Integer;
  259.     function ToPrinterUnit(Value, Resolution: Integer): Integer;
  260.     function Screen2PrinterUnit(Value: Integer): Integer;
  261.     function PaintGraphic(X, Y: Integer; Graphic: TGraphic): TPoint;
  262.     function PaintWinControl(X, Y: Integer; WinControl: TWinControl): TPoint;
  263.     procedure Clear;
  264.     procedure BeginDoc;
  265.     procedure EndDoc;
  266.     procedure NewPage;
  267.     procedure Abort;
  268.     procedure Print;
  269.     procedure UpdateZoom;
  270.     procedure PrintPages(FirstPage, LastPage: Integer);
  271.     procedure LoadFromStream(Stream: TStream);
  272.     procedure SaveToStream(Stream: TStream);
  273.     procedure LoadFromFile(const FileName: String);
  274.     procedure SaveToFile(const FileName: String);
  275.     property Aborted: Boolean read FAborted;
  276.     property Canvas: TCanvas read GetCanvas;
  277.     property TotalPages: Integer read GetTotalPages;
  278.     property State: TPreviewState read FState;
  279.     property PrinterInstalled: Boolean read GetPrinterInstalled;
  280.     property CurrentPage: Integer read FCurrentPage write SetCurrentPage;
  281.     property Pages[PageNo: Integer]: TMetaFile read GetPages;
  282.   published
  283.     property Align default alClient;
  284.     property FastPrint: Boolean read FFastPrint write FFastPrint default True;
  285.     property TabStop default True;
  286.     property PrintJobTitle: String read FPrintJobTitle write FPrintJobTitle;
  287.     property Units: TUnits read FUnits write SetUnits default mmHiMetric;
  288.     property Orientation: TPrinterOrientation read FOrientation write SetOrientation default poPortrait;
  289.     property PaperType: TPaperType read FPaperType write SetPaperType default pA4;
  290.     property PaperView: TPaperPreviewOptions read FPaperViewOptions write SetPaperViewOptions;
  291.     property PaperWidth: Integer read FPaperWidth write SetPaperWidth stored IsCustomPaper;
  292.     property PaperHeight: Integer read FPaperHeight write SetPaperHeight stored IsCustomPaper;
  293.     property ZoomState: TZoomState read FZoomState write SetZoomState default zsZoomToFit;
  294.     property Zoom: Integer read FZoom write SetZoom default 100;
  295.     property ZoomSavePos: Boolean read FZoomSavePos write FZoomSavePos default True;
  296.     property UseTempFile: Boolean read GetUseTempFile write SetUseTempFile default False;
  297.     property OnBeginDoc: TNotifyEvent read FOnBeginDoc write FOnBeginDoc;
  298.     property OnEndDoc: TNotifyEvent read FOnEndDoc write FOnEndDoc;
  299.     property OnNewPage: TNotifyEvent read FOnNewPage write FOnNewPage;
  300.     property OnAbort: TNotifyEvent read FOnAbort write FOnAbort;
  301.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  302.     property OnPrintProgress: TPreviewPrintProgress read FOnPrintProgress write FOnPrintProgress;
  303.     property OnBeforePrint: TNotifyEvent read FOnBeforePrint write FOnBeforePrint;
  304.     property OnAfterPrint: TNotifyEvent read FOnAfterPrint write FOnAfterPrint;
  305.   end;
  306.  
  307. procedure Register;
  308.  
  309. implementation
  310.  
  311. {$R *.RES}
  312.  
  313. const
  314.   MagicNumber: LongInt     = $50502D4B;
  315.   SNotEnoughMemory         = 'Not enough memory to create a new page';
  316.   SInvalidPreviewData      = 'The content is not Print Preview data.';
  317.  
  318. function GetTemporaryFileName: String;
  319. var
  320.   TempPath: array[0..255] of Char;
  321.   TempFile: array[0..255] of Char;
  322. begin
  323.   GetTempPath(SizeOf(TempPath), TempPath);
  324.   GetTempFileName(TempPath, 'TMP', 0, TempFile);
  325.   Result := StrPas(TempFile);
  326. end;
  327.  
  328. { Based on:                                                                         }
  329. { Sending an image to the printer - by Borland Developer Support Staff              }
  330. { Article ID: 16211  Publish Date: July 16, 1998  Last Modified: September 01, 1999 }
  331.  
  332. type
  333.   PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
  334.   TPalEntriesArray = array[0..0] of TPaletteEntry;
  335.  
  336. {$WARNINGS OFF}
  337. procedure BltTBitmapAsDib(DestDc : hdc;   {Handle of where to blt}
  338.                           x : word;       {Bit at x}
  339.                           y : word;       {Blt at y}
  340.                           Width : word;   {Width to stretch}
  341.                           Height : word;  {Height to stretch}
  342.                           bm : TBitmap);  {the TBitmap to Blt}
  343. var
  344.   OriginalWidth :LongInt;               {width of BM}
  345.   dc : hdc;                             {screen dc}
  346.   IsPaletteDevice : bool;               {if the device uses palettes}
  347.   IsDestPaletteDevice : bool;           {if the device uses palettes}
  348.   BitmapInfoSize : integer;             {sizeof the bitmapinfoheader}
  349.   lpBitmapInfo : PBitmapInfo;           {the bitmap info header}
  350.   hBm : hBitmap;                        {handle to the bitmap}
  351.   hPal : hPalette;                      {handle to the palette}
  352.   OldPal : hPalette;                    {temp palette}
  353.   hBits : THandle;                      {handle to the DIB bits}
  354.   pBits : pointer;                      {pointer to the DIB bits}
  355.   lPPalEntriesArray : PPalEntriesArray; {palette entry array}
  356.   NumPalEntries : integer;              {number of palette entries}
  357.   i : integer;                          {looping variable}
  358. begin
  359. {If range checking is on - lets turn it off for now}
  360. {we will remember if range checking was on by defining}
  361. {a define called CKRANGE if range checking is on.}
  362. {We do this to access array members past the arrays}
  363. {defined index range without causing a range check}
  364. {error at runtime. To satisfy the compiler, we must}
  365. {also access the indexes with a variable. ie: if we}
  366. {have an array defined as a: array[0..0] of byte,}
  367. {and an integer i, we can now access a[3] by setting}
  368. {i := 3; and then accessing a[i] without error}
  369. {$IFOPT R+}
  370.   {$DEFINE CKRANGE}
  371.   {$R-}
  372. {$ENDIF}
  373.  
  374.  {Save the original width of the bitmap}
  375.   OriginalWidth := bm.Width;
  376.  
  377.  {Get the screen's dc to use since memory dc's are not reliable}
  378.   dc := GetDc(0);
  379.  {Are we a palette device?}
  380.   IsPaletteDevice :=
  381.     GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
  382.  {Give back the screen dc}
  383.   ReleaseDc(0, dc);
  384.  
  385.  {Allocate the BitmapInfo structure}
  386.   if IsPaletteDevice then
  387.     BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
  388.   else
  389.     BitmapInfoSize := sizeof(TBitmapInfo);
  390.   GetMem(lpBitmapInfo, BitmapInfoSize);
  391.  
  392.  {Zero out the BitmapInfo structure}
  393.   FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
  394.  
  395.  {Fill in the BitmapInfo structure}
  396.   lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  397.   lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
  398.   lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
  399.   lpBitmapInfo^.bmiHeader.biPlanes := 1;
  400.   if IsPaletteDevice then
  401.     lpBitmapInfo^.bmiHeader.biBitCount := 8
  402.   else
  403.     lpBitmapInfo^.bmiHeader.biBitCount := 24;
  404.   lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  405.   lpBitmapInfo^.bmiHeader.biSizeImage :=
  406.     ((lpBitmapInfo^.bmiHeader.biWidth *
  407.       longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
  408.       lpBitmapInfo^.bmiHeader.biHeight;
  409.   lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  410.   lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  411.   if IsPaletteDevice then begin
  412.     lpBitmapInfo^.bmiHeader.biClrUsed := 256;
  413.     lpBitmapInfo^.bmiHeader.biClrImportant := 256;
  414.   end else begin
  415.     lpBitmapInfo^.bmiHeader.biClrUsed := 0;
  416.     lpBitmapInfo^.bmiHeader.biClrImportant := 0;
  417.   end;
  418.  
  419.  {Take ownership of the bitmap handle and palette}
  420.   hBm := bm.ReleaseHandle;
  421.   hPal := bm.ReleasePalette;
  422.  
  423.  {Get the screen's dc to use since memory dc's are not reliable}
  424.   dc := GetDc(0);
  425.  
  426.   if IsPaletteDevice then begin
  427.    {If we are using a palette, it must be}
  428.    {selected into the dc during the conversion}
  429.     OldPal := SelectPalette(dc, hPal, TRUE);
  430.    {Realize the palette}
  431.     RealizePalette(dc);
  432.   end;
  433.  {Tell GetDiBits to fill in the rest of the bitmap info structure}
  434.   GetDiBits(dc,
  435.             hBm,
  436.             0,
  437.             lpBitmapInfo^.bmiHeader.biHeight,
  438.             nil,
  439.             TBitmapInfo(lpBitmapInfo^),
  440.             DIB_RGB_COLORS);
  441.  
  442.  {Allocate memory for the Bits}
  443.   hBits := GlobalAlloc(GMEM_MOVEABLE,
  444.                        lpBitmapInfo^.bmiHeader.biSizeImage);
  445.   pBits := GlobalLock(hBits);
  446.  {Get the bits}
  447.   GetDiBits(dc,
  448.             hBm,
  449.             0,
  450.             lpBitmapInfo^.bmiHeader.biHeight,
  451.             pBits,
  452.             TBitmapInfo(lpBitmapInfo^),
  453.             DIB_RGB_COLORS);
  454.  
  455.  
  456.   if IsPaletteDevice then begin
  457.    {Lets fix up the color table for buggy video drivers}
  458.     GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
  459.    {$IFDEF VER100}
  460.       NumPalEntries := GetPaletteEntries(hPal,
  461.                                          0,
  462.                                          256,
  463.                                          lPPalEntriesArray^);
  464.    {$ELSE}
  465.       NumPalEntries := GetSystemPaletteEntries(dc,
  466.                                                0,
  467.                                                256,
  468.                                                lPPalEntriesArray^);
  469.    {$ENDIF}
  470.     for i := 0 to (NumPalEntries - 1) do begin
  471.       lpBitmapInfo^.bmiColors[i].rgbRed :=
  472.         lPPalEntriesArray^[i].peRed;
  473.       lpBitmapInfo^.bmiColors[i].rgbGreen :=
  474.         lPPalEntriesArray^[i].peGreen;
  475.       lpBitmapInfo^.bmiColors[i].rgbBlue :=
  476.         lPPalEntriesArray^[i].peBlue;
  477.     end;
  478.     FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
  479.   end;
  480.  
  481.   if IsPaletteDevice then begin
  482.    {Select the old palette back in}
  483.     SelectPalette(dc, OldPal, TRUE);
  484.    {Realize the old palette}
  485.     RealizePalette(dc);
  486.   end;
  487.  
  488.  {Give back the screen dc}
  489.   ReleaseDc(0, dc);
  490.  
  491.  {Is the Dest dc a palette device?}
  492.   IsDestPaletteDevice :=
  493.     GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
  494.  
  495.  
  496.   if IsPaletteDevice then begin
  497.    {If we are using a palette, it must be}
  498.    {selected into the dc during the conversion}
  499.     OldPal := SelectPalette(DestDc, hPal, TRUE);
  500.    {Realize the palette}
  501.     RealizePalette(DestDc);
  502.   end;
  503.  
  504.  {Do the blt}
  505.   StretchDiBits(DestDc,
  506.                 x,
  507.                 y,
  508.                 Width,
  509.                 Height,
  510.                 0,
  511.                 0,
  512.                 OriginalWidth,
  513.                 lpBitmapInfo^.bmiHeader.biHeight,
  514.                 pBits,
  515.                 lpBitmapInfo^,
  516.                 DIB_RGB_COLORS,
  517.                 SrcCopy);
  518.  
  519.   if IsDestPaletteDevice then begin
  520.    {Select the old palette back in}
  521.     SelectPalette(DestDc, OldPal, TRUE);
  522.    {Realize the old palette}
  523.     RealizePalette(DestDc);
  524.   end;
  525.  
  526.  {De-Allocate the Dib Bits}
  527.   GlobalUnLock(hBits);
  528.   GlobalFree(hBits);
  529.  
  530.  {De-Allocate the BitmapInfo}
  531.   FreeMem(lpBitmapInfo, BitmapInfoSize);
  532.  
  533.  {Set the ownership of the bimap handles back to the bitmap}
  534.   bm.Handle := hBm;
  535.   bm.Palette := hPal;
  536.  
  537.   {Turn range checking back on if it was on when we started}
  538. {$IFDEF CKRANGE}
  539.   {$UNDEF CKRANGE}
  540.   {$R+}
  541. {$ENDIF}
  542. end;
  543. {$WARNINGS ON}
  544.  
  545. procedure PrintGraphic(PrinterDC: HDC; DestRect: TRect; Graphic: TGraphic);
  546. var
  547.   Bitmap: TBitmap;
  548. begin
  549.   Bitmap := TBitmap.Create;
  550.   try
  551.     Bitmap.Width := Graphic.Width;
  552.     Bitmap.Height := Graphic.Height;
  553.     Bitmap.Canvas.Draw(0, 0, Graphic);
  554.     BltTBitmapAsDib(PrinterDC, DestRect.Left, DestRect.Top,
  555.       DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, Bitmap);
  556.   finally
  557.     Bitmap.Free;
  558.   end;
  559. end;
  560.  
  561. { TMetaFileList }
  562.  
  563. constructor TMetaFileList.Create;
  564. begin
  565.   inherited Create;
  566.   FRecords := TList.Create;
  567. end;
  568.  
  569. destructor TMetaFileList.Destroy;
  570. begin
  571.   FOnChange := nil;
  572.   Clear;
  573.   FRecords.Free;
  574.   inherited Destroy;
  575. end;
  576.  
  577. procedure TMetaFileList.Clear;
  578. begin
  579.   FRecords.Clear;
  580.   if Assigned(FDataStream) then
  581.   begin
  582.     FDataStream.Free;
  583.     FDataStream := nil;
  584.     if FUseTempFile and FileExists(FTempFile) then
  585.       DeleteFile(FTempFile);
  586.   end;
  587.   if Assigned(FMetaFile) then
  588.   begin
  589.     FMetaFile.Free;
  590.     FMetaFile := nil;
  591.   end;
  592.   if Assigned(FOnChange) then
  593.     FOnChange(Self);
  594. end;
  595.  
  596. function TMetaFileList.Add(AMetaFile: TMetaFile): Integer;
  597. var
  598.   Offset: LongInt;
  599. begin
  600.   if not Assigned(FDataStream) then
  601.     FDataStream := CreateMetaFileStream;
  602.   FDataStream.Seek(0, soFromEnd);
  603.   Offset := FDataStream.Position;
  604.   AMetaFile.SaveToStream(FDataStream);
  605.   Result := FRecords.Add(Pointer(Offset));
  606.   if Assigned(FOnChange) then
  607.     FOnChange(Self);
  608. end;
  609.  
  610. procedure TMetaFileList.LoadFromStream(Stream: TStream);
  611. var
  612.   I: Integer;
  613.   Data: LongInt;
  614. begin
  615.   Stream.Read(Data, SizeOf(Data));
  616.   if MagicNumber <> Data then
  617.     raise EInvalidPreviewData.Create(SInvalidPreviewData);
  618.   Clear;
  619.   Stream.Read(Data, SizeOf(Data));
  620.   FRecords.Capacity := Data;
  621.   for I := Data downto 1 do
  622.   begin
  623.     Stream.Read(Data, SizeOf(Data));
  624.     FRecords.Add(Pointer(Data));
  625.   end;
  626.   FDataStream := CreateMetaFileStream;
  627.   FDataStream.CopyFrom(Stream, Stream.Size - Stream.Position);
  628.   if Assigned(FOnChange) then
  629.     FOnChange(Self);
  630. end;
  631.  
  632. procedure TMetaFileList.SaveToStream(Stream: TStream);
  633. var
  634.   I: Integer;
  635.   Data: LongInt;
  636. begin
  637.   Data := MagicNumber;
  638.   Stream.Write(Data, SizeOf(Data));
  639.   Data := FRecords.Count;
  640.   Stream.Write(Data, SizeOf(Data));
  641.   for I := 0 to FRecords.Count - 1 do
  642.   begin
  643.     Data := LongInt(FRecords[I]);
  644.     Stream.Write(Data, SizeOf(Data));
  645.   end;
  646.   if Assigned(FDataStream) then
  647.   begin
  648.     FDataStream.Position := 0;
  649.     Stream.CopyFrom(FDataStream, FDataStream.Size);
  650.   end;
  651. end;
  652.  
  653. procedure TMetaFileList.LoadFromFile(const FileName: String);
  654. var
  655.   FileStream: TFileStream;
  656. begin
  657.   FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  658.   try
  659.     LoadFromStream(FileStream);
  660.   finally
  661.     FileStream.Free;
  662.   end;
  663. end;
  664.  
  665. procedure TMetaFileList.SaveToFile(const FileName: String);
  666. var
  667.   FileStream: TFileStream;
  668. begin
  669.   FileStream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
  670.   try
  671.     SaveToStream(FileStream);
  672.   finally
  673.     FileStream.Free;
  674.   end;
  675. end;
  676.  
  677. function TMetaFileList.GetCount: Integer;
  678. begin
  679.   Result := FRecords.Count;
  680. end;
  681.  
  682. function TMetaFileList.GetItems(Index: Integer): TMetaFile;
  683. begin
  684.   if not Assigned(FMetaFile) then
  685.     FMetaFile := TMetaFile.Create;
  686.   if (Index >= 0) and (Index < FRecords.Count) then
  687.   begin
  688.     FDataStream.Seek(LongInt(FRecords[Index]), soFromBeginning);
  689.     FMetaFile.LoadFromStream(FDataStream);
  690.   end
  691.   else
  692.     FMetaFile.Clear;
  693.   Result := FMetaFile;
  694. end;
  695.  
  696. procedure TMetaFileList.SetUseTempFile(Value: Boolean);
  697. var
  698.   NewStream: TStream;
  699. begin
  700.   if FUseTempFile <> Value then
  701.   begin
  702.     FUseTempFile := Value;
  703.     if Assigned(FDataStream) then
  704.     begin
  705.       NewStream := CreateMetaFileStream;
  706.       NewStream.CopyFrom(FDataStream, 0);
  707.       FDataStream.Free;
  708.       FDataStream := NewStream;
  709.       if not FUseTempFile and FileExists(FTempFile) then
  710.       begin
  711.         DeleteFile(FTempFile);
  712.         FTempFile := EmptyStr;
  713.       end;
  714.     end;
  715.   end;
  716. end;
  717.  
  718. function TMetaFileList.CreateMetaFileStream: TStream;
  719. begin
  720.   if FUseTempFile then
  721.   begin
  722.     FTempFile := GetTemporaryFileName;
  723.     Result := TFileStream.Create(FTempFile, fmCreate or fmShareExclusive)
  724.   end
  725.   else
  726.     Result := TMemoryStream.Create;
  727. end;
  728.  
  729. { TPaperPreview }
  730.  
  731. constructor TPaperPreview.Create(AOwner: TComponent);
  732. begin
  733.   inherited Create(AOwner);
  734.   ControlStyle := ControlStyle + [csOpaque];
  735.   FOffScreen := TBitmap.Create;
  736.   FBorderColor := clBlack;
  737.   FBorderSize := 1;
  738.   FPaperColor := clWhite;
  739.   FShadowColor := clBtnShadow;
  740.   FShadowSize := 3;
  741.   PaperWidth := 105;
  742.   PaperHeight := 148;
  743. end;
  744.  
  745. destructor TPaperPreview.Destroy;
  746. begin
  747.   FOffScreen.Free;
  748.   inherited Destroy;
  749. end;
  750.  
  751. procedure TPaperPreview.Paint;
  752. var
  753.   R, PR: TRect;
  754.   Region: THandle;
  755. begin
  756.   PR := PageRect;
  757.   FOffScreen.Width := Width;
  758.   FOffScreen.Height := Height;
  759.   with FOffscreen.Canvas do
  760.   begin
  761.     Pen.Mode := pmCopy;
  762.     if BorderSize > 0 then
  763.     begin
  764.       Pen.Width := BorderSize;
  765.       Pen.Style := psInsideFrame;
  766.       Pen.Color := BorderColor;
  767.       Brush.Style := bsClear;
  768.       Rectangle(0, 0, Width - ShadowSize, Height - ShadowSize);
  769.     end;
  770.     if ShadowSize > 0 then
  771.     begin
  772.       Brush.Style := bsSolid;
  773.       Brush.Color := ShadowColor;
  774.       SetRect(R, Width - ShadowSize, ShadowSize, Width, Height);
  775.       FillRect(R);
  776.       SetRect(R, ShadowSize, Height - ShadowSize, Width, Height);
  777.       FillRect(R);
  778.       Brush.Color := Color;
  779.       SetRect(R, Width - ShadowSize, 0, Width, ShadowSize);
  780.       FillRect(R);
  781.       SetRect(R, 0, Height - ShadowSize, ShadowSize, Height);
  782.       FillRect(R);
  783.     end;
  784.     Brush.Style := bsSolid;
  785.     Brush.Color := PaperColor;
  786.     FillRect(PR);
  787.   end;
  788.   if Assigned(FOnPaint) then
  789.   begin
  790.     Region := CreateRectRgn(PR.Left, PR.Top, PR.Right, PR.Bottom);
  791.     SelectClipRgn(FOffScreen.Canvas.Handle, Region);
  792.     try
  793.       FOnPaint(Self, FOffScreen.Canvas, PR);
  794.     finally
  795.       SelectClipRgn(FOffScreen.Canvas.Handle, 0);
  796.       DeleteObject(Region);
  797.     end;
  798.   end;
  799.   BitBlt(Canvas.Handle, 0, 0, Width, Height, FOffScreen.Canvas.Handle,
  800.     0, 0, SRCCOPY);
  801. end;
  802.  
  803. function TPaperPreview.PageRect;
  804. begin
  805.   with Result do
  806.   begin
  807.     Left := BorderSize;
  808.     Top := BorderSize;
  809.     Right := Width - (ShadowSize + BorderSize);
  810.     Bottom := Height - (ShadowSize + BorderSize);
  811.   end;
  812. end;
  813.  
  814. function TPaperPreview.ActualWidth(APaperWidth: Integer): Integer;
  815. begin
  816.   Result := APaperWidth + 2 * FBorderSize + FShadowSize;
  817. end;
  818.  
  819. function TPaperPreview.ActualHeight(APaperHeight: Integer): Integer;
  820. begin
  821.   Result := APaperHeight + 2 * FBorderSize + FShadowSize;
  822. end;
  823.  
  824. procedure TPaperPreview.SetPaperWidth(Value: Integer);
  825. begin
  826.   Width := Value + 2 * FBorderSize + FShadowSize;
  827. end;
  828.  
  829. function TPaperPreview.GetPaperWidth: Integer;
  830. begin
  831.   Result := Width - 2 * FBorderSize - FShadowSize;
  832. end;
  833.  
  834. procedure TPaperPreview.SetPaperHeight(Value: Integer);
  835. begin
  836.   Height := Value + 2 * FBorderSize + FShadowSize;
  837. end;
  838.  
  839. function TPaperPreview.GetPaperHeight: Integer;
  840. begin
  841.   Result := Height - 2 * FBorderSize - FShadowSize;
  842. end;
  843.  
  844. procedure TPaperPreview.SetPaperColor(Value: TColor);
  845. begin
  846.   if FPaperColor <> Value then
  847.   begin
  848.     FPaperColor := Value;
  849.     Invalidate;
  850.   end;
  851. end;
  852.  
  853. procedure TPaperPreview.SetBorderColor(Value: TColor);
  854. begin
  855.   if FBorderColor <> Value then
  856.   begin
  857.     FBorderColor := Value;
  858.     Invalidate;
  859.   end;
  860. end;
  861.  
  862. procedure TPaperPreview.SetBorderSize(Value: TBorderWidth);
  863. begin
  864.   if FBorderSize <> Value then
  865.   begin
  866.     FBorderSize := Value;
  867.     Invalidate;
  868.   end;
  869. end;
  870.  
  871. procedure TPaperPreview.SetShadowColor(Value: TColor);
  872. begin
  873.   if FShadowColor <> Value then
  874.   begin
  875.     FShadowColor := Value;
  876.     Invalidate;
  877.   end;
  878. end;
  879.  
  880. procedure TPaperPreview.SetShadowSize(Value: TBorderWidth);
  881. begin
  882.   if FShadowSize <> Value then
  883.   begin
  884.     FShadowSize := Value;
  885.     Invalidate;
  886.   end;
  887. end;
  888.  
  889. procedure TPaperPreview.WMSize(var Message: TWMSize);
  890. begin
  891.   inherited;
  892.   if Assigned(FOnResize) then
  893.     FOnResize(Self);
  894. end;
  895.  
  896. procedure TPaperPreview.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  897. begin
  898.   Message.Result := 1;
  899. end;
  900.  
  901. { TPaperPreviewOptions }
  902.  
  903. constructor TPaperPreviewOptions.Create;
  904. begin
  905.   inherited Create;
  906.   FBorderColor := clBlack;
  907.   FBorderWidth := 1;
  908.   FCursor := crDefault;
  909.   FDragCursor := crHand;
  910.   FPaperColor := clWhite;
  911.   FShadowColor := clBtnShadow;
  912.   FShadowWidth := 3;
  913. end;
  914.  
  915. procedure TPaperPreviewOptions.Assign(Source: TPersistent);
  916. begin
  917.   if Source is TPaperPreviewOptions then
  918.   begin
  919.     BorderColor := TPaperPreviewOptions(Source).BorderColor;
  920.     BorderWidth :=  TPaperPreviewOptions(Source).BorderWidth;
  921.     Cursor := TPaperPreviewOptions(Source).Cursor;
  922.     DragCursor := TPaperPreviewOptions(Source).DragCursor;
  923.     PaperColor := TPaperPreviewOptions(Source).PaperColor;
  924.     PopupMenu := TPaperPreviewOptions(Source).PopupMenu;
  925.     ShadowColor := TPaperPreviewOptions(Source).ShadowColor;
  926.     ShadowWidth := TPaperPreviewOptions(Source).ShadowWidth;
  927.   end
  928.   else
  929.     inherited Assign(Source);
  930. end;
  931.  
  932. procedure TPaperPreviewOptions.DoChange;
  933. begin
  934.   if Assigned(FOnChange) then FOnChange(self);
  935. end;
  936.  
  937. procedure TPaperPreviewOptions.SetPaperColor(Value: TColor);
  938. begin
  939.   if FPaperColor <> Value then
  940.   begin
  941.     FPaperColor := Value;
  942.     DoChange;
  943.   end;
  944. end;
  945.  
  946. procedure TPaperPreviewOptions.SetBorderColor(Value: TColor);
  947. begin
  948.   if FBorderColor <> Value then
  949.   begin
  950.     FBorderColor := Value;
  951.     DoChange;
  952.   end;
  953. end;
  954.  
  955. procedure TPaperPreviewOptions.SetBorderWidth(Value: TBorderWidth);
  956. begin
  957.   if FBorderWidth <> Value then
  958.   begin
  959.     FBorderWidth := Value;
  960.     DoChange;
  961.   end;
  962. end;
  963.  
  964. procedure TPaperPreviewOptions.SetShadowColor(Value: TColor);
  965. begin
  966.   if FShadowColor <> Value then
  967.   begin
  968.     FShadowColor := Value;
  969.     DoChange;
  970.   end;
  971. end;
  972.  
  973. procedure TPaperPreviewOptions.SetShadowWidth(Value: TBorderWidth);
  974. begin
  975.   if FShadowWidth <> Value then
  976.   begin
  977.     FShadowWidth := Value;
  978.     DoChange;
  979.   end;
  980. end;
  981.  
  982. procedure TPaperPreviewOptions.SetCursor(Value: TCursor);
  983. begin
  984.   if FCursor <> Value then
  985.   begin
  986.     FCursor := Value;
  987.     DoChange;
  988.   end;
  989. end;
  990.  
  991. procedure TPaperPreviewOptions.SetDragCursor(Value: TCursor);
  992. begin
  993.   if FDragCursor <> Value then
  994.   begin
  995.     FDragCursor := Value;
  996.     DoChange;
  997.   end;
  998. end;
  999.  
  1000. procedure TPaperPreviewOptions.SetPopupMenu(Value: TPopupMenu);
  1001. begin
  1002.   if FPopupMenu <> Value then
  1003.   begin
  1004.     FPopupMenu := Value;
  1005.     DoChange;
  1006.   end;
  1007. end;
  1008.  
  1009. { TPrintPreview }
  1010.  
  1011. type
  1012.   TPaperSizeInfo = record
  1013.     ID: Byte;
  1014.     Width, Height: Integer;
  1015.   end;
  1016.  
  1017. const
  1018.   // Paper Sizes are in mmLoMetric
  1019.   PaperSizes: array[TPaperType] of TPaperSizeInfo = (
  1020.     (ID: 1; Width: 2159; Height: 2794),
  1021.     (ID: 2; Width: 2159; Height: 2794),
  1022.     (ID: 3; Width: 2794; Height: 4318),
  1023.     (ID: 4; Width: 4318; Height: 2794),
  1024.     (ID: 5; Width: 2159; Height: 3556),
  1025.     (ID: 6; Width: 1397; Height: 2159),
  1026.     (ID: 7; Width: 1842; Height: 2667),
  1027.     (ID: 8; Width: 2970; Height: 4200),
  1028.     (ID: 9; Width: 2100; Height: 2970),
  1029.     (ID: 10; Width: 2100; Height: 2970),
  1030.     (ID: 11; Width: 1480; Height: 2100),
  1031.     (ID: 12; Width: 2500; Height: 3540),
  1032.     (ID: 13; Width: 1820; Height: 2570),
  1033.     (ID: 14; Width: 2159; Height: 3302),
  1034.     (ID: 15; Width: 2150; Height: 2750),
  1035.     (ID: 16; Width: 2540; Height: 3556),
  1036.     (ID: 17; Width: 2794; Height: 4318),
  1037.     (ID: 18; Width: 2159; Height: 2794),
  1038.     (ID: 19; Width: 984; Height: 2254),
  1039.     (ID: 20; Width: 1048; Height: 2413),
  1040.     (ID: 21; Width: 1143; Height: 2635),
  1041.     (ID: 22; Width: 1207; Height: 2794),
  1042.     (ID: 23; Width: 1270; Height: 2921),
  1043.     (ID: 24; Width: 4318; Height: 5588),
  1044.     (ID: 25; Width: 5588; Height: 8636),
  1045.     (ID: 26; Width: 8636; Height: 11176),
  1046.     (ID: 27; Width: 1100; Height: 2200),
  1047.     (ID: 28; Width: 1620; Height: 2290),
  1048.     (ID: 29; Width: 3240; Height: 4580),
  1049.     (ID: 30; Width: 2290; Height: 3240),
  1050.     (ID: 31; Width: 1140; Height: 1620),
  1051.     (ID: 32; Width: 1140; Height: 2290),
  1052.     (ID: 33; Width: 2500; Height: 3530),
  1053.     (ID: 34; Width: 1760; Height: 2500),
  1054.     (ID: 35; Width: 1760; Height: 1250),
  1055.     (ID: 36; Width: 1100; Height: 2300),
  1056.     (ID: 37; Width: 984; Height: 1905),
  1057.     (ID: 38; Width: 920; Height: 1651),
  1058.     (ID: 39; Width: 3778; Height: 2794),
  1059.     (ID: 40; Width: 2159; Height: 3048),
  1060.     (ID: 41; Width: 2159; Height: 3302),
  1061.     (ID: 42; Width: 2500; Height: 3530),
  1062.     (ID: 43; Width: 1000; Height: 1480),
  1063.     (ID: 44; Width: 2286; Height: 2794),
  1064.     (ID: 45; Width: 2540; Height: 2794),
  1065.     (ID: 46; Width: 3810; Height: 2794),
  1066.     (ID: 47; Width: 2200; Height: 2200),
  1067.     (ID: 50; Width: 2355; Height: 3048),
  1068.     (ID: 51; Width: 2355; Height: 3810),
  1069.     (ID: 52; Width: 2969; Height: 4572),
  1070.     (ID: 53; Width: 2354; Height: 3223),
  1071.     (ID: 54; Width: 2101; Height: 2794),
  1072.     (ID: 55; Width: 2100; Height: 2970),
  1073.     (ID: 56; Width: 2355; Height: 3048),
  1074.     (ID: 57; Width: 2270; Height: 3560),
  1075.     (ID: 58; Width: 3050; Height: 4870),
  1076.     (ID: 59; Width: 2159; Height: 3223),
  1077.     (ID: 60; Width: 2100; Height: 3300),
  1078.     (ID: 61; Width: 1480; Height: 2100),
  1079.     (ID: 62; Width: 1820; Height: 2570),
  1080.     (ID: 63; Width: 3220; Height: 4450),
  1081.     (ID: 64; Width: 1740; Height: 2350),
  1082.     (ID: 65; Width: 2010; Height: 2760),
  1083.     (ID: 66; Width: 4200; Height: 5940),
  1084.     (ID: 67; Width: 2970; Height: 4200),
  1085.     (ID: 68; Width: 3220; Height: 4450),
  1086.     (ID: 255; Width: 0; Height: 0));
  1087.  
  1088. procedure RaiseOutOfMemory;
  1089. begin
  1090.   raise EOutOfMemory.Create(SNotEnoughMemory);
  1091. end;
  1092.  
  1093. procedure SwapValue(var A, B: Integer);
  1094. begin
  1095.   A := A xor B;
  1096.   B := A xor B;
  1097.   A := A xor B;
  1098. end;
  1099.  
  1100. { Corrected by jcf }
  1101. function GetPhysicalPageBounds: TRect;
  1102. var
  1103.   Ofs: TPoint;
  1104.   Size: TPoint;
  1105. begin
  1106.   Ofs.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
  1107.   Ofs.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
  1108.   Size.X := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);
  1109.   Size.Y := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);
  1110.   SetRect(Result, -Ofs.X, -Ofs.Y, Size.X - Ofs.X, Size.Y - Ofs.Y);
  1111. end;
  1112.  
  1113. function ConvertUnits(Value, DPI: Integer; InUnits, OutUnits: TUnits): Integer;
  1114. begin
  1115.   Result := Value;
  1116.   case InUnits of
  1117.     mmLoMetric:
  1118.       case OutUnits of
  1119.         mmLoMetric: Result := Value;
  1120.         mmHiMetric: Result := Value * 10;
  1121.         mmLoEnglish: Result := MulDiv(Value, 10, 254);
  1122.         mmHiEnglish: Result := MulDiv(Value, 100, 254);
  1123.         mmTWIPS: Result := MulDiv(Value, 1440, 254);
  1124.         mmPixel: Result := MulDiv(Value, DPI, 254);
  1125.       end;
  1126.     mmHiMetric:
  1127.       case OutUnits of
  1128.         mmLoMetric: Result := Value div 10;
  1129.         mmHiMetric: Result := Value;
  1130.         mmLoEnglish: Result := Value div 254;
  1131.         mmHiEnglish: Result := MulDiv(Value, 10, 254);
  1132.         mmTWIPS: Result := MulDiv(Value, 1440, 2540);
  1133.         mmPixel: Result := MulDiv(Value, DPI, 2540);
  1134.       end;
  1135.     mmLoEnglish:
  1136.       case OutUnits of
  1137.         mmLoMetric: Result := MulDiv(Value, 254, 10);
  1138.         mmHiMetric: Result := Value * 254;
  1139.         mmLoEnglish: Result := Value;
  1140.         mmHiEnglish: Result := Value * 10;
  1141.         mmTWIPS: Result := MulDiv(Value, 1440, 10);
  1142.         mmPixel: Result := MulDiv(Value, DPI, 10);
  1143.       end;
  1144.     mmHiEnglish:
  1145.       case OutUnits of
  1146.         mmLoMetric: Result := MulDiv(Value, 254, 100);
  1147.         mmHiMetric: Result := MulDiv(Value, 254, 10);
  1148.         mmLoEnglish: Result := Value div 10;
  1149.         mmHiEnglish: Result := Value;
  1150.         mmTWIPS: Result := MulDiv(Value, 1440, 100);
  1151.         mmPixel: Result := MulDiv(Value, DPI, 100);
  1152.       end;
  1153.     mmTWIPS:
  1154.       case OutUnits of
  1155.         mmLoMetric: Result := MulDiv(Value, 254, 1440);
  1156.         mmHiMetric: Result := MulDiv(Value, 2540, 1440);
  1157.         mmLoEnglish: Result := MulDiv(Value, 10, 1440);
  1158.         mmHiEnglish: Result := MulDiv(Value, 100, 1440);
  1159.         mmTWIPS: Result := Value;
  1160.         mmPixel: Result := MulDiv(Value, DPI, 1440);
  1161.       end;
  1162.     mmPixel:
  1163.       case OutUnits of
  1164.         mmLoMetric: Result := MulDiv(Value, 254, DPI);
  1165.         mmHiMetric: Result := MulDiv(Value, 2540, DPI);
  1166.         mmLoEnglish: Result := MulDiv(Value, 10, DPI);
  1167.         mmHiEnglish: Result := MulDiv(Value, 100, DPI);
  1168.         mmTWIPS: Result := MulDiv(Value, 1440, DPI);
  1169.         mmPixel: Result := Value;
  1170.       end;
  1171.   end;
  1172. end;
  1173.  
  1174. constructor TPrintPreview.Create(AOwner: TComponent);
  1175. begin
  1176.   inherited Create(AOwner);
  1177.   Align := alClient;
  1178.   TabStop := True;
  1179.   FAborted := False;
  1180.   FState := psReady;
  1181.   FPaperType := pA4;
  1182.   FOrientation := poPortrait;
  1183.   FUnits := mmHiMetric;
  1184.   with PaperSizes[FPaperType] do
  1185.   begin
  1186.     FPaperWidth := ConvertUnits(Width, Screen.PixelsPerInch, mmLoMetric, FUnits);
  1187.     FPaperHeight := ConvertUnits(Height, Screen.PixelsPerInch, mmLoMetric, FUnits);
  1188.   end;
  1189.   FPixels.X := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, mmPixel);
  1190.   FPixels.Y := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, mmPixel);
  1191.   Font.Name := 'Arial';
  1192.   Font.Height := -260; { 2.6 mm }
  1193.   FZoomState := zsZoomToFit;
  1194.   FZoom := 100;
  1195.   FZoomSavePos := True;
  1196.   FFastPrint := True;
  1197.   FPages := TMetaFileList.Create;
  1198.   FPages.OnChange := PagesChanged;
  1199.   FPaperViewOptions := TPaperPreviewOptions.Create;
  1200.   FPaperViewOptions.OnChange := PaperViewOptionsChanged;
  1201.   FPaperView := TPaperPreview.Create(Self);
  1202.   with FPaperView do
  1203.   begin
  1204.     Parent := Self;
  1205.     TabStop := False;
  1206.     Visible := False;
  1207.     OnPaint := PaintPage;
  1208.     OnClick := PaperClick;
  1209.     OnDblClick := PaperDblClick;
  1210.     OnMouseDown := PaperMouseDown;
  1211.     OnMouseMove := PaperMouseMove;
  1212.     OnMouseUp := PaperMouseUp;
  1213.     PaperColor := FPaperViewOptions.PaperColor;
  1214.     BorderColor := FPaperViewOptions.BorderColor;
  1215.     BorderSize := FPaperViewOptions.BorderWidth;
  1216.     ShadowColor := FPaperViewOptions.ShadowColor;
  1217.     ShadowSize := FPaperViewOptions.ShadowWidth;
  1218.     Cursor := FPaperViewOptions.Cursor;
  1219.     DragCursor := FPaperViewOptions.DragCursor;
  1220.     PopupMenu := FPaperViewOptions.PopupMenu;
  1221.   end;
  1222. end;
  1223.  
  1224. destructor TPrintPreview.Destroy;
  1225. begin
  1226.   FPages.Free;
  1227.   FPaperView.Free;
  1228.   FPaperViewOptions.Free;
  1229.   inherited Destroy;
  1230. end;
  1231.  
  1232. procedure TPrintPreview.Loaded;
  1233. begin
  1234.   inherited Loaded;
  1235.   FPixels.X := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, mmPixel);
  1236.   FPixels.Y := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, mmPixel);
  1237.   UpdateZoom;
  1238. end;
  1239.  
  1240. function TPrintPreview.ConvertUnit(Value: Integer; FromUnit, ToUnit: TUnits): Integer;
  1241. begin
  1242.   Result := ConvertUnits(Value, Screen.PixelsPerInch, FromUnit, ToUnit);
  1243. end;
  1244.  
  1245. function TPrintPreview.ToPrinterUnit(Value, Resolution: Integer): Integer;
  1246. begin
  1247.   Result := ConvertUnits(
  1248.     ConvertUnits(Value, Resolution, mmPixel, mmHiEnglish),
  1249.     Screen.PixelsPerInch, mmHiEnglish, FUnits);
  1250. end;
  1251.  
  1252. function TPrintPreview.Screen2PrinterUnit(Value: Integer): Integer;
  1253. begin
  1254.   Result := ToPrinterUnit(Value, Screen.PixelsPerInch);
  1255. end;
  1256.  
  1257. function TPrintPreview.PaintGraphic(X, Y: Integer; Graphic: TGraphic): TPoint;
  1258. var
  1259.   Bitmap: TBitmap;
  1260. begin
  1261.   if not (Graphic is TBitmap) then
  1262.   begin
  1263.     Bitmap := TBitmap.Create;
  1264.     Bitmap.Width := Graphic.Width;
  1265.     Bitmap.Height := Graphic.Height;
  1266.     Bitmap.Canvas.Draw(0, 0, Graphic);
  1267.   end
  1268.   else
  1269.     Bitmap := Graphic as TBitmap;
  1270.   Result.X := Screen2PrinterUnit(Bitmap.Width);
  1271.   Result.Y := Screen2PrinterUnit(Bitmap.Height);
  1272.   BltTBitmapAsDib(Canvas.Handle, X, Y, Result.X, Result.Y, Bitmap);
  1273.   if not (Graphic is TBitmap) then
  1274.     Bitmap.Free;
  1275. end;
  1276.  
  1277. function TPrintPreview.PaintWinControl(X, Y: Integer; WinControl: TWinControl): TPoint;
  1278. var
  1279.   Bitmap: TBitmap;
  1280. begin
  1281.   Bitmap := TBitmap.Create;
  1282.   try
  1283.     Bitmap.Width := WinControl.Width;
  1284.     Bitmap.Height := WinControl.Height;
  1285.     WinControl.PaintTo(Bitmap.Canvas.Handle, 0, 0);
  1286.     Result := PaintGraphic(X, Y, Bitmap);
  1287.   finally
  1288.     Bitmap.Free;
  1289.   end;
  1290. end;
  1291.  
  1292. procedure TPrintPreview.CNKeyDown(var Message: TWMKey);
  1293. var
  1294.   Key: Word;
  1295.   Shift: TShiftState;
  1296. begin
  1297.   with Message do
  1298.   begin
  1299.     Key := CharCode;
  1300.     Shift := KeyDataToShiftState(KeyData);
  1301.   end;
  1302.   if (Key = VK_HOME) and (Shift = []) then
  1303.     with HorzScrollbar do Position := 0
  1304.   else if (Key = VK_HOME) and (Shift = [ssCtrl]) then
  1305.     with VertScrollbar do Position := 0
  1306.   else if (Key = VK_END) and (Shift = []) then
  1307.     with HorzScrollbar do Position := Range
  1308.   else if (Key = VK_END) and (Shift = [ssCtrl]) then
  1309.     with VertScrollbar do Position := Range
  1310.   else if (Key = VK_LEFT) and (Shift = []) then
  1311.     with HorzScrollbar do Position := Position - Increment
  1312.   else if (Key = VK_LEFT) and (Shift = [ssCtrl]) then
  1313.     with HorzScrollbar do Position := Position - ClientWidth
  1314.   else if (Key = VK_RIGHT) and (Shift = []) then
  1315.     with HorzScrollbar do Position := Position + Increment
  1316.   else if (Key = VK_RIGHT) and (Shift = [ssCtrl]) then
  1317.     with HorzScrollbar do Position := Position + ClientWidth
  1318.   else if (Key = VK_UP) and (Shift = []) then
  1319.     with VertScrollbar do Position := Position - Increment
  1320.   else if (Key = VK_UP) and (Shift = [ssCtrl]) then
  1321.     with VertScrollbar do Position := Position - ClientHeight
  1322.   else if (Key = VK_DOWN) and (Shift = []) then
  1323.     with VertScrollbar do Position := Position + Increment
  1324.   else if (Key = VK_DOWN) and (Shift = [ssCtrl]) then
  1325.     with VertScrollbar do Position := Position + ClientHeight
  1326.   else if (Key = VK_NEXT) and (Shift = [ssCtrl]) then
  1327.     CurrentPage := TotalPages
  1328.   else if (Key = VK_PRIOR) and (Shift = [ssCtrl]) then
  1329.     CurrentPage := 1
  1330.   else if (Key = VK_NEXT) and (Shift = []) then
  1331.     CurrentPage := CurrentPage + 1
  1332.   else if (Key = VK_PRIOR) and (Shift = []) then
  1333.     CurrentPage := CurrentPage - 1
  1334.   else
  1335.     inherited;
  1336. end;
  1337.  
  1338. procedure TPrintPreview.PaperClick(Sender: TObject);
  1339. begin
  1340.   Click;
  1341. end;
  1342.  
  1343. procedure TPrintPreview.PaperDblClick(Sender: TObject);
  1344. begin
  1345.   DblClick;
  1346. end;
  1347.  
  1348. procedure TPrintPreview.PaperMouseDown(Sender: TObject; Button: TMouseButton;
  1349.   Shift: TShiftState; X, Y: Integer);
  1350. begin
  1351.   if not Focused and Enabled then SetFocus;
  1352.   FOldMousePos := Point(X, Y);
  1353.   MouseDown(Button, Shift, X, Y);
  1354. end;
  1355.  
  1356. procedure TPrintPreview.PaperMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  1357. var
  1358.   Delta: TPoint;
  1359. begin
  1360.   MouseMove(Shift, X, Y);
  1361.   if ssLeft in Shift then
  1362.   begin
  1363.     if FCanScrollHorz then
  1364.     begin
  1365.       Delta.X := X - FOldMousePos.X;
  1366.       if not (AutoScroll and HorzScrollBar.Visible) then
  1367.       begin
  1368.         if FPaperView.Left + Delta.X < ClientWidth - HorzScrollBar.Margin - FPaperView.Width then
  1369.           Delta.X := ClientWidth - HorzScrollBar.Margin - FPaperView.Width - FPaperView.Left
  1370.         else if FPaperView.Left + Delta.X > HorzScrollBar.Margin then
  1371.           Delta.X := HorzScrollBar.Margin - FPaperView.Left;
  1372.         FPaperView.Left := FPaperView.Left + Delta.X;
  1373.       end
  1374.       else
  1375.         HorzScrollBar.Position := HorzScrollBar.Position - Delta.X;
  1376.     end;
  1377.     if FCanScrollVert then
  1378.     begin
  1379.       Delta.Y := Y - FOldMousePos.Y;
  1380.       if not (AutoScroll and VertScrollBar.Visible) then
  1381.       begin
  1382.         if FPaperView.Top + Delta.Y < ClientHeight - VertScrollBar.Margin - FPaperView.Height then
  1383.           Delta.Y := ClientHeight - VertScrollBar.Margin - FPaperView.Height - FPaperView.Top
  1384.         else if FPaperView.Top + Delta.Y > VertScrollBar.Margin then
  1385.           Delta.Y := VertScrollBar.Margin - FPaperView.Top;
  1386.         FPaperView.Top := FPaperView.Top + Delta.Y;
  1387.       end
  1388.       else
  1389.         VertScrollBar.Position := VertScrollBar.Position - Delta.Y;
  1390.     end;
  1391.   end;
  1392. end;
  1393.  
  1394. procedure TPrintPreview.PaperMouseUp(Sender: TObject; Button: TMouseButton;
  1395.   Shift: TShiftState; X, Y: Integer);
  1396. begin
  1397.   MouseUp(Button, Shift, X, Y);
  1398. end;
  1399.  
  1400. procedure TPrintPreview.SetPrinterParameters;
  1401. const
  1402.   Orientations: array[TPrinterOrientation] of Integer =
  1403.     (DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
  1404. var
  1405.   DevMode: PDevMode;
  1406.   DeviceMode: THandle;
  1407.   Device, Driver, Port: array[0..255] of Char;
  1408.   PaperSize: TPoint;
  1409.   DriverInfo2: PDriverInfo2;
  1410.   NeededSize: DWord;
  1411.   hPrinter: THandle;
  1412. begin
  1413.   if Printer.Printers.Count <= 0 then Exit;
  1414.   if not (Printer.PrinterIndex in [0..Printer.Printers.Count - 1]) then
  1415.     Printer.PrinterIndex := -1;
  1416.   Printer.GetPrinter(Device, Driver, Port, DeviceMode);
  1417.   hPrinter := Printer.Handle;
  1418.   OpenPrinter(Device, hPrinter, nil);
  1419.   GetMem(DriverInfo2, 255);
  1420.   GetPrinterDriver(hPrinter, nil, 2, DriverInfo2, 255, NeededSize);
  1421.   StrPCopy(Driver, ExtractFileName(StrPas(DriverInfo2^.PDriverPath)));
  1422.   FreeMem(DriverInfo2, 255);
  1423.   DevMode := PDevMode(GlobalLock(DeviceMode));
  1424.   with DevMode^ do
  1425.   begin
  1426.     dmFields := dmFields or DM_PAPERSIZE;
  1427.     if FPaperType = pCustom then
  1428.     begin
  1429.       PaperSize.X := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, mmLoMetric);
  1430.       PaperSize.Y := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, mmLoMetric);
  1431.       if FOrientation = poLandscape then SwapValue(PaperSize.X, PaperSize.Y);
  1432.       dmPaperSize := DMPAPER_USER;
  1433.       dmFields := dmFields or DM_PAPERWIDTH;
  1434.       dmPaperWidth := PaperSize.X;
  1435.       dmFields := dmFields or DM_PAPERLENGTH;
  1436.       dmPaperLength := PaperSize.Y;
  1437.     end
  1438.     else
  1439.       dmPaperSize := PaperSizes[FPaperType].ID;
  1440.     dmFields := dmFields or DM_ORIENTATION;
  1441.     dmOrientation := Orientations[(FOrientation)];
  1442.   end;
  1443.   GlobalUnlock(DeviceMode);
  1444.   Printer.SetPrinter(Device, Driver, Port, DeviceMode);
  1445. end;
  1446.  
  1447. procedure TPrintPreview.Resize;
  1448. begin
  1449.   inherited Resize;
  1450.   UpdateZoom;
  1451. end;
  1452.  
  1453. function TPrintPreview.CalculateViewSize(const Space: TPoint): TPoint;
  1454. begin
  1455.   with FPaperView do
  1456.     case FZoomState of
  1457.       zsZoomOther:
  1458.       begin
  1459.         Result.X := ActualWidth(MulDiv(FPixels.X, FZoom, 100));
  1460.         Result.Y := ActualHeight(MulDiv(FPixels.Y, FZoom, 100));
  1461.       end;
  1462.       zsZoomToWidth:
  1463.       begin
  1464.         Result.X := Space.X;
  1465.         Result.Y := ActualHeight(MulDiv(ActualWidth(Result.X), FPixels.Y, FPixels.X));
  1466.       end;
  1467.       zsZoomToHeight:
  1468.       begin
  1469.         Result.Y := Space.Y;
  1470.         Result.X := ActualWidth(MulDiv(ActualHeight(Result.Y), FPixels.X, FPixels.Y));
  1471.       end;
  1472.       zsZoomToFit:
  1473.       begin
  1474.         if (FPixels.Y / FPixels.X) < (Space.Y / Space.X) then
  1475.         begin
  1476.           Result.X := Space.X;
  1477.           Result.Y := ActualHeight(MulDiv(ActualWidth(Result.X), FPixels.Y, FPixels.X));
  1478.         end
  1479.         else
  1480.         begin
  1481.           Result.Y := Space.Y;
  1482.           Result.X := ActualWidth(MulDiv(ActualHeight(Result.Y), FPixels.X, FPixels.Y));
  1483.         end;
  1484.       end;
  1485.     end;
  1486. end;
  1487.  
  1488. {$WARNINGS OFF}
  1489. procedure TPrintPreview.UpdateZoom;
  1490. var
  1491.   Space: TPoint;
  1492.   Percent: TPoint;
  1493.   ViewPos: TPoint;
  1494.   ViewSize: TPoint;
  1495. begin
  1496.   if csLoading in ComponentState then Exit;
  1497.  
  1498.   Space.X := ClientWidth - 2 * HorzScrollBar.Margin;
  1499.   Space.Y := ClientHeight - 2 * VertScrollBar.Margin;
  1500.  
  1501.   if FZoomSavePos then
  1502.   begin
  1503.     Percent.X := MulDiv(HorzScrollbar.Position, 100, HorzScrollBar.Range - Space.X);
  1504.     if Percent.X < 0 then Percent.X := 0;
  1505.     Percent.Y := MulDiv(VertScrollbar.Position, 100, VertScrollbar.Range - Space.Y);
  1506.     if Percent.Y < 0 then Percent.Y := 0;
  1507.   end;
  1508.  
  1509.   if AutoScroll then
  1510.   begin
  1511.     {$IFDEF VER100}
  1512.     if HorzScrollBar.Visible and (GetWindowLong(Handle, GWL_STYLE) and SB_HORZ <> 0) then
  1513.     {$ELSE}
  1514.     if HorzScrollBar.IsScrollBarVisible then
  1515.     {$ENDIF}
  1516.       Inc(Space.Y, GetSystemMetrics(SM_CYHSCROLL));
  1517.     {$IFDEF VER100}
  1518.     if VertScrollBar.Visible and (GetWindowLong(Handle, GWL_STYLE) and SB_VERT <> 0) then
  1519.     {$ELSE}
  1520.     if VertScrollBar.IsScrollBarVisible then
  1521.     {$ENDIF}
  1522.       Inc(Space.X, GetSystemMetrics(SM_CXVSCROLL));
  1523.   end;
  1524.  
  1525.   DisableAutoRange;
  1526.  
  1527.   HorzScrollbar.Position := 0;
  1528.   VertScrollbar.Position := 0;
  1529.  
  1530.   ViewSize := CalculateViewSize(Space);
  1531.  
  1532.   FCanScrollHorz := (ViewSize.X > Space.X);
  1533.   FCanScrollVert := (ViewSize.Y > Space.Y);
  1534.  
  1535.   if AutoScroll then
  1536.   begin
  1537.     if FCanScrollHorz then
  1538.     begin
  1539.        Dec(Space.Y, GetSystemMetrics(SM_CYHSCROLL));
  1540.        FCanScrollVert := (FPaperView.Height > Space.Y);
  1541.        if FCanScrollVert then
  1542.          Dec(Space.X, GetSystemMetrics(SM_CXVSCROLL));
  1543.        ViewSize := CalculateViewSize(Space);
  1544.     end
  1545.     else if FCanScrollVert then
  1546.     begin
  1547.        Dec(Space.X, GetSystemMetrics(SM_CXVSCROLL));
  1548.        FCanScrollHorz := (FPaperView.Width > Space.X);
  1549.        if FCanScrollHorz then
  1550.          Dec(Space.Y, GetSystemMetrics(SM_CYHSCROLL));
  1551.        ViewSize := CalculateViewSize(Space);
  1552.     end;
  1553.   end;
  1554.  
  1555.   ViewPos.X := HorzScrollBar.Margin;
  1556.   if not FCanScrollHorz then
  1557.     Inc(ViewPos.X, (Space.X - ViewSize.X) div 2);
  1558.  
  1559.   ViewPos.Y := VertScrollBar.Margin;
  1560.   if not FCanScrollVert then
  1561.     Inc(ViewPos.Y, (Space.Y - ViewSize.Y) div 2);
  1562.  
  1563.   FPaperView.SetBounds(ViewPos.X, ViewPos.Y, ViewSize.X, ViewSize.Y);
  1564.  
  1565.   EnableAutoRange;
  1566.  
  1567.   if FZoomSavePos and FCanScrollHorz then
  1568.     HorzScrollbar.Position := MulDiv(Percent.X, HorzScrollBar.Range - Space.X, 100);
  1569.   if FZoomSavePos and FCanScrollVert then
  1570.      VertScrollbar.Position := MulDiv(Percent.Y, VertScrollbar.Range - Space.Y, 100);
  1571.  
  1572.   if FCanScrollHorz or FCanScrollVert then
  1573.     FPaperView.Cursor := FPaperViewOptions.DragCursor
  1574.   else
  1575.     FPaperView.Cursor := FPaperViewOptions.Cursor;
  1576.  
  1577. end;
  1578. {$WARNINGS ON}
  1579.  
  1580. procedure TPrintPreview.PaintPage(Sender: TObject; Canvas: TCanvas; PageRect: TRect);
  1581. begin
  1582.   if (FCurrentPage >= 1) and (FCurrentPage <= TotalPages) then
  1583.     Canvas.StretchDraw(PageRect, TMetaFile(FPages[FCurrentPage-1]))
  1584. end;
  1585.  
  1586. procedure TPrintPreview.PaperViewOptionsChanged(Sender: TObject);
  1587. begin
  1588.   FPaperView.PaperColor := FPaperViewOptions.PaperColor;
  1589.   FPaperView.BorderColor := FPaperViewOptions.BorderColor;
  1590.   FPaperView.BorderSize := FPaperViewOptions.BorderWidth;
  1591.   FPaperView.ShadowColor := FPaperViewOptions.ShadowColor;
  1592.   FPaperView.ShadowSize := FPaperViewOptions.ShadowWidth;
  1593.   FPaperView.Cursor := FPaperViewOptions.Cursor;
  1594.   FPaperView.DragCursor := FPaperViewOptions.DragCursor;
  1595.   FPaperView.PopupMenu := FPaperViewOptions.PopupMenu;
  1596.   UpdateZoom;
  1597. end;
  1598.  
  1599. procedure TPrintPreview.PagesChanged(Sender: TObject);
  1600. begin
  1601.   if TotalPages = 0 then
  1602.   begin
  1603.     FCurrentPage := 0;
  1604.     FPaperView.Visible := False;
  1605.   end
  1606.   else if FCurrentPage = 0 then
  1607.   begin
  1608.     FCurrentPage := 1;
  1609.     FPaperView.Visible := True;
  1610.   end;
  1611.   FPaperView.Refresh;
  1612.   if Assigned(FOnChange) then
  1613.     FOnChange(Self);
  1614. end;
  1615.  
  1616. procedure TPrintPreview.SetPaperViewOptions(Value: TPaperPreviewOptions);
  1617. begin
  1618.   FPaperViewOptions.Assign(Value);
  1619. end;
  1620.  
  1621. procedure TPrintPreview.SetUnits(Value: TUnits);
  1622. begin
  1623.   if FUnits <> Value then
  1624.   begin
  1625.     if FPaperType <> pCustom then
  1626.       with PaperSizes[FPaperType] do
  1627.       begin
  1628.         FPaperWidth := ConvertUnits(Width, Screen.PixelsPerInch, mmLoMetric, Value);
  1629.         FPaperHeight := ConvertUnits(Height, Screen.PixelsPerInch, mmLoMetric, Value);
  1630.       end
  1631.     else
  1632.     begin
  1633.       FPaperWidth := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, Value);
  1634.       FPaperHeight := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, Value);
  1635.     end;
  1636.     Font.Height := ConvertUnits(Font.Height, Screen.PixelsPerInch, FUnits, Value);
  1637.     if Assigned(FCanvas) then
  1638.     begin
  1639.       AdjustCanvasView;
  1640.       FCanvas.Font.Height := ConvertUnits(FCanvas.Font.Height, Screen.PixelsPerInch, FUnits, Value);
  1641.       FCanvas.Pen.Width := ConvertUnits(FCanvas.Pen.Width, Screen.PixelsPerInch, FUnits, Value);
  1642.     end;
  1643.     FUnits := Value;
  1644.   end;
  1645. end;
  1646.  
  1647. procedure TPrintPreview.SetPaperType(Value: TPaperType);
  1648. begin
  1649.   if (FPaperType <> Value) and (FState <> psCreating) then
  1650.   begin
  1651.     FPaperType := Value;
  1652.     if FPaperType <> pCustom then
  1653.     begin
  1654.       with PaperSizes[FPaperType] do
  1655.       begin
  1656.         FPaperWidth := ConvertUnits(Width, Screen.PixelsPerInch, mmLoMetric, FUnits);
  1657.         FPaperHeight := ConvertUnits(Height, Screen.PixelsPerInch, mmLoMetric, FUnits);
  1658.       end;
  1659.       if FOrientation = poLandscape then
  1660.         SwapValue(FPaperWidth, FPaperHeight);
  1661.       FPixels.X := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, mmPixel);
  1662.       FPixels.Y := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, mmPixel);
  1663.       UpdateZoom;
  1664.     end;
  1665.   end;
  1666. end;
  1667.  
  1668. procedure TPrintPreview.SetPaperWidth(Value: Integer);
  1669. begin
  1670.   if Value > High(SmallInt) then Value := High(SmallInt)
  1671.   else if Value < 1 then Value := 1;
  1672.   if (FPaperWidth <> Value) and (FState <> psCreating) then
  1673.   begin
  1674.     FPaperType := pCustom;
  1675.     FPaperWidth := Value;
  1676.     FPixels.X := ConvertUnits(FPaperWidth, Screen.PixelsPerInch, FUnits, mmPixel);
  1677.     UpdateZoom;
  1678.   end;
  1679. end;
  1680.  
  1681. procedure TPrintPreview.SetPaperHeight(Value: Integer);
  1682. begin
  1683.   if Value > High(SmallInt) then Value := High(SmallInt)
  1684.   else if Value < 1 then Value := 1;
  1685.   if (FPaperHeight <> Value) and (FState <> psCreating) then
  1686.   begin
  1687.     FPaperType := pCustom;
  1688.     FPaperHeight := Value;
  1689.     FPixels.Y := ConvertUnits(FPaperHeight, Screen.PixelsPerInch, FUnits, mmPixel);
  1690.     UpdateZoom;
  1691.   end;
  1692. end;
  1693.  
  1694. function TPrintPreview.IsCustomPaper: Boolean;
  1695. begin
  1696.   Result := (FPaperType = pCustom);
  1697. end;
  1698.  
  1699. procedure TPrintPreview.SetOrientation(Value: TPrinterOrientation);
  1700. begin
  1701.   if (FOrientation <> Value) and (FState <> psCreating) then
  1702.   begin
  1703.     FOrientation := Value;
  1704.     SwapValue(FPaperWidth, FPaperHeight);
  1705.     SwapValue(FPixels.X, FPixels.Y);
  1706.     UpdateZoom;
  1707.   end;
  1708. end;
  1709.  
  1710. procedure TPrintPreview.SetZoom(Value: Integer);
  1711. begin
  1712.   if (FZoom <> Value) or (FZoomState <> zsZoomOther) then
  1713.   begin
  1714.     FZoom := Value;
  1715.     FZoomState := zsZoomOther;
  1716.     UpdateZoom;
  1717.   end;
  1718. end;
  1719.  
  1720. procedure TPrintPreview.SetZoomState(Value: TZoomState);
  1721. begin
  1722.   if FZoomState <> Value then
  1723.   begin
  1724.     FZoomState := Value;
  1725.     UpdateZoom;
  1726.   end;
  1727. end;
  1728.  
  1729. procedure TPrintPreview.SetCurrentPage(Value: Integer);
  1730. begin
  1731.   if TotalPages <> 0 then
  1732.   begin
  1733.     if Value < 1 then Value := 1;
  1734.     if Value > TotalPages then Value := TotalPages;
  1735.     if FCurrentPage <> Value then
  1736.     begin
  1737.       FCurrentPage := Value;
  1738.       FPaperView.Refresh;
  1739.       if Assigned(FOnChange) then
  1740.         FOnChange(Self);
  1741.     end;
  1742.   end;
  1743. end;
  1744.  
  1745. function TPrintPreview.GetUseTempFile: Boolean;
  1746. begin
  1747.   Result := FPages.UseTempFile;
  1748. end;
  1749.  
  1750. procedure TPrintPreview.SetUseTempFile(Value: Boolean);
  1751. begin
  1752.   FPages.UseTempFile := Value;
  1753. end;
  1754.  
  1755. function TPrintPreview.GetTotalPages: Integer;
  1756. begin
  1757.   Result := FPages.Count;
  1758. end;
  1759.  
  1760. function TPrintPreview.GetPages(PageNo: Integer): TMetaFile;
  1761. begin
  1762.   if (PageNo >= 1) and (PageNo <= TotalPages) then
  1763.     Result := TMetaFile(FPages[PageNo-1])
  1764.   else
  1765.     Result := nil;
  1766. end;
  1767.  
  1768. function TPrintPreview.GetCanvas: TCanvas;
  1769. begin
  1770.   if (FState = psCreating) and Assigned(FCanvas) then
  1771.     Result := FCanvas
  1772.   else
  1773.     Result := Printer.Canvas;
  1774. end;
  1775.  
  1776. function TPrintPreview.GetPrinterInstalled: Boolean;
  1777. begin
  1778.   Result := (Printer.Printers.Count > 0);
  1779. end;
  1780.  
  1781. procedure TPrintPreview.AdjustCanvasView;
  1782. begin
  1783.   SetMapMode(FCanvas.Handle, MM_ANISOTROPIC);
  1784.   SetWindowExtEx(FCanvas.Handle, FPaperWidth, FPaperHeight, nil);
  1785.   SetViewPortExtEx(FCanvas.Handle, FPixels.X, FPixels.Y, nil);
  1786. end;
  1787.  
  1788. procedure TPrintPreview.CreateMetaFileCanvas;
  1789. begin
  1790.   Metafile := TMetafile.Create;
  1791.   try
  1792.     MetaFile.Width := FPixels.X;
  1793.     MetaFile.Height := FPixels.Y;
  1794.     FCanvas := TMetafileCanvas.Create(Metafile, 0);
  1795.     if FCanvas.Handle = 0 then
  1796.     begin
  1797.       FCanvas.Free;
  1798.       FCanvas := nil;
  1799.       RaiseOutOfMemory;
  1800.     end;
  1801.   except
  1802.     MetaFile.Free;
  1803.     MetaFile := nil;
  1804.     raise;
  1805.   end;
  1806.   AdjustCanvasView;
  1807.   FCanvas.Font.Assign(Font);
  1808. end;
  1809.  
  1810. procedure TPrintPreview.CloseMetaFileCanvas;
  1811. begin
  1812.   FCanvas.Free;
  1813.   FCanvas := nil;
  1814.   if MetaFile.Handle = 0 then
  1815.   begin
  1816.     MetaFile.Free;
  1817.     RaiseOutOfMemory;
  1818.   end;
  1819. end;
  1820.  
  1821. procedure TPrintPreview.Clear;
  1822. begin
  1823.   FPages.Clear;
  1824. end;
  1825.  
  1826. procedure TPrintPreview.BeginDoc;
  1827. begin
  1828.   if FState <> psCreating then
  1829.   begin
  1830.     Clear;
  1831.     FAborted := False;
  1832.     FState := psCreating;
  1833.     if Assigned(FOnBeginDoc) then
  1834.       FOnBeginDoc(Self);
  1835.     NewPage;
  1836.   end;
  1837. end;
  1838.  
  1839. procedure TPrintPreview.EndDoc;
  1840. begin
  1841.   if FState = psCreating then
  1842.   begin
  1843.     CloseMetaFileCanvas;
  1844.     try
  1845.       FPages.Add(MetaFile);
  1846.     finally
  1847.       MetaFile.Free;
  1848.     end;
  1849.     if Assigned(FOnEndDoc) then
  1850.       FOnEndDoc(Self);
  1851.     FState := psReady;
  1852.   end;
  1853. end;
  1854.  
  1855. procedure TPrintPreview.NewPage;
  1856. begin
  1857.   if FState = psCreating then
  1858.   begin
  1859.     if Assigned(FCanvas) then
  1860.     begin
  1861.       CloseMetaFileCanvas;
  1862.       try
  1863.         FPages.Add(MetaFile);
  1864.       finally
  1865.         MetaFile.Free;
  1866.       end;
  1867.     end;
  1868.     CreateMetaFileCanvas;
  1869.     if Assigned(FOnNewPage) then
  1870.       FOnNewPage(Self);
  1871.   end;
  1872. end;
  1873.  
  1874. procedure TPrintPreview.Abort;
  1875. begin
  1876.   FAborted := True;
  1877.   case State of
  1878.     psCreating: begin
  1879.       if Assigned(FOnAbort) then
  1880.         FOnAbort(Self);
  1881.       CloseMetaFileCanvas;
  1882.       if Assigned(MetaFile) then
  1883.         MetaFile.Free;
  1884.       Clear;
  1885.     end;
  1886.     psPrinting:
  1887.       if Printer.Printing and not Printer.Aborted then
  1888.         Printer.Abort;
  1889.   end;
  1890. end;
  1891.  
  1892. procedure TPrintPreview.LoadFromStream(Stream: TStream);
  1893. begin
  1894.   FPages.LoadFromStream(Stream);
  1895. end;
  1896.  
  1897. procedure TPrintPreview.SaveToStream(Stream: TStream);
  1898. begin
  1899.   FPages.SaveToStream(Stream);
  1900. end;
  1901.  
  1902. procedure TPrintPreview.LoadFromFile(const FileName: String);
  1903. begin
  1904.   FPages.LoadFromFile(FileName);
  1905. end;
  1906.  
  1907. procedure TPrintPreview.SaveToFile(const FileName: String);
  1908. begin
  1909.   FPages.SaveToFile(FileName);
  1910. end;
  1911.  
  1912. procedure TPrintPreview.Print;
  1913. begin
  1914.   PrintPages(1, TotalPages);
  1915. end;
  1916.  
  1917. type
  1918.   EAbortPrint = class(EAbort);
  1919.  
  1920. procedure TPrintPreview.DoProgress(Current, Done, Total: Integer);
  1921. var
  1922.   IsAborted: Boolean;
  1923. begin
  1924.   IsAborted := FAborted;
  1925.   if Assigned(FOnPrintProgress) then
  1926.     FOnPrintProgress(Self, Current, MulDiv(100, Done, Total), IsAborted);
  1927.   Application.ProcessMessages;
  1928.   if IsAborted or Printer.Aborted then
  1929.   begin
  1930.     FAborted := True;
  1931.     raise EAbortPrint.Create(EmptyStr);
  1932.   end;
  1933. end;
  1934.  
  1935. procedure TPrintPreview.PrintPages(FirstPage, LastPage: Integer);
  1936. var
  1937.   CurPage: Integer;
  1938.   PrintRect: TRect;
  1939. begin
  1940.   if FirstPage < 1 then FirstPage := 1;
  1941.   if FirstPage > TotalPages then FirstPage := TotalPages;
  1942.   if LastPage < 1 then LastPage := 1;
  1943.   if LastPage > TotalPages then LastPage := TotalPages;
  1944.   if (FState = psReady) and (TotalPages > 0) and
  1945.      (FirstPage <= LastPage) and (Printer.Printers.Count > 0) then
  1946.   begin
  1947.     FState := psPrinting;
  1948.     FAborted := False;
  1949.     try
  1950.       try
  1951.         if Assigned(FOnBeforePrint) then
  1952.           FOnBeforePrint(Self);
  1953.         SetPrinterParameters;
  1954.         PrintRect := GetPhysicalPageBounds;
  1955.         Printer.Title := PrintJobTitle;
  1956.         Printer.BeginDoc;
  1957.         for CurPage := FirstPage to LastPage do
  1958.         begin
  1959.           DoProgress(CurPage, CurPage - FirstPage, LastPage - FirstPage + 1);
  1960.           if FFastPrint then
  1961.             Printer.Canvas.StretchDraw(PrintRect, TMetaFile(FPages[CurPage-1]))
  1962.           else
  1963.             PrintGraphic(Printer.Canvas.Handle, PrintRect, TMetaFile(FPages[CurPage-1]));
  1964.           DoProgress(CurPage, CurPage - FirstPage + 1, LastPage - FirstPage + 1);
  1965.           if CurPage <> LastPage then
  1966.             Printer.NewPage
  1967.         end;
  1968.       except
  1969.         on EAbort do
  1970.           FAborted := True;
  1971.         on E: Exception do
  1972.         begin
  1973.           FAborted := True;
  1974.           Application.ShowException(E);
  1975.         end;
  1976.       end;
  1977.     finally
  1978.       if FAborted then
  1979.       begin
  1980.         if Printer.Printing then Printer.Abort;
  1981.         if Assigned(FOnAbort) then FOnAbort(Self);
  1982.       end;
  1983.       if Printer.Printing then Printer.EndDoc;
  1984.       if not Aborted and Assigned(FOnAfterPrint) then
  1985.         FOnAfterPrint(Self);
  1986.       Printer.Title := EmptyStr;
  1987.       FState := psReady;
  1988.     end;
  1989.   end;
  1990. end;
  1991.  
  1992. procedure Register;
  1993. begin
  1994.   RegisterComponents('Delphi Area', [TPaperPreview, TPrintPreview]);
  1995. end;
  1996.  
  1997. initialization
  1998.   Screen.Cursors[crHand] := LoadCursor(hInstance, 'CURSOR_HAND');
  1999. end.
  2000.  
  2001.