home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / GRAPHICS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  130.5 KB  |  4,875 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Graphics;
  11.  
  12. {$P+,S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes;
  18.  
  19. { Graphics Objects }
  20.  
  21. type
  22.   TColor = $80000000..$7FFFFFFF;
  23.  
  24. const
  25.   clScrollBar = COLOR_SCROLLBAR or $80000000;
  26.   clBackground = COLOR_BACKGROUND or $80000000;
  27.   clActiveCaption = COLOR_ACTIVECAPTION or $80000000;
  28.   clInactiveCaption = COLOR_INACTIVECAPTION or $80000000;
  29.   clMenu = COLOR_MENU or $80000000;
  30.   clWindow = COLOR_WINDOW or $80000000;
  31.   clWindowFrame = COLOR_WINDOWFRAME or $80000000;
  32.   clMenuText = COLOR_MENUTEXT or $80000000;
  33.   clWindowText = COLOR_WINDOWTEXT or $80000000;
  34.   clCaptionText = COLOR_CAPTIONTEXT or $80000000;
  35.   clActiveBorder = COLOR_ACTIVEBORDER or $80000000;
  36.   clInactiveBorder = COLOR_INACTIVEBORDER or $80000000;
  37.   clAppWorkSpace = COLOR_APPWORKSPACE or $80000000;
  38.   clHighlight = COLOR_HIGHLIGHT or $80000000;
  39.   clHighlightText = COLOR_HIGHLIGHTTEXT or $80000000;
  40.   clBtnFace = COLOR_BTNFACE or $80000000;
  41.   clBtnShadow = COLOR_BTNSHADOW or $80000000;
  42.   clGrayText = COLOR_GRAYTEXT or $80000000;
  43.   clBtnText = COLOR_BTNTEXT or $80000000;
  44.   clInactiveCaptionText = COLOR_INACTIVECAPTIONTEXT or $80000000;
  45.   clBtnHighlight = COLOR_BTNHIGHLIGHT or $80000000;
  46.   cl3DDkShadow = COLOR_3DDKSHADOW or $80000000;
  47.   cl3DLight = COLOR_3DLIGHT or $80000000;
  48.   clInfoText = COLOR_INFOTEXT or $80000000;
  49.   clInfoBk = COLOR_INFOBK or $80000000;
  50.  
  51.   clBlack = TColor($000000);
  52.   clMaroon = TColor($000080);
  53.   clGreen = TColor($008000);
  54.   clOlive = TColor($008080);
  55.   clNavy = TColor($800000);
  56.   clPurple = TColor($800080);
  57.   clTeal = TColor($808000);
  58.   clGray = TColor($808080);
  59.   clSilver = TColor($C0C0C0);
  60.   clRed = TColor($0000FF);
  61.   clLime = TColor($00FF00);
  62.   clYellow = TColor($00FFFF);
  63.   clBlue = TColor($FF0000);
  64.   clFuchsia = TColor($FF00FF);
  65.   clAqua = TColor($FFFF00);
  66.   clLtGray = TColor($C0C0C0);
  67.   clDkGray = TColor($808080);
  68.   clWhite = TColor($FFFFFF);
  69.   clNone = TColor($1FFFFFFF);
  70.   clDefault = TColor($20000000);
  71.  
  72. const
  73.   cmBlackness = BLACKNESS;
  74.   cmDstInvert = DSTINVERT;
  75.   cmMergeCopy = MERGECOPY;
  76.   cmMergePaint = MERGEPAINT;
  77.   cmNotSrcCopy = NOTSRCCOPY;
  78.   cmNotSrcErase = NOTSRCERASE;
  79.   cmPatCopy = PATCOPY;
  80.   cmPatInvert = PATINVERT;
  81.   cmPatPaint = PATPAINT;
  82.   cmSrcAnd = SRCAND;
  83.   cmSrcCopy = SRCCOPY;
  84.   cmSrcErase = SRCERASE;
  85.   cmSrcInvert = SRCINVERT;
  86.   cmSrcPaint = SRCPAINT;
  87.   cmWhiteness = WHITENESS;
  88.  
  89. type
  90.   HMETAFILE = THandle;
  91.   HENHMETAFILE = THandle;
  92.  
  93.   EInvalidGraphic = class(Exception);
  94.   EInvalidGraphicOperation = class(Exception);
  95.  
  96.   TGraphic = class;
  97.   TBitmap = class;
  98.   TIcon = class;
  99.   TMetafile = class;
  100.  
  101.   TResData = record
  102.     Handle: THandle;
  103.   end;
  104.  
  105.   TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  106.   TFontStyles = set of TFontStyle;
  107.   TFontPitch = (fpDefault, fpVariable, fpFixed);
  108.   TFontName = string[LF_FACESIZE - 1];
  109.  
  110.   TFontData = record
  111.     Handle: HFont;
  112.     Height: Integer;
  113.     Pitch: TFontPitch;
  114.     Style: TFontStyles;
  115.     Name: TFontName;
  116.   end;
  117.  
  118.   TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
  119.     psInsideFrame);
  120.   TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
  121.     pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
  122.     pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);
  123.  
  124.   TPenData = record
  125.     Handle: HPen;
  126.     Color: TColor;
  127.     Width: Integer;
  128.     Style: TPenStyle;
  129.   end;
  130.  
  131.   TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
  132.     bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
  133.  
  134.   TBrushData = record
  135.     Handle: HBrush;
  136.     Color: TColor;
  137.     Bitmap: TBitmap;
  138.     Style: TBrushStyle;
  139.   end;
  140.  
  141.   PResource = ^TResource;
  142.   TResource = record
  143.     Next: PResource;
  144.     RefCount: Integer;
  145.     Handle: THandle;
  146.     HashCode: Word;
  147.     case Integer of
  148.       0: (Data: TResData);
  149.       1: (Font: TFontData);
  150.       2: (Pen: TPenData);
  151.       3: (Brush: TBrushData);
  152.   end;
  153.  
  154.   TGraphicsObject = class(TPersistent)
  155.   private
  156.     FOnChange: TNotifyEvent;
  157.     FResource: PResource;
  158.   protected
  159.     procedure Changed; dynamic;
  160.   public
  161.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  162.   end;
  163.  
  164.   TFont = class(TGraphicsObject)
  165.   private
  166.     FColor: TColor;
  167.     FPixelsPerInch: Integer;
  168.     procedure GetData(var FontData: TFontData);
  169.     procedure SetData(const FontData: TFontData);
  170.   protected
  171.     function GetHandle: HFont;
  172.     function GetHeight: Integer;
  173.     function GetName: TFontName;
  174.     function GetPitch: TFontPitch;
  175.     function GetSize: Integer;
  176.     function GetStyle: TFontStyles;
  177.     procedure SetColor(Value: TColor);
  178.     procedure SetHandle(Value: HFont);
  179.     procedure SetHeight(Value: Integer);
  180.     procedure SetName(const Value: TFontName);
  181.     procedure SetPitch(Value: TFontPitch);
  182.     procedure SetSize(Value: Integer);
  183.     procedure SetStyle(Value: TFontStyles);
  184.   public
  185.     constructor Create;
  186.     destructor Destroy; override;
  187.     procedure Assign(Source: TPersistent); override;
  188.     property Handle: HFont read GetHandle write SetHandle;
  189.     property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  190.   published
  191.     property Color: TColor read FColor write SetColor;
  192.     property Height: Integer read GetHeight write SetHeight;
  193.     property Name: TFontName read GetName write SetName;
  194.     property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  195.     property Size: Integer read GetSize write SetSize stored False;
  196.     property Style: TFontStyles read GetStyle write SetStyle;
  197.   end;
  198.  
  199.   TPen = class(TGraphicsObject)
  200.   private
  201.     FMode: TPenMode;
  202.     procedure GetData(var PenData: TPenData);
  203.     procedure SetData(const PenData: TPenData);
  204.   protected
  205.     function GetColor: TColor;
  206.     procedure SetColor(Value: TColor);
  207.     function GetHandle: HPen;
  208.     procedure SetHandle(Value: HPen);
  209.     procedure SetMode(Value: TPenMode);
  210.     function GetStyle: TPenStyle;
  211.     procedure SetStyle(Value: TPenStyle);
  212.     function GetWidth: Integer;
  213.     procedure SetWidth(Value: Integer);
  214.   public
  215.     constructor Create;
  216.     destructor Destroy; override;
  217.     procedure Assign(Source: TPersistent); override;
  218.     property Handle: HPen read GetHandle write SetHandle;
  219.   published
  220.     property Color: TColor read GetColor write SetColor default clBlack;
  221.     property Mode: TPenMode read FMode write SetMode default pmCopy;
  222.     property Style: TPenStyle read GetStyle write SetStyle default psSolid;
  223.     property Width: Integer read GetWidth write SetWidth default 1;
  224.   end;
  225.  
  226.   TBrush = class(TGraphicsObject)
  227.   private
  228.     procedure GetData(var BrushData: TBrushData);
  229.     procedure SetData(const BrushData: TBrushData);
  230.   protected
  231.     function GetBitmap: TBitmap;
  232.     procedure SetBitmap(Value: TBitmap);
  233.     function GetColor: TColor;
  234.     procedure SetColor(Value: TColor);
  235.     function GetHandle: HBrush;
  236.     procedure SetHandle(Value: HBrush);
  237.     function GetStyle: TBrushStyle;
  238.     procedure SetStyle(Value: TBrushStyle);
  239.   public
  240.     constructor Create;
  241.     destructor Destroy; override;
  242.     procedure Assign(Source: TPersistent); override;
  243.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  244.     property Handle: HBrush read GetHandle write SetHandle;
  245.   published
  246.     property Color: TColor read GetColor write SetColor default clWhite;
  247.     property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  248.   end;
  249.  
  250.   TFillStyle = (fsSurface, fsBorder);
  251.   TFillMode = (fmAlternate, fmWinding);
  252.  
  253.   TCopyMode = Longint;
  254.  
  255.   TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  256.   TCanvasState = set of TCanvasStates;
  257.  
  258.   TCanvas = class(TPersistent)
  259.   private
  260.     FHandle: HDC;
  261.     State: TCanvasState;
  262.     FFont: TFont;
  263.     FPen: TPen;
  264.     FBrush: TBrush;
  265.     FPenPos: TPoint;
  266.     FCopyMode: TCopyMode;
  267.     FOnChange: TNotifyEvent;
  268.     FOnChanging: TNotifyEvent;
  269.     procedure CreateBrush;
  270.     procedure CreateFont;
  271.     procedure CreatePen;
  272.     procedure BrushChanged(ABrush: TObject);
  273.     procedure DeselectHandles;
  274.     function GetClipRect: TRect;
  275.     function GetHandle: HDC;
  276.     function GetPenPos: TPoint;
  277.     function GetPixel(X, Y: Integer): TColor;
  278.     procedure FontChanged(AFont: TObject);
  279.     procedure PenChanged(APen: TObject);
  280.     procedure SetBrush(Value: TBrush);
  281.     procedure SetFont(Value: TFont);
  282.     procedure SetHandle(Value: HDC);
  283.     procedure SetPen(Value: TPen);
  284.     procedure SetPenPos(Value: TPoint);
  285.     procedure SetPixel(X, Y: Integer; Value: TColor);
  286.   protected
  287.     procedure Changed; virtual;
  288.     procedure Changing; virtual;
  289.     procedure CreateHandle; virtual;
  290.     procedure RequiredState(ReqState: TCanvasState);
  291.   public
  292.     constructor Create;
  293.     destructor Destroy; override;
  294.     procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  295.     procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  296.       const Source: TRect; Color: TColor);
  297.     procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  298.     procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
  299.       const Source: TRect);
  300.     procedure Draw(X, Y: Integer; Graphic: TGraphic);
  301.     procedure DrawFocusRect(const Rect: TRect);
  302.     procedure Ellipse(X1, Y1, X2, Y2: Integer);
  303.     procedure FillRect(const Rect: TRect);
  304.     procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
  305.     procedure FrameRect(const Rect: TRect);
  306.     procedure LineTo(X, Y: Integer);
  307.     procedure MoveTo(X, Y: Integer);
  308.     procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  309.     procedure Polygon(const Points: array of TPoint);
  310.     procedure Polyline(const Points: array of TPoint);
  311.     procedure Rectangle(X1, Y1, X2, Y2: Integer);
  312.     procedure Refresh;
  313.     procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  314.     procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
  315.     function TextHeight(const Text: string): Integer;
  316.     procedure TextOut(X, Y: Integer; const Text: string);
  317.     procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  318.     function TextWidth(const Text: string): Integer;
  319.     property ClipRect: TRect read GetClipRect;
  320.     property Handle: HDC read GetHandle write SetHandle;
  321.     property PenPos: TPoint read GetPenPos write SetPenPos;
  322.     property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
  323.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  324.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  325.   published
  326.     property Brush: TBrush read FBrush write SetBrush;
  327.     property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
  328.     property Font: TFont read FFont write SetFont;
  329.     property Pen: TPen read FPen write SetPen;
  330.   end;
  331.  
  332.   { The TGraphic class is a abstract base class for dealing with graphic images
  333.     such as metafile, bitmaps and icons; but is not limited to such.
  334.       LoadFromFile - Read the graphic from the file system.  The old contents of
  335.         the graphic are lost.  If the file is not of the right format, an
  336.         exception will be generated.
  337.       SaveToFile - Writes the graphic to disk in the file provided.
  338.       LoadFromStream - Like LoadFromFile except source is a stream (e.g.
  339.         TBlobStream).
  340.       SaveToStream - stream analogue of SaveToFile.
  341.       LoadFromClipboardFormat - Replaces the current image with the data
  342.         provided.  If the TGraphic does not support that format it will generate
  343.         an exception.
  344.       SaveToClipboardFormats - Converts the image to a clipboard format.  If the
  345.         image does not support being translated into a clipboard format it
  346.         will generate an exception.
  347.       Height - The native, unstretched, height of the graphic.
  348.       Width - The native, unstretched, width of the graphic.
  349.       OnChange - Called whenever the graphic changes }
  350.  
  351.   TGraphic = class(TPersistent)
  352.   private
  353.     FOnChange: TNotifyEvent;
  354.     FModified: Boolean;
  355.     FReserved: Byte;
  356.     procedure SetModified(Value: Boolean);
  357.   protected
  358.     constructor Create; virtual;
  359.     procedure Changed(Sender: TObject);
  360.     procedure DefineProperties(Filer: TFiler); override;
  361.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
  362.     function Equals(Graphic: TGraphic): Boolean; virtual;
  363.     function GetEmpty: Boolean; virtual; abstract;
  364.     function GetHeight: Integer; virtual; abstract;
  365.     function GetWidth: Integer; virtual; abstract;
  366.     procedure ReadData(Stream: TStream); virtual;
  367.     procedure SetHeight(Value: Integer); virtual; abstract;
  368.     procedure SetWidth(Value: Integer); virtual; abstract;
  369.     procedure WriteData(Stream: TStream); virtual;
  370.   public
  371.     procedure LoadFromFile(const Filename: string); virtual;
  372.     procedure SaveToFile(const Filename: string); virtual;
  373.     procedure LoadFromStream(Stream: TStream); virtual; abstract;
  374.     procedure SaveToStream(Stream: TStream); virtual; abstract;
  375.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  376.       APalette: HPALETTE); virtual; abstract;
  377.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  378.       var APalette: HPALETTE); virtual; abstract;
  379.     property Empty: Boolean read GetEmpty;
  380.     property Height: Integer read GetHeight write SetHeight;
  381.     property Modified: Boolean read FModified write SetModified;
  382.     property Width: Integer read GetWidth write SetWidth;
  383.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  384.   end;
  385.  
  386.   TGraphicClass = class of TGraphic;
  387.  
  388.   { TPicture }
  389.   { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
  390.     graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
  391.     polymorphic. For example, if the TPicture is holding an Icon, you can
  392.     LoadFromFile a bitmap file, where if the class was TIcon you could only read
  393.     .ICO files.
  394.       LoadFromFile - Reads a picture from disk.  The TGraphic class created
  395.         determined by the file extension of the file.  If the file extension is
  396.         not recognized an exception is generated.
  397.       SaveToFile - Writes the picture to disk.
  398.       LoadFromClipboardFormat - Reads the picture from the handle provided in
  399.         the given clipboard format.  If the format is not supported, an
  400.         exception is generated.
  401.       SaveToClipboardFormats - Allocates a global handle and writes the picture
  402.         in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE
  403.         for metafiles, etc.).  Formats will contain the formats written.
  404.         Returns the number of clipboard items written to the array pointed to
  405.         by Formats and Datas or would be written if either Formats or Datas are
  406.         nil.
  407.       SupportsClipboardFormat - Returns true if the given clipboard format
  408.         is supported by LoadFromClipboardFormat.
  409.       Assign - Copys the contents of the given TPicture.  Used most often in
  410.         the implementation of TPicture properties.
  411.       RegisterFileFormat - Register a new TGraphic class for use in
  412.         LoadFromFile.
  413.       RegisterClipboardFormat - Registers a new TGraphic class for use in
  414.         LoadFromClipboardFormat.
  415.       Height - The native, unstretched, height of the picture.
  416.       Width - The native, unstretched, width of the picture.
  417.       Graphic - The TGraphic object contained by the TPicture
  418.       Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
  419.         contents are thrown away and a blank bitmap is returned.
  420.       Icon - Returns an icon.  If the contents is not already an icon, the
  421.         contents are thrown away and a blank icon is returned.
  422.       Metafile - Returns a metafile.  If the contents is not already a metafile,
  423.         the contents are thrown away and a blank metafile is returned. }
  424.   TPicture = class(TPersistent)
  425.   private
  426.     FGraphic: TGraphic;
  427.     FOnChange: TNotifyEvent;
  428.     procedure ForceType(GraphicType: TGraphicClass);
  429.     function GetBitmap: TBitmap;
  430.     function GetHeight: Integer;
  431.     function GetIcon: TIcon;
  432.     function GetMetafile: TMetafile;
  433.     function GetWidth: Integer;
  434.     procedure ReadData(Stream: TStream);
  435.     procedure SetBitmap(Value: TBitmap);
  436.     procedure SetGraphic(Value: TGraphic);
  437.     procedure SetIcon(Value: TIcon);
  438.     procedure SetMetafile(Value: TMetafile);
  439.     procedure WriteData(Stream: TStream);
  440.   protected
  441.     procedure AssignTo(Dest: TPersistent); override;
  442.     procedure Changed(Sender: TObject);
  443.     procedure DefineProperties(Filer: TFiler); override;
  444.   public
  445.     destructor Destroy; override;
  446.     procedure LoadFromFile(const Filename: string);
  447.     procedure SaveToFile(const Filename: string);
  448.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  449.       APalette: HPALETTE);
  450.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  451.       var APalette: HPALETTE);
  452.     class function SupportsClipboardFormat(AFormat: Word): Boolean;
  453.     procedure Assign(Source: TPersistent); override;
  454.     class procedure RegisterFileFormat(const AExtension, ADescription: string;
  455.       AGraphicClass: TGraphicClass);
  456.     class procedure RegisterFileFormatRes(const AExtension: String;
  457.       ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  458.     class procedure RegisterClipboardFormat(AFormat: Word;
  459.       AGraphicClass: TGraphicClass);
  460.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  461.     property Graphic: TGraphic read FGraphic write SetGraphic;
  462.     property Height: Integer read GetHeight;
  463.     property Icon: TIcon read GetIcon write SetIcon;
  464.     property Metafile: TMetafile read GetMetafile write SetMetafile;
  465.     property Width: Integer read GetWidth;
  466.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  467.   end;
  468.  
  469.   { TMetafile }
  470.   { TMetafile is an encapsulation of the Win32 Enhanced metafile.
  471.       Handle - The metafile handle.
  472.       Enhanced - determines how the metafile will be stored on disk.
  473.         Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
  474.         Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
  475.         The in-memory format is always EMF.  WMF has very limited capabilities;
  476.         storing as WMF will lose information that would be retained by EMF.
  477.         This property is set to match the metafile type when loaded from a
  478.         stream or file.  This maintains form file compatibility with 16 bit
  479.         Delphi (If loaded as WMF, then save as WMF).
  480.       Inch - The units per inch assumed by a WMF metafile.  Used to alter
  481.         scale when writing as WMF, but otherwise this property is obsolete.
  482.         Enhanced metafiles maintain complete scale information internally.
  483.       MMWidth,
  484.       MMHeight: Width and Height in 0.01 millimeter units, the native
  485.         scale used by enhanced metafiles.  The Width and Height properties
  486.         are always in screen device pixel units; you can avoid loss of
  487.         precision in converting between device pixels and mm by setting
  488.         or reading the dimentions in mm with these two properties.
  489.       CreatedBy - Optional name of the author or application used to create
  490.         the metafile.
  491.       Description - Optional text description of the metafile.
  492.       You can set the CreatedBy and Description of a new metafile by calling
  493.       TMetafileCanvas.CreateWithComment.
  494.  
  495.     TMetafileCanvas
  496.       To create a metafile image from scratch, you must draw the image in
  497.       a metafile canvas.  When the canvas is destroyed, it transfers the
  498.       image into the metafile object provided to the canvas constructor.
  499.       After the image is drawn on the canvas and the canvas is destroyed,
  500.       the image is 'playable' in the metafile object.  Like this:
  501.  
  502.       MyMetafile := TMetafile.Create;
  503.       with TMetafileCanvas.Create(MyMetafile, 0) do
  504.       try
  505.         Brush.Color := clRed;
  506.         Ellipse(0,0,100,100);
  507.         ...
  508.       finally
  509.         Free;
  510.       end;
  511.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle  *)
  512.  
  513.       To add to an existing metafile image, create a metafile canvas
  514.       and play the source metafile into the metafile canvas.  Like this:
  515.  
  516.       (* continued from previous example, so MyMetafile contains an image *)
  517.       with TMetafileCanvas.Create(MyMetafile, 0) do
  518.       try
  519.         Draw(0,0,MyMetafile);
  520.         Brush.Color := clBlue;
  521.         Ellipse(100,100,200,200);
  522.         ...
  523.       finally
  524.         Free;
  525.       end;
  526.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle and 1 blue circle *)
  527.   }
  528.  
  529.   TMetafileCanvas = class(TCanvas)
  530.   private
  531.     FMetafile: TMetafile;
  532.   public
  533.     constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  534.     constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
  535.       const CreatedBy, Description: String);
  536.     destructor Destroy; override;
  537.   end;
  538.  
  539.   TMetafileImage = class
  540.   private
  541.     FRefCount: Integer;
  542.     FHandle: HENHMETAFILE;
  543.     FWidth: Integer;      // FWidth and FHeight are in 0.01 mm logical pixels
  544.     FHeight: Integer;     // These are converted to device pixels in TMetafile
  545.     FPalette: HPALETTE;
  546.     FInch: Word;          // Used only when writing WMF files.
  547.     FTempWidth: Integer;  // FTempWidth and FTempHeight are in device pixels
  548.     FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
  549.     procedure Reference;
  550.     procedure Release;
  551.   end;
  552.  
  553.   TMetafile = class(TGraphic)
  554.   private
  555.     FImage: TMetafileImage;
  556.     FEnhanced: Boolean;
  557.     function GetAuthor: String;
  558.     function GetDesc: String;
  559.     function GetHandle: HENHMETAFILE;
  560.     function GetInch: Word;
  561.     function GetMMHeight: Integer;
  562.     function GetMMWidth: Integer;
  563.     function GetPalette: HPALETTE;
  564.     procedure NewImage;
  565.     procedure SetHandle(Value: HENHMETAFILE);
  566.     procedure SetInch(Value: Word);
  567.     procedure SetMMHeight(Value: Integer);
  568.     procedure SetMMWidth(Value: Integer);
  569.     procedure UniqueImage;
  570.   protected
  571.     function GetEmpty: Boolean; override;
  572.     function GetHeight: Integer; override;
  573.     function GetWidth: Integer; override;
  574.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  575.     procedure ReadData(Stream: TStream); override;
  576.     procedure ReadEMFStream(Stream: TStream);
  577.     procedure ReadWMFStream(Stream: TStream; Length: Longint);
  578.     procedure SetHeight(Value: Integer); override;
  579.     procedure SetWidth(Value: Integer); override;
  580.     function  TestEMF(Stream: TStream): Boolean;
  581.     procedure WriteData(Stream: TStream); override;
  582.     procedure WriteEMFStream(Stream: TStream);
  583.     procedure WriteWMFStream(Stream: TStream);
  584.   public
  585.     constructor Create; override;
  586.     destructor Destroy; override;
  587.     procedure Clear;
  588.     procedure LoadFromStream(Stream: TStream); override;
  589.     procedure SaveToFile(const Filename: String); override;
  590.     procedure SaveToStream(Stream: TStream); override;
  591.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  592.       APalette: HPALETTE); override;
  593.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  594.       var APalette: HPALETTE); override;
  595.     procedure Assign(Source: TPersistent); override;
  596.     property CreatedBy: String read GetAuthor;
  597.     property Description: String read GetDesc;
  598.     property Enhanced: Boolean read FEnhanced write FEnhanced default True;
  599.     property Handle: HENHMETAFILE read GetHandle write SetHandle;
  600.     property MMWidth: Integer read GetMMWidth write SetMMWidth;
  601.     property MMHeight: Integer read GetMMHeight write SetMMHeight;
  602.     property Inch: Word read GetInch write SetInch;
  603.     property Palette: HPALETTE read GetPalette;
  604.   end;
  605.  
  606.   { TBitmap }
  607.   { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
  608.     the palette realizing automatically as well as having a Canvas to allow
  609.     modifications to the palette.  Creating copies of a TBitmap is very fast
  610.     since the handles is copied not the image.  If the image is modified, and
  611.     the handle is shared by more than one TBitmap object, the image is copied
  612.     before the modification is performed (i.e. copy on write).
  613.       Canvas - Allows drawing on the bitmap.
  614.       Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
  615.         directly should be avoided since it causes the HBITMAP to be copied if
  616.         more than one TBitmap share the handle.
  617.       Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
  618.         directly should be avoided since it causes the HPALETTE to be copied if
  619.         more than one TBitmap share the handle.
  620.       Monochrome - True if the bitmap is a monochrome bitmap }
  621.  
  622.   TInternalImage = class
  623.   private
  624.     FRefCount: Integer;
  625.     FMemoryImage: TCustomMemoryStream;
  626.     procedure Reference;
  627.     procedure Release;
  628.     procedure FreeHandle; virtual; abstract;
  629.   end;
  630.  
  631.   TDIBType = (dtNone, dtWin, dtPM);
  632.  
  633.   TBitmapImage = class(TInternalImage)
  634.   private
  635.     FHandle: HBITMAP;
  636.     FPalette: HBITMAP;
  637.     FWidth: Integer;
  638.     FHeight: Integer;
  639.     FDIBHeader: Pointer;
  640.     FDIBBits: Pointer;
  641.     FMonochrome: Boolean;
  642.     FDIBType: TDIBType;
  643.     procedure FreeHandle; override;
  644.   end;
  645.  
  646.   TBitmap = class(TGraphic)
  647.   private
  648.     FImage: TBitmapImage;
  649.     FCanvas: TCanvas;
  650.     FIgnorePalette: Boolean;
  651.     procedure Changing(Sender: TObject);
  652.     procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; AWidth,
  653.       AHeight: Integer; AMonochrome: Boolean);
  654.     procedure FreeContext;
  655.     function GetCanvas: TCanvas;
  656.     function GetHandle: HBITMAP; virtual;
  657.     function GetMonochrome: Boolean;
  658.     function GetPalette: HPALETTE;
  659.     function GetTransparentColor: TColor;
  660.     procedure HandleNeeded;
  661.     procedure ReadStream(Size: Longint; Stream: TStream);
  662.     procedure ReadStreamDIB(Image: TCustomMemoryStream);
  663.     procedure SetHandle(Value: HBITMAP);
  664.     procedure SetMonochrome(Value: Boolean);
  665.     procedure SetPalette(Value: HPALETTE);
  666.     procedure MemoryImageNeeded;
  667.     procedure PaletteNeeded;
  668.     procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE; NewWidth,
  669.       NewHeight: Integer; NewMonochrome: Boolean; NewImage: TCustomMemoryStream;
  670.       NewDIBType: TDIBType; NewDIBHeader, NewDIBBits: Pointer);
  671.     procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  672.   protected
  673.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  674.     function GetEmpty: Boolean; override;
  675.     function GetHeight: Integer; override;
  676.     function GetWidth: Integer; override;
  677.     procedure ReadData(Stream: TStream); override;
  678.     procedure SetWidth(Value: Integer); override;
  679.     procedure SetHeight(Value: Integer); override;
  680.     procedure WriteData(Stream: TStream); override;
  681.   public
  682.     constructor Create; override;
  683.     destructor Destroy; override;
  684.     procedure Assign(Source: TPersistent); override;
  685.     procedure Dormant;
  686.     procedure FreeImage;
  687.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  688.       APalette: HPALETTE); override;
  689.     procedure LoadFromStream(Stream: TStream); override;
  690.     procedure LoadFromResourceName(Instance: THandle; const ResName: String);
  691.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
  692.     function ReleaseHandle: HBITMAP;
  693.     function ReleasePalette: HPALETTE;
  694.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  695.       var APalette: HPALETTE); override;
  696.     procedure SaveToStream(Stream: TStream); override;
  697.     property Canvas: TCanvas read GetCanvas;
  698.     property Handle: HBITMAP read GetHandle write SetHandle;
  699.     property Monochrome: Boolean read GetMonochrome write SetMonochrome;
  700.     property Palette: HPALETTE read GetPalette write SetPalette;
  701.     property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
  702.     property TransparentColor: TColor read GetTransparentColor;
  703.   end;
  704.  
  705.   { TIcon }
  706.   { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
  707.     so calling stretch draw is not meaningful.
  708.       Handle - The HICON used by the TIcon. }
  709.  
  710.   TIconImage = class(TInternalImage)
  711.   private
  712.     FHandle: HICON;
  713.     procedure FreeHandle; override;
  714.   end;
  715.  
  716.   TIcon = class(TGraphic)
  717.   private
  718.     FImage: TIconImage;
  719.     function GetHandle: HICON;
  720.     procedure HandleNeeded;
  721.     procedure ImageNeeded;
  722.     procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  723.     procedure SetHandle(Value: HICON);
  724.   protected
  725.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  726.     function GetEmpty: Boolean; override;
  727.     function GetHeight: Integer; override;
  728.     function GetWidth: Integer; override;
  729.     procedure SetHeight(Value: Integer); override;
  730.     procedure SetWidth(Value: Integer); override;
  731.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  732.       APalette: HPALETTE); override;
  733.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  734.       var APalette: HPALETTE); override;
  735.   public
  736.     constructor Create; override;
  737.     destructor Destroy; override;
  738.     procedure Assign(Source: TPersistent); override;
  739.     procedure LoadFromStream(Stream: TStream); override;
  740.     function ReleaseHandle: HICON;
  741.     procedure SaveToStream(Stream: TStream); override;
  742.     property Handle: HICON read GetHandle write SetHandle;
  743.   end;
  744.  
  745. function GraphicFilter(GraphicClass: TGraphicClass): string;
  746. function GraphicExtension(GraphicClass: TGraphicClass): string;
  747.  
  748. function ColorToRGB(Color: TColor): Longint;
  749. function ColorToString(Color: TColor): string;
  750. function StringToColor(const S: string): TColor;
  751. procedure GetColorValues(Proc: TGetStrProc);
  752. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  753. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  754.  
  755. function MemAlloc(Size: Longint): Pointer;
  756. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  757.   var ImageSize: DWORD);
  758. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  759.  
  760. function CopyPalette(Palette: HPALETTE): HPALETTE;
  761.  
  762. procedure InitGraphics;
  763. procedure PaletteChanged;
  764. procedure FreeMemoryContexts;
  765.  
  766. implementation
  767.  
  768. { Things left out
  769.   ---------------
  770.   Regions
  771.   PatBlt
  772.   Tabbed text
  773.   Clipping regions
  774.   Coordinate transformations
  775.   Paths
  776.   Beziers }
  777.  
  778. uses Controls, Forms, Consts;
  779.  
  780. const
  781.   csAllValid = [csHandleValid..csBrushValid];
  782.  
  783. var
  784.   ScreenLogPixels: Integer;
  785.   StockPen: HPEN;
  786.   StockBrush: HBRUSH;
  787.   StockFont: HFONT;
  788.   StockIcon: HICON;
  789.  
  790. { Resource managers }
  791.  
  792. const
  793.   ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);
  794.  
  795. type
  796.   TResourceManager = class(TObject)
  797.     ResList: PResource;
  798.     ResDataSize: Word;
  799.     constructor Create(AResDataSize: Word);
  800.     function AllocResource(const ResData): PResource;
  801.     procedure FreeResource(Resource: PResource);
  802.     procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
  803.     procedure AssignResource(GraphicsObject: TGraphicsObject;
  804.       AResource: PResource);
  805.   end;
  806.  
  807. var
  808.   FontManager: TResourceManager;
  809.   PenManager: TResourceManager;
  810.   BrushManager: TResourceManager;
  811.  
  812. function GetHashCode(const Buffer; Count: Integer): Word; assembler;
  813. asm
  814.         MOV     ECX,EDX
  815.         MOV     EDX,EAX
  816.         XOR     EAX,EAX
  817. @@1:    ROL     AX,5
  818.         XOR     AL,[EDX]
  819.         INC     EDX
  820.         DEC     ECX
  821.         JNE     @@1
  822. end;
  823.  
  824. function BlockCompare(const Buf1, Buf2; Count: Integer): Boolean; {assembler;}
  825. type
  826.   BufArray = array[0..MaxInt - 1] of Char;
  827. var
  828.   I: Integer;
  829. begin
  830.   Result := False;
  831.   for I := 0 to Count - 1 do
  832.     if BufArray(Buf1)[I] <> BufArray(Buf2)[I] then Exit;
  833.   Result := True;
  834. end;
  835. {asm
  836.         PUSH    ESI
  837.         PUSH    EDI
  838.         MOV     ESI,EAX
  839.         MOV     EDI,EDX
  840.         XOR     EAX,EAX
  841.         CLD
  842.         REPE    CMPSB
  843.         JNE     @@1
  844.         INC     EAX
  845. @@1:    POP     EDI
  846.         POP     ESI
  847. end;}
  848.  
  849. constructor TResourceManager.Create(AResDataSize: Word);
  850. begin
  851.   ResDataSize := AResDataSize;
  852. end;
  853.  
  854. function TResourceManager.AllocResource(const ResData): PResource;
  855. var
  856.   ResHash: Word;
  857. begin
  858.   ResHash := GetHashCode(ResData, ResDataSize);
  859.   Result := ResList;
  860.   while (Result <> nil) and ((Result^.HashCode <> ResHash) or
  861.     not BlockCompare(Result^.Data, ResData, ResDataSize)) do
  862.     Result := Result^.Next;
  863.   if Result = nil then
  864.   begin
  865.     GetMem(Result, ResDataSize + ResInfoSize);
  866.     with Result^ do
  867.     begin
  868.       Next := ResList;
  869.       RefCount := 0;
  870.       Handle := TResData(ResData).Handle;
  871.       HashCode := ResHash;
  872.       Move(ResData, Data, ResDataSize);
  873.     end;
  874.     ResList := Result;
  875.   end;
  876.   Inc(Result^.RefCount);
  877. end;
  878.  
  879. procedure TResourceManager.FreeResource(Resource: PResource);
  880. var
  881.   P: PResource;
  882. begin
  883.   if Resource <> nil then
  884.     with Resource^ do
  885.     begin
  886.       Dec(RefCount);
  887.       if RefCount = 0 then
  888.       begin
  889.         if Handle <> 0 then DeleteObject(Handle);
  890.         if Resource = ResList then ResList := Resource^.Next else
  891.         begin
  892.           P := ResList;
  893.           while P^.Next <> Resource do P := P^.Next;
  894.           P^.Next := Resource^.Next;
  895.         end;
  896.         FreeMem(Resource, ResDataSize + ResInfoSize);
  897.       end;
  898.     end;
  899. end;
  900.  
  901. procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  902.   const ResData);
  903. var
  904.   P: PResource;
  905. begin
  906.   P := GraphicsObject.FResource;
  907.   GraphicsObject.FResource := AllocResource(ResData);
  908.   if GraphicsObject.FResource <> P then GraphicsObject.Changed;
  909.   FreeResource(P);
  910. end;
  911.  
  912. procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  913.   AResource: PResource);
  914. var
  915.   P: PResource;
  916. begin
  917.   P := GraphicsObject.FResource;
  918.   if P <> AResource then
  919.   begin
  920.     Inc(AResource^.RefCount);
  921.     GraphicsObject.FResource := AResource;
  922.     GraphicsObject.Changed;
  923.     FreeResource(P);
  924.   end;
  925. end;
  926.  
  927. var
  928.   CanvasList: TList;
  929.  
  930. procedure PaletteChanged;
  931. var
  932.   I: Integer;
  933.  
  934.   procedure ClearColor(Resource: PResource);
  935.   begin
  936.     while Resource <> nil do
  937.     begin
  938.       with Resource^ do
  939.         { Assumes Pen.Color and Brush.Color share the same location }
  940.         if (Handle <> 0) and (Pen.Color < 0) then
  941.         begin
  942.           DeleteObject(Handle);
  943.           Handle := 0;
  944.         end;
  945.       Resource := Resource^.Next;
  946.     end;
  947.   end;
  948.  
  949. begin
  950.   { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  951.   for I := 0 to CanvasList.Count - 1 do
  952.     TCanvas(CanvasList[I]).DeselectHandles;
  953.   ClearColor(PenManager.ResList);
  954.   ClearColor(BrushManager.ResList);
  955. end;
  956.  
  957. { Color mapping routines }
  958.  
  959. type
  960.   TColorEntry = record
  961.     Value: TColor;
  962.     Name: string;
  963.   end;
  964.  
  965. const
  966.   Colors: array[0..41] of TColorEntry = (
  967.     (Value: clBlack; Name: 'clBlack'),
  968.     (Value: clMaroon; Name: 'clMaroon'),
  969.     (Value: clGreen; Name: 'clGreen'),
  970.     (Value: clOlive; Name: 'clOlive'),
  971.     (Value: clNavy; Name: 'clNavy'),
  972.     (Value: clPurple; Name: 'clPurple'),
  973.     (Value: clTeal; Name: 'clTeal'),
  974.     (Value: clGray; Name: 'clGray'),
  975.     (Value: clSilver; Name: 'clSilver'),
  976.     (Value: clRed; Name: 'clRed'),
  977.     (Value: clLime; Name: 'clLime'),
  978.     (Value: clYellow; Name: 'clYellow'),
  979.     (Value: clBlue; Name: 'clBlue'),
  980.     (Value: clFuchsia; Name: 'clFuchsia'),
  981.     (Value: clAqua; Name: 'clAqua'),
  982.     (Value: clWhite; Name: 'clWhite'),
  983.     (Value: clScrollBar; Name: 'clScrollBar'),
  984.     (Value: clBackground; Name: 'clBackground'),
  985.     (Value: clActiveCaption; Name: 'clActiveCaption'),
  986.     (Value: clInactiveCaption; Name: 'clInactiveCaption'),
  987.     (Value: clMenu; Name: 'clMenu'),
  988.     (Value: clWindow; Name: 'clWindow'),
  989.     (Value: clWindowFrame; Name: 'clWindowFrame'),
  990.     (Value: clMenuText; Name: 'clMenuText'),
  991.     (Value: clWindowText; Name: 'clWindowText'),
  992.     (Value: clCaptionText; Name: 'clCaptionText'),
  993.     (Value: clActiveBorder; Name: 'clActiveBorder'),
  994.     (Value: clInactiveBorder; Name: 'clInactiveBorder'),
  995.     (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
  996.     (Value: clHighlight; Name: 'clHighlight'),
  997.     (Value: clHighlightText; Name: 'clHighlightText'),
  998.     (Value: clBtnFace; Name: 'clBtnFace'),
  999.     (Value: clBtnShadow; Name: 'clBtnShadow'),
  1000.     (Value: clGrayText; Name: 'clGrayText'),
  1001.     (Value: clBtnText; Name: 'clBtnText'),
  1002.     (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
  1003.     (Value: clBtnHighlight; Name: 'clBtnHighlight'),
  1004.     (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
  1005.     (Value: cl3DLight; Name: 'cl3DLight'),
  1006.     (Value: clInfoText; Name: 'clInfoText'),
  1007.     (Value: clInfoBk; Name: 'clInfoBk'),
  1008.     (Value: clNone; Name: 'clNone'));
  1009.  
  1010. function ColorToRGB(Color: TColor): Longint;
  1011. begin
  1012.   if Color < 0 then
  1013.     Result := GetSysColor(Color and $000000FF) else
  1014.     Result := Color;
  1015. end;
  1016.  
  1017. function ColorToString(Color: TColor): string;
  1018. begin
  1019.   if not ColorToIdent(Color, Result) then
  1020.     FmtStr(Result, '$%.8x', [Color]);
  1021. end;
  1022.  
  1023. function StringToColor(const S: string): TColor;
  1024. begin
  1025.   if not IdentToColor(S, Longint(Result)) then
  1026.     Result := TColor(StrToInt(S));
  1027. end;
  1028.  
  1029. procedure GetColorValues(Proc: TGetStrProc);
  1030. var
  1031.   I: Integer;
  1032. begin
  1033.   for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
  1034. end;
  1035.  
  1036. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  1037. var
  1038.   I: Integer;
  1039. begin
  1040.   for I := Low(Colors) to High(Colors) do
  1041.     if Colors[I].Value = Color then
  1042.     begin
  1043.       Result := True;
  1044.       Ident := Colors[I].Name;
  1045.       Exit;
  1046.     end;
  1047.   Result := False;
  1048. end;
  1049.  
  1050. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  1051. var
  1052.   I: Integer;
  1053. begin
  1054.   for I := Low(Colors) to High(Colors) do
  1055.     if CompareText(Colors[I].Name, Ident) = 0 then
  1056.     begin
  1057.       Result := True;
  1058.       Color := Colors[I].Value;
  1059.       Exit;
  1060.     end;
  1061.   Result := False;
  1062. end;
  1063.  
  1064. { TGraphicsObject }
  1065.  
  1066. procedure TGraphicsObject.Changed;
  1067. begin
  1068.   if Assigned(FOnChange) then FOnChange(Self);
  1069. end;
  1070.  
  1071. { TFont }
  1072.  
  1073. var
  1074.   DefFontData: TFontData = (
  1075.     Handle: 0;
  1076.     Height: 0;
  1077.     Pitch: fpDefault;
  1078.     Style: [];
  1079.     Name: 'MS Sans Serif');
  1080.  
  1081.  
  1082. constructor TFont.Create;
  1083. begin
  1084.   FResource := FontManager.AllocResource(DefFontData);
  1085.   FColor := clWindowText;
  1086.   FPixelsPerInch := ScreenLogPixels;
  1087. end;
  1088.  
  1089. destructor TFont.Destroy;
  1090. begin
  1091.   FontManager.FreeResource(FResource);
  1092. end;
  1093.  
  1094. procedure TFont.Assign(Source: TPersistent);
  1095. begin
  1096.   if Source is TFont then
  1097.   begin
  1098.     FontManager.AssignResource(Self, TFont(Source).FResource);
  1099.     Color := TFont(Source).Color;
  1100.     if PixelsPerInch <> TFont(Source).PixelsPerInch then
  1101.       Size := TFont(Source).Size;
  1102.     Exit;
  1103.   end;
  1104.   inherited Assign(Source);
  1105. end;
  1106.  
  1107. procedure TFont.GetData(var FontData: TFontData);
  1108. begin
  1109.   FontData := FResource^.Font;
  1110.   FontData.Handle := 0;
  1111. end;
  1112.  
  1113. procedure TFont.SetData(const FontData: TFontData);
  1114. begin
  1115.   FontManager.ChangeResource(Self, FontData);
  1116. end;
  1117.  
  1118. procedure TFont.SetColor(Value: TColor);
  1119. begin
  1120.   if FColor <> Value then
  1121.   begin
  1122.     FColor := Value;
  1123.     Changed;
  1124.   end;
  1125. end;
  1126.  
  1127. function TFont.GetHandle: HFont;
  1128. var
  1129.   LogFont: TLogFont;
  1130. begin
  1131.   with FResource^ do
  1132.   begin
  1133.     if Handle = 0 then
  1134.     begin
  1135.       with LogFont do
  1136.       begin
  1137.         lfHeight := Font.Height;
  1138.         lfWidth := 0; { have font mapper choose }
  1139.         lfEscapement := 0; { only straight fonts }
  1140.         lfOrientation := 0; { no rotation }
  1141.         if fsBold in Font.Style then
  1142.           lfWeight := FW_BOLD
  1143.         else
  1144.           lfWeight := FW_NORMAL;
  1145.         lfItalic := Byte(fsItalic in Font.Style);
  1146.         lfUnderline := Byte(fsUnderline in Font.Style);
  1147.         lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  1148.         lfCharSet := DEFAULT_CHARSET;
  1149.         StrPCopy(lfFaceName, Font.Name);
  1150.         lfQuality := DEFAULT_QUALITY;
  1151.         { Everything else as default }
  1152.         lfOutPrecision := OUT_DEFAULT_PRECIS;
  1153.         lfClipPrecision := CLIP_DEFAULT_PRECIS;
  1154.         case Pitch of
  1155.           fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  1156.           fpFixed: lfPitchAndFamily := FIXED_PITCH;
  1157.         else
  1158.           lfPitchAndFamily := DEFAULT_PITCH;
  1159.         end;
  1160.       end;
  1161.       Handle := CreateFontIndirect(LogFont);
  1162.     end;
  1163.     Result := Handle;
  1164.   end;
  1165. end;
  1166.  
  1167. procedure TFont.SetHandle(Value: HFont);
  1168. var
  1169.   FontData: TFontData;
  1170. begin
  1171.   FontData := DefFontData;
  1172.   FontData.Handle := Value;
  1173.   SetData(FontData);
  1174. end;
  1175.  
  1176. function TFont.GetHeight: Integer;
  1177. begin
  1178.   Result := FResource^.Font.Height;
  1179. end;
  1180.  
  1181. procedure TFont.SetHeight(Value: Integer);
  1182. var
  1183.   FontData: TFontData;
  1184. begin
  1185.   GetData(FontData);
  1186.   FontData.Height := Value;
  1187.   SetData(FontData);
  1188. end;
  1189.  
  1190. function TFont.GetName: TFontName;
  1191. begin
  1192.   Result := FResource^.Font.Name;
  1193. end;
  1194.  
  1195. procedure TFont.SetName(const Value: TFontName);
  1196. var
  1197.   FontData: TFontData;
  1198. begin
  1199.   if Value <> '' then
  1200.   begin
  1201.     GetData(FontData);
  1202.     FillChar(FontData.Name, SizeOf(FontData.Name), 0);
  1203.     FontData.Name := Value;
  1204.     SetData(FontData);
  1205.   end;
  1206. end;
  1207.  
  1208. function TFont.GetSize: Integer;
  1209. begin
  1210.   Result := -MulDiv(Height, 72, FPixelsPerInch);
  1211. end;
  1212.  
  1213. procedure TFont.SetSize(Value: Integer);
  1214. begin
  1215.   Height := -MulDiv(Value, FPixelsPerInch, 72);
  1216. end;
  1217.  
  1218. function TFont.GetStyle: TFontStyles;
  1219. begin
  1220.   Result := FResource^.Font.Style;
  1221. end;
  1222.  
  1223. procedure TFont.SetStyle(Value: TFontStyles);
  1224. var
  1225.   FontData: TFontData;
  1226. begin
  1227.   GetData(FontData);
  1228.   FontData.Style := Value;
  1229.   SetData(FontData);
  1230. end;
  1231.  
  1232. function TFont.GetPitch: TFontPitch;
  1233. begin
  1234.   Result := FResource^.Font.Pitch;
  1235. end;
  1236.  
  1237. procedure TFont.SetPitch(Value: TFontPitch);
  1238. var
  1239.   FontData: TFontData;
  1240. begin
  1241.   GetData(FontData);
  1242.   FontData.Pitch := Value;
  1243.   SetData(FontData);
  1244. end;
  1245.  
  1246.  
  1247. { TPen }
  1248.  
  1249. const
  1250.   DefPenData: TPenData = (
  1251.     Handle: 0;
  1252.     Color: clBlack;
  1253.     Width: 1;
  1254.     Style: psSolid);
  1255.  
  1256. constructor TPen.Create;
  1257. begin
  1258.   FResource := PenManager.AllocResource(DefPenData);
  1259.   FMode := pmCopy;
  1260. end;
  1261.  
  1262. destructor TPen.Destroy;
  1263. begin
  1264.   PenManager.FreeResource(FResource);
  1265. end;
  1266.  
  1267. procedure TPen.Assign(Source: TPersistent);
  1268. begin
  1269.   if Source is TPen then
  1270.   begin
  1271.     PenManager.AssignResource(Self, TPen(Source).FResource);
  1272.     SetMode(TPen(Source).FMode);
  1273.     Exit;
  1274.   end;
  1275.   inherited Assign(Source);
  1276. end;
  1277.  
  1278. procedure TPen.GetData(var PenData: TPenData);
  1279. begin
  1280.   PenData := FResource^.Pen;
  1281.   PenData.Handle := 0;
  1282. end;
  1283.  
  1284. procedure TPen.SetData(const PenData: TPenData);
  1285. begin
  1286.   PenManager.ChangeResource(Self, PenData);
  1287. end;
  1288.  
  1289. function TPen.GetColor: TColor;
  1290. begin
  1291.   Result := FResource^.Pen.Color;
  1292. end;
  1293.  
  1294. procedure TPen.SetColor(Value: TColor);
  1295. var
  1296.   PenData: TPenData;
  1297. begin
  1298.   GetData(PenData);
  1299.   PenData.Color := Value;
  1300.   SetData(PenData);
  1301. end;
  1302.  
  1303. function TPen.GetHandle: HPen;
  1304. const
  1305.   PenStyles: array[TPenStyle] of Word =
  1306.     (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
  1307.      PS_INSIDEFRAME);
  1308. var
  1309.   LogPen: TLogPen;
  1310. begin
  1311.   with FResource^ do
  1312.   begin
  1313.     if Handle = 0 then
  1314.     begin
  1315.       with LogPen do
  1316.       begin
  1317.         lopnStyle := PenStyles[Pen.Style];
  1318.         lopnWidth.X := Pen.Width;
  1319.         lopnColor := ColorToRGB(Pen.Color);
  1320.       end;
  1321.       Handle := CreatePenIndirect(LogPen);
  1322.     end;
  1323.     Result := Handle;
  1324.   end;
  1325. end;
  1326.  
  1327. procedure TPen.SetHandle(Value: HPen);
  1328. var
  1329.   PenData: TPenData;
  1330. begin
  1331.   PenData := DefPenData;
  1332.   PenData.Handle := Value;
  1333.   SetData(PenData);
  1334. end;
  1335.  
  1336. procedure TPen.SetMode(Value: TPenMode);
  1337. begin
  1338.   if FMode <> Value then
  1339.   begin
  1340.     FMode := Value;
  1341.     Changed;
  1342.   end;
  1343. end;
  1344.  
  1345. function TPen.GetStyle: TPenStyle;
  1346. begin
  1347.   Result := FResource^.Pen.Style;
  1348. end;
  1349.  
  1350. procedure TPen.SetStyle(Value: TPenStyle);
  1351. var
  1352.   PenData: TPenData;
  1353. begin
  1354.   GetData(PenData);
  1355.   PenData.Style := Value;
  1356.   SetData(PenData);
  1357. end;
  1358.  
  1359. function TPen.GetWidth: Integer;
  1360. begin
  1361.   Result := FResource^.Pen.Width;
  1362. end;
  1363.  
  1364. procedure TPen.SetWidth(Value: Integer);
  1365. var
  1366.   PenData: TPenData;
  1367. begin
  1368.   if Value >= 0 then
  1369.   begin
  1370.     GetData(PenData);
  1371.     PenData.Width := Value;
  1372.     SetData(PenData);
  1373.   end;
  1374. end;
  1375.  
  1376. { TBrush }
  1377.  
  1378. const
  1379.   DefBrushData: TBrushData = (
  1380.     Handle: 0;
  1381.     Color: clWhite;
  1382.     Bitmap: nil;
  1383.     Style: bsSolid);
  1384.  
  1385. constructor TBrush.Create;
  1386. begin
  1387.   FResource := BrushManager.AllocResource(DefBrushData);
  1388. end;
  1389.  
  1390. destructor TBrush.Destroy;
  1391. begin
  1392.   BrushManager.FreeResource(FResource);
  1393. end;
  1394.  
  1395. procedure TBrush.Assign(Source: TPersistent);
  1396. begin
  1397.   if Source is TBrush then
  1398.   begin
  1399.     BrushManager.AssignResource(Self, TBrush(Source).FResource);
  1400.     Exit;
  1401.   end;
  1402.   inherited Assign(Source);
  1403. end;
  1404.  
  1405. procedure TBrush.GetData(var BrushData: TBrushData);
  1406. begin
  1407.   BrushData := FResource^.Brush;
  1408.   BrushData.Handle := 0;
  1409.   BrushData.Bitmap := nil;
  1410. end;
  1411.  
  1412. procedure TBrush.SetData(const BrushData: TBrushData);
  1413. begin
  1414.   BrushManager.ChangeResource(Self, BrushData);
  1415. end;
  1416.  
  1417. function TBrush.GetBitmap: TBitmap;
  1418. begin
  1419.   Result := FResource^.Brush.Bitmap;
  1420. end;
  1421.  
  1422. procedure TBrush.SetBitmap(Value: TBitmap);
  1423. var
  1424.   BrushData: TBrushData;
  1425. begin
  1426.   BrushData := DefBrushData;
  1427.   BrushData.Bitmap := Value;
  1428.   SetData(BrushData);
  1429. end;
  1430.  
  1431. function TBrush.GetColor: TColor;
  1432. begin
  1433.   Result := FResource^.Brush.Color;
  1434. end;
  1435.  
  1436. procedure TBrush.SetColor(Value: TColor);
  1437. var
  1438.   BrushData: TBrushData;
  1439. begin
  1440.   GetData(BrushData);
  1441.   BrushData.Color := Value;
  1442.   if BrushData.Style = bsClear then BrushData.Style := bsSolid;
  1443.   SetData(BrushData);
  1444. end;
  1445.  
  1446. function TBrush.GetHandle: HBrush;
  1447. var
  1448.   LogBrush: TLogBrush;
  1449. begin
  1450.   with FResource^ do
  1451.   begin
  1452.     if Handle = 0 then
  1453.     begin
  1454.       with LogBrush do
  1455.       begin
  1456.         if Brush.Bitmap <> nil then
  1457.         begin
  1458.           lbStyle := BS_PATTERN;
  1459.           lbHatch := Brush.Bitmap.Handle;
  1460.         end else
  1461.         begin
  1462.           lbHatch := 0;
  1463.           case Brush.Style of
  1464.             bsSolid: lbStyle := BS_SOLID;
  1465.             bsClear: lbStyle := BS_HOLLOW;
  1466.           else
  1467.             lbStyle := BS_HATCHED;
  1468.             lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
  1469.           end;
  1470.         end;
  1471.         lbColor := ColorToRGB(Brush.Color);
  1472.       end;
  1473.       Handle := CreateBrushIndirect(LogBrush);
  1474.     end;
  1475.     Result := Handle;
  1476.   end;
  1477. end;
  1478.  
  1479. procedure TBrush.SetHandle(Value: HBrush);
  1480. var
  1481.   BrushData: TBrushData;
  1482. begin
  1483.   BrushData := DefBrushData;
  1484.   BrushData.Handle := Value;
  1485.   SetData(BrushData);
  1486. end;
  1487.  
  1488. function TBrush.GetStyle: TBrushStyle;
  1489. begin
  1490.   Result := FResource^.Brush.Style;
  1491. end;
  1492.  
  1493. procedure TBrush.SetStyle(Value: TBrushStyle);
  1494. var
  1495.   BrushData: TBrushData;
  1496. begin
  1497.   GetData(BrushData);
  1498.   BrushData.Style := Value;
  1499.   if BrushData.Style = bsClear then BrushData.Color := clWhite;
  1500.   SetData(BrushData);
  1501. end;
  1502.  
  1503. { TCanvas }
  1504.  
  1505. constructor TCanvas.Create;
  1506. begin
  1507.   inherited Create;
  1508.   FFont := TFont.Create;
  1509.   FFont.OnChange := FontChanged;
  1510.   FPen := TPen.Create;
  1511.   FPen.OnChange := PenChanged;
  1512.   FBrush := TBrush.Create;
  1513.   FBrush.OnChange := BrushChanged;
  1514.   FCopyMode := cmSrcCopy;
  1515.   State := [];
  1516.   CanvasList.Add(Self);
  1517. end;
  1518.  
  1519. destructor TCanvas.Destroy;
  1520. begin
  1521.   CanvasList.Remove(Self);
  1522.   SetHandle(0);
  1523.   FFont.Free;
  1524.   FPen.Free;
  1525.   FBrush.Free;
  1526.   inherited Destroy;
  1527. end;
  1528.  
  1529. procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1530. begin
  1531.   Changing;
  1532.   RequiredState([csHandleValid, csPenValid]);
  1533.   Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1534.   Changed;
  1535. end;
  1536.  
  1537. var
  1538.   MonoBmp: TBitmap = nil;
  1539.  
  1540. procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  1541.   const Source: TRect; Color: TColor);
  1542. const
  1543.   ROP_DSPDxax = $00E20746;
  1544. var
  1545.   crBack, crText: TColorRef;
  1546.   W, H: Integer;
  1547. begin
  1548.   if Bitmap = nil then Exit;
  1549.   Changing;
  1550.   W := Source.Right - Source.Left;
  1551.   H := Source.Bottom - Source.Top;
  1552.   RequiredState([csHandleValid]);
  1553.      { Build a mask and paint through it }
  1554.   if not Assigned(MonoBmp) then
  1555.   begin
  1556.     MonoBmp := TBitmap.Create;
  1557.     MonoBmp.Monochrome := True;
  1558.   end;
  1559.   if W > MonoBmp.Width then MonoBmp.Width := W;
  1560.   if H > MonoBmp.Height then MonoBmp.Height := H;
  1561.  
  1562.   MonoBmp.Canvas.RequiredState([csHandleValid]);
  1563.   Bitmap.Canvas.RequiredState([csHandleValid]);
  1564.   crBack := SetBkColor(Bitmap.Canvas.FHandle, ColorToRGB(Color));
  1565.   BitBlt(MonoBmp.Canvas.FHandle, 0, 0, W, H,
  1566.     Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcCopy);
  1567.   SetBkColor(Bitmap.Canvas.FHandle, crBack);
  1568.  
  1569.   RequiredState([csHandleValid, csBrushValid]);
  1570.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1571.     Dest.Bottom - Dest.Top, Bitmap.Canvas.FHandle, Source.Left, Source.Top,
  1572.     W, H, SrcCopy);
  1573.   crText := SetTextColor(FHandle, 0);
  1574.   crBack := SetBkColor(FHandle, $FFFFFF);
  1575.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1576.     Dest.Bottom - Dest.Top, MonoBmp.Canvas.FHandle, 0, 0, W, H, ROP_DSPDxax);
  1577.   SetTextColor(FHandle, crText);
  1578.   SetBkColor(FHandle, crBack);
  1579.   Changed;
  1580. end;
  1581.  
  1582. procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1583. begin
  1584.   Changing;
  1585.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1586.   Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1587.   Changed;
  1588. end;
  1589.  
  1590. procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
  1591.   const Source: TRect);
  1592. begin
  1593.   Changing;
  1594.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  1595.   Canvas.RequiredState([csHandleValid, csBrushValid]);
  1596.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1597.     Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
  1598.     Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
  1599.   Changed;
  1600. end;
  1601.  
  1602. procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
  1603. begin
  1604.   if (Graphic <> nil) and not Graphic.Empty then
  1605.   begin
  1606.     Changing;
  1607.     RequiredState([csHandleValid]);
  1608.     SetBkColor(FHandle, ColorToRGB(FBrush.Color));
  1609.     SetTextColor(FHandle, ColorToRGB(FFont.Color));
  1610.     Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
  1611.     Changed;
  1612.   end;
  1613. end;
  1614.  
  1615. procedure TCanvas.DrawFocusRect(const Rect: TRect);
  1616. begin
  1617.   Changing;
  1618.   RequiredState([csHandleValid, csBrushValid]);
  1619.   Windows.DrawFocusRect(FHandle, Rect);
  1620.   Changed;
  1621. end;
  1622.  
  1623. procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
  1624. begin
  1625.   Changing;
  1626.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1627.   Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
  1628.   Changed;
  1629. end;
  1630.  
  1631. procedure TCanvas.FillRect(const Rect: TRect);
  1632. begin
  1633.   Changing;
  1634.   RequiredState([csHandleValid, csBrushValid]);
  1635.   Windows.FillRect(FHandle, Rect, Brush.GetHandle);
  1636.   Changed;
  1637. end;
  1638.  
  1639. procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  1640.   FillStyle: TFillStyle);
  1641. const
  1642.   FillStyles: array[TFillStyle] of Word =
  1643.     (FLOODFILLSURFACE, FLOODFILLBORDER);
  1644. begin
  1645.   Changing;
  1646.   RequiredState([csHandleValid, csBrushValid]);
  1647.   Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  1648.   Changed;
  1649. end;
  1650.  
  1651. procedure TCanvas.FrameRect(const Rect: TRect);
  1652. begin
  1653.   Changing;
  1654.   RequiredState([csHandleValid, csBrushValid]);
  1655.   Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
  1656.   Changed;
  1657. end;
  1658.  
  1659. procedure TCanvas.LineTo(X, Y: Integer);
  1660. begin
  1661.   Changing;
  1662.   RequiredState([csHandleValid, csPenValid]);
  1663.   Windows.LineTo(FHandle, X, Y);
  1664.   Changed;
  1665. end;
  1666.  
  1667. procedure TCanvas.MoveTo(X, Y: Integer);
  1668. begin
  1669.   RequiredState([csHandleValid]);
  1670.   Windows.MoveToEx(FHandle, X, Y, nil);
  1671. end;
  1672.  
  1673. procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1674. begin
  1675.   Changing;
  1676.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1677.   Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1678.   Changed;
  1679. end;
  1680.  
  1681. type
  1682.   PPoints = ^TPoints;
  1683.   TPoints = array[0..0] of TPoint;
  1684.  
  1685. procedure TCanvas.Polygon(const Points: array of TPoint);
  1686. begin
  1687.   Changing;
  1688.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1689.   Windows.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
  1690.   Changed;
  1691. end;
  1692.  
  1693. procedure TCanvas.Polyline(const Points: array of TPoint);
  1694. begin
  1695.   Changing;
  1696.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1697.   Windows.Polyline(FHandle, PPoints(@Points)^, High(Points) + 1);
  1698.   Changed;
  1699. end;
  1700.  
  1701. procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
  1702. begin
  1703.   Changing;
  1704.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  1705.   Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
  1706.   Changed;
  1707. end;
  1708.  
  1709. procedure TCanvas.Refresh;
  1710. begin
  1711.   DeselectHandles;
  1712. end;
  1713.  
  1714. procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  1715. begin
  1716.   Changing;
  1717.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  1718.   Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
  1719.   Changed;
  1720. end;
  1721.  
  1722. procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
  1723. begin
  1724.   if Graphic <> nil then
  1725.   begin
  1726.     Changing;
  1727.     RequiredState(csAllValid);
  1728.     Graphic.Draw(Self, Rect);
  1729.     Changed;
  1730.   end;
  1731. end;
  1732.  
  1733. procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
  1734. begin
  1735.   Changing;
  1736.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  1737.   Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));
  1738.   MoveTo(X + TextWidth(Text), Y);
  1739.   Changed;
  1740. end;
  1741.  
  1742. procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  1743. var
  1744.   Options: Integer;
  1745. begin
  1746.   Changing;
  1747.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  1748.   Options := ETO_CLIPPED;
  1749.   if Brush.Style <> bsClear then Inc(Options, ETO_OPAQUE);
  1750.   Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text),
  1751.     Length(Text), nil);
  1752.   Changed;
  1753. end;
  1754.  
  1755. function TCanvas.TextWidth(const Text: String): Integer;
  1756. var
  1757.   Extent: TSize;
  1758. begin
  1759.   RequiredState([csHandleValid, csFontValid]);
  1760.   if Windows.GetTextExtentPoint(FHandle, PChar(Text), Length(Text), Extent) then
  1761.     TextWidth := Extent.cX else
  1762.     TextWidth := 0;
  1763. end;
  1764.  
  1765. function TCanvas.TextHeight(const Text: String): Integer;
  1766. var
  1767.   Extent: TSize;
  1768. begin
  1769.   RequiredState([csHandleValid, csFontValid]);
  1770.   if Windows.GetTextExtentPoint(FHandle, PChar(Text), Length(Text), Extent) then
  1771.     TextHeight := Extent.cY else
  1772.     TextHeight := 0;
  1773. end;
  1774.  
  1775. procedure TCanvas.SetFont(Value: TFont);
  1776. begin
  1777.   FFont.Assign(Value);
  1778. end;
  1779.  
  1780. procedure TCanvas.SetPen(Value: TPen);
  1781. begin
  1782.   FPen.Assign(Value);
  1783. end;
  1784.  
  1785. procedure TCanvas.SetBrush(Value: TBrush);
  1786. begin
  1787.   FBrush.Assign(Value);
  1788. end;
  1789.  
  1790. function TCanvas.GetPenPos: TPoint;
  1791. begin
  1792.   RequiredState([csHandleValid]);
  1793.   Windows.GetCurrentPositionEx(FHandle, @Result);
  1794. end;
  1795.  
  1796. procedure TCanvas.SetPenPos(Value: TPoint);
  1797. begin
  1798.   MoveTo(Value.X, Value.Y);
  1799. end;
  1800.  
  1801. function TCanvas.GetPixel(X, Y: Integer): TColor;
  1802. begin
  1803.   RequiredState([csHandleValid]);
  1804.   GetPixel := Windows.GetPixel(FHandle, X, Y);
  1805. end;
  1806.  
  1807. procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
  1808. begin
  1809.   Changing;
  1810.   RequiredState([csHandleValid, csPenValid]);
  1811.   Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
  1812.   Changed;
  1813. end;
  1814.  
  1815. function TCanvas.GetClipRect: TRect;
  1816. begin
  1817.   RequiredState([csHandleValid]);
  1818.   GetClipBox(FHandle, Result);
  1819. end;
  1820.  
  1821. function TCanvas.GetHandle: HDC;
  1822. begin
  1823.   Changing;
  1824.   RequiredState(csAllValid);
  1825.   Result := FHandle;
  1826. end;
  1827.  
  1828. procedure TCanvas.DeselectHandles;
  1829. begin
  1830.   if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
  1831.   begin
  1832.     SelectObject(FHandle, StockPen);
  1833.     SelectObject(FHandle, StockBrush);
  1834.     SelectObject(FHandle, StockFont);
  1835.     State := State - [csPenValid, csBrushValid, csFontValid];
  1836.   end;
  1837. end;
  1838.  
  1839. procedure TCanvas.CreateHandle;
  1840. begin
  1841. end;
  1842.  
  1843. procedure TCanvas.SetHandle(Value: HDC);
  1844. begin
  1845.   if FHandle <> Value then
  1846.   begin
  1847.     if FHandle <> 0 then
  1848.     begin
  1849.       DeselectHandles;
  1850.       FPenPos := GetPenPos;
  1851.       FHandle := 0;
  1852.       Exclude(State, csHandleValid);
  1853.     end;
  1854.     if Value <> 0 then
  1855.     begin
  1856.       Include(State, csHandleValid);
  1857.       FHandle := Value;
  1858.       SetPenPos(FPenPos);
  1859.     end;
  1860.   end;
  1861. end;
  1862.  
  1863. procedure TCanvas.RequiredState(ReqState: TCanvasState);
  1864. var
  1865.   NeededState: TCanvasState;
  1866. begin
  1867.   NeededState := ReqState - State;
  1868.   if NeededState <> [] then
  1869.   begin
  1870.     if csHandleValid in NeededState then
  1871.     begin
  1872.       CreateHandle;
  1873.       if FHandle = 0 then
  1874.         raise EInvalidOperation.CreateRes(SNoCanvasHandle);
  1875.     end;
  1876.     if csFontValid in NeededState then CreateFont;
  1877.     if csPenValid in NeededState then
  1878.     begin
  1879.       CreatePen;
  1880.       if Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
  1881.         Include(NeededState, csBrushValid);
  1882.     end;
  1883.     if csBrushValid in NeededState then CreateBrush;
  1884.     State := State + NeededState;
  1885.   end;
  1886. end;
  1887.  
  1888. procedure TCanvas.Changing;
  1889. begin
  1890.   if Assigned(FOnChanging) then FOnChanging(Self);
  1891. end;
  1892.  
  1893. procedure TCanvas.Changed;
  1894. begin
  1895.   if Assigned(FOnChange) then FOnChange(Self);
  1896. end;
  1897.  
  1898. procedure TCanvas.CreateFont;
  1899. begin
  1900.   SelectObject(FHandle, Font.GetHandle);
  1901.   SetTextColor(FHandle, ColorToRGB(Font.Color));
  1902. end;
  1903.  
  1904. procedure TCanvas.CreatePen;
  1905. const
  1906.   PenModes: array[TPenMode] of Word =
  1907.     (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
  1908.      R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
  1909.      R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);
  1910. begin
  1911.   SelectObject(FHandle, Pen.GetHandle);
  1912.   SetROP2(FHandle, PenModes[Pen.Mode]);
  1913. end;
  1914.  
  1915. procedure TCanvas.CreateBrush;
  1916. begin
  1917.   UnrealizeObject(Brush.Handle);
  1918.   SelectObject(FHandle, Brush.Handle);
  1919.   if Brush.Style = bsSolid then
  1920.   begin
  1921.     SetBkColor(FHandle, ColorToRGB(Brush.Color));
  1922.     SetBkMode(FHandle, OPAQUE);
  1923.   end
  1924.   else
  1925.   begin
  1926.     { Win95 doesn't draw brush hatches if bkcolor = brush color }
  1927.     { Since bkmode is transparent, nothing should use bkcolor anyway }
  1928.     SetBkColor(FHandle, not ColorToRGB(Brush.Color));
  1929.     SetBkMode(FHandle, TRANSPARENT);
  1930.   end;
  1931. end;
  1932.  
  1933. procedure TCanvas.FontChanged(AFont: TObject);
  1934. begin
  1935.   if csFontValid in State then
  1936.   begin
  1937.     Exclude(State, csFontValid);
  1938.     SelectObject(FHandle, StockFont);
  1939.   end;
  1940. end;
  1941.  
  1942. procedure TCanvas.PenChanged(APen: TObject);
  1943. begin
  1944.   if csPenValid in State then
  1945.   begin
  1946.     Exclude(State, csPenValid);
  1947.     SelectObject(FHandle, StockPen);
  1948.   end;
  1949. end;
  1950.  
  1951. procedure TCanvas.BrushChanged(ABrush: TObject);
  1952. begin
  1953.   if csBrushValid in State then
  1954.   begin
  1955.     Exclude(State, csBrushValid);
  1956.     SelectObject(FHandle, StockBrush);
  1957.   end;
  1958. end;
  1959.  
  1960. { Picture support }
  1961.  
  1962. { Icon and cursor types }
  1963.  
  1964. const
  1965.   rc3_StockIcon = 0;
  1966.   rc3_Icon = 1;
  1967.   rc3_Cursor = 2;
  1968.  
  1969. type
  1970.   PCursorOrIcon = ^TCursorOrIcon;
  1971.   TCursorOrIcon = packed record
  1972.     Reserved: Word;
  1973.     wType: Word;
  1974.     Count: Word;
  1975.   end;
  1976.  
  1977.   PIconRec = ^TIconRec;
  1978.   TIconRec = packed record
  1979.     Width: Byte;
  1980.     Height: Byte;
  1981.     Colors: Word;
  1982.     Reserved1: Word;
  1983.     Reserved2: Word;
  1984.     DIBSize: Longint;
  1985.     DIBOffset: Longint;
  1986.   end;
  1987.  
  1988.  
  1989. { Metafile types }
  1990.  
  1991. const
  1992.   WMFKey = $9AC6CDD7;
  1993.   WMFWord = $CDD7;
  1994.  
  1995. type
  1996.   PMetafileHeader = ^TMetafileHeader;
  1997.   TMetafileHeader = packed record
  1998.     Key: Longint;
  1999.     Handle: SmallInt;
  2000.     Box: TSmallRect;
  2001.     Inch: Word;
  2002.     Reserved: Longint;
  2003.     CheckSum: Word;
  2004.   end;
  2005.  
  2006. { Exception routines }
  2007.  
  2008. procedure InvalidOperation(Str: Integer); near;
  2009. begin
  2010.   raise EInvalidGraphicOperation.CreateRes(Str);
  2011. end;
  2012.  
  2013. procedure InvalidGraphic(Str: Integer); near;
  2014. begin
  2015.   raise EInvalidGraphic.CreateRes(Str);
  2016. end;
  2017.  
  2018. procedure InvalidBitmap; near;
  2019. begin
  2020.   InvalidGraphic(SInvalidBitmap);
  2021. end;
  2022.  
  2023. procedure InvalidIcon; near;
  2024. begin
  2025.   InvalidGraphic(SInvalidIcon);
  2026. end;
  2027.  
  2028. procedure InvalidMetafile; near;
  2029. begin
  2030.   InvalidGraphic(SInvalidMetafile);
  2031. end;
  2032.  
  2033. procedure OutOfResources; near;
  2034. begin
  2035.   raise EOutOfResources.CreateRes(SOutOfResources);
  2036. end;
  2037.  
  2038. function MemAlloc(Size: Longint): Pointer;
  2039. begin
  2040.   GetMem(Result, Size);
  2041. end;
  2042.  
  2043. function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
  2044. var
  2045.   DC, Mem1, Mem2: HDC;
  2046.   Old1, Old2: HBITMAP;
  2047.   Bitmap: Windows.TBitmap;
  2048. begin
  2049.   Mem1 := CreateCompatibleDC(0);
  2050.   Mem2 := CreateCompatibleDC(0);
  2051.  
  2052.   GetObject(Src, SizeOf(Bitmap), @Bitmap);
  2053.   if Mono then
  2054.     Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
  2055.   else
  2056.   begin
  2057.     DC := GetDC(0);
  2058.     if DC = 0 then OutOfResources;
  2059.     try
  2060.       Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
  2061.       if Result = 0 then OutOfResources;
  2062.     finally
  2063.       ReleaseDC(0, DC);
  2064.     end;
  2065.   end;
  2066.  
  2067.   if Result <> 0 then
  2068.   begin
  2069.     Old1 := SelectObject(Mem1, Src);
  2070.     Old2 := SelectObject(Mem2, Result);
  2071.  
  2072.     StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
  2073.       Bitmap.bmHeight, SrcCopy);
  2074.     if Old1 <> 0 then SelectObject(Mem1, Old1);
  2075.     if Old2 <> 0 then SelectObject(Mem2, Old2);
  2076.   end;
  2077.   DeleteDC(Mem1);
  2078.   DeleteDC(Mem2);
  2079. end;
  2080.  
  2081. function GetDInColors(BitCount: Word): Integer;
  2082. begin
  2083.   case BitCount of
  2084.     1, 4, 8: Result := 1 shl BitCount;
  2085.   else
  2086.     Result := 0;
  2087.   end;
  2088. end;
  2089.  
  2090. function PaletteFromW3DIB(const BI: TBitmapInfo): HPALETTE;
  2091. var
  2092.   DstPal: PLogPalette;
  2093.   Colors, n: Integer;
  2094.   Size: Longint;
  2095.   DC: HDC;
  2096.   Focus: HWND;
  2097.   SysPalSize: Integer;
  2098.   I: Integer;
  2099. begin
  2100.   Result := 0;
  2101.  
  2102.   { If the ClrUsed field of the header is non-zero, it means that we could
  2103.     have a short color table }
  2104.   with BI.bmiHeader do
  2105.     if biClrUsed <> 0 then
  2106.       Colors := biClrUsed
  2107.     else
  2108.       Colors := GetDInColors(biBitCount);
  2109.  
  2110.   if Colors <= 2 then Exit;
  2111.  
  2112.   Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
  2113.   DstPal := AllocMem(Size);
  2114.   try
  2115.     FillChar(DstPal^, Size, 0);
  2116.     with DstPal^ do
  2117.     begin
  2118.       palNumEntries := Colors;
  2119.       palVersion := $300;
  2120.       Focus := GetFocus;
  2121.       DC := GetDC(Focus);
  2122.       try
  2123.         SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2124.         if (Colors = 16) and (SysPalSize >= 16) then
  2125.         begin
  2126.           { Ignore the disk image of the palette for 16 color bitmaps use
  2127.             instead the first 8 and last 8 of the current system palette }
  2128.           GetSystemPaletteEntries(DC, 0, 8, palPalEntry);
  2129.           I := 8;
  2130.           GetSystemPaletteEntries(DC, SysPalSize - I, I, palPalEntry[I]);
  2131.         end
  2132.         else
  2133.           { Copy the palette for all others (i.e. 256 colors) }
  2134.           for N := 0 to Colors - 1 do
  2135.           begin
  2136.             palPalEntry[N].peRed := BI.bmiColors[N].rgbRed;
  2137.             palPalEntry[N].peGreen := BI.bmiColors[N].rgbGreen;
  2138.             palPalEntry[N].peBlue := BI.bmiColors[N].rgbBlue;
  2139.             palPalEntry[N].peFlags := 0;
  2140.           end;
  2141.       finally
  2142.         ReleaseDC(Focus, DC);
  2143.       end;
  2144.     end;
  2145.     Result := CreatePalette(DstPal^);
  2146.   finally
  2147.     FreeMem(DstPal, Size);
  2148.   end;
  2149. end;
  2150.  
  2151. procedure ReadWin3DIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  2152.   HeaderSize: Longint; ImageSize: Longint);
  2153. var
  2154.   Size: Word;
  2155.   Focus: HWND;
  2156.   DC: HDC;
  2157.   BitsMem: Pointer;
  2158.   BitmapHeader: TBitmapInfoHeader;
  2159.   BitmapInfo: PBitmapInfo;
  2160.   OldPal: HPALETTE;
  2161. begin
  2162.   Stream.Read(Pointer(Longint(@BitmapHeader) + SizeOf(Longint))^,
  2163.     SizeOf(TBitmapInfoHeader) - SizeOf(Longint));
  2164.   BitmapHeader.biSize := HeaderSize;
  2165.  
  2166.   { check number of planes. Windows 3.x supports only 1 plane DIBS }
  2167.   if BitmapHeader.biPlanes <> 1 then InvalidBitmap;
  2168.  
  2169.   with BitmapHeader do
  2170.   begin
  2171.     if biClrUsed = 0 then
  2172.       biClrUsed := GetDInColors(biBitCount);
  2173.     Size := biClrUsed * SizeOf(TRgbQuad);
  2174.   end;
  2175.  
  2176.   BitmapInfo := AllocMem(Size + SizeOf(TBitmapInfoHeader));
  2177.   try
  2178.     with BitmapInfo^ do
  2179.     begin
  2180.       bmiHeader := BitmapHeader;
  2181.       Stream.Read(bmiColors, Size);
  2182.  
  2183.       { now we've got the color table. Create a pallete from it }
  2184.       Pal := PaletteFromW3DIB(BitmapInfo^);
  2185.  
  2186.       { some applications do not fill in the SizeImage field in the header.
  2187.         (Actually the truth is more likely that some drivers do not fill the field
  2188.         in and the apps do not compensate for these buggy drivers.) Therefore, if
  2189.         this field is 0, we will compute the size. }
  2190.       with bmiHeader do
  2191.       begin
  2192.         Dec(ImageSize, SizeOf(TBitmapInfoHeader) + Size);
  2193.         if biSizeImage <> 0 then
  2194.           if biSizeImage < ImageSize then ImageSize := biSizeImage;
  2195.         BitsMem := AllocMem(ImageSize);
  2196.         try
  2197.           Stream.Read(BitsMem^, ImageSize);
  2198.  
  2199.           { we use the handle of the window with the focus (which, if this routine
  2200.             is called from a menu command, will be this window) in order to guarantee
  2201.             that the realized palette will have first priority on the system palette }
  2202.           Focus := GetFocus;
  2203.           DC := GetDC(Focus);
  2204.           if DC = 0 then OutOfResources;
  2205.           try
  2206.             if Pal <> 0 then
  2207.             begin
  2208.               { select and realize our palette we have gotten the DC of the focus
  2209.                 window just to make sure that all our colors are mapped }
  2210.               OldPal := SelectPalette(DC, Pal, False);
  2211.               RealizePalette(DC);
  2212.             end
  2213.             else
  2214.               OldPal := 0;
  2215.  
  2216.             try
  2217.               Bits := CreateDIBitmap(DC, BitmapInfo^.bmiHeader,  CBM_INIT, BitsMem,
  2218.                 BitmapInfo^, DIB_RGB_COLORS);
  2219.               if Bits = 0 then OutOfResources;
  2220.             finally
  2221.               if OldPal <> 0 then
  2222.                 SelectPalette(DC, OldPal, False);
  2223.             end;
  2224.           finally
  2225.             ReleaseDC(Focus, DC);
  2226.           end;
  2227.         finally
  2228.           FreeMem(BitsMem, ImageSize);
  2229.         end;
  2230.       end;
  2231.     end;
  2232.   finally
  2233.     FreeMem(BitmapInfo, Size + SizeOf(TBitmapInfoHeader));
  2234.   end;
  2235. end;
  2236.  
  2237. { This routine accepts a pointer to a BITMAPCORE structure and creates a GDI
  2238.   logical palette from the color table which follows it, for 2, 16 and 256
  2239.   color bitmaps. It returns 0 for all others, including 24-bit DIB's
  2240.  
  2241.   It differs from the windows DIB routine in two respects:
  2242.   1) The PM 1.x DIB must have complete color tables, since there is no ClrUsed
  2243.      field in the header
  2244.   2) The size of the color table entries is 3 bytes, not 4 bytes. }
  2245.  
  2246. function PaletteFromPM1DIB(const BC: TBitmapCoreInfo): HPALETTE;
  2247. var
  2248.   DstPal: PLogPalette;
  2249.   Colors, N: Integer;
  2250.   Size: Longint;
  2251. begin
  2252.   Result := 0;
  2253.   Colors := GetDInColors(BC.bmciHeader.bcBitCount);
  2254.   if Colors = 0 then Exit;
  2255.  
  2256.   Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
  2257.   DstPal := AllocMem(Size);
  2258.   FillChar(DstPal^, Size, 0);
  2259.   try
  2260.     with DstPal^ do
  2261.     begin
  2262.       palNumEntries := Colors;
  2263.       palVersion := $300;
  2264.       for N := 0 to Colors - 1 do
  2265.       begin
  2266.         palPalEntry[N].peRed := BC.bmciColors[N].rgbtRed;
  2267.         palPalEntry[N].peGreen := BC.bmciColors[N].rgbtGreen;
  2268.         palPalEntry[N].peBlue := BC.bmciColors[N].rgbtBlue;
  2269.         palPalEntry[N].peFlags := 0;
  2270.       end;
  2271.     end;
  2272.     Result := CreatePalette(DstPal^);
  2273.   finally
  2274.     FreeMem(DstPal, Size);
  2275.   end;
  2276. end;
  2277.  
  2278. { Read a PM 1.x device independent bitmap. }
  2279.  
  2280. procedure ReadPM1DIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  2281.   HeaderSize: Longint; ImageSize: Longint);
  2282. var
  2283.   Size: Word;
  2284.   Focus: HWND;
  2285.   DC: HDC;
  2286.   BitsMem: Pointer;
  2287.   BitmapHeader: TBitmapCoreHeader;
  2288.   BitmapInfo: PBitmapCoreInfo;
  2289.   OldPal: HPALETTE;
  2290.   MaxSize: Longint;
  2291. begin
  2292.   Stream.Read(Pointer(Longint(@BitmapHeader) + SizeOf(HeaderSize))^,
  2293.     SizeOf(BitmapHeader) - SizeOf(Longint));
  2294.   BitmapHeader.bcSize := HeaderSize;
  2295.   if BitmapHeader.bcPlanes <> 1 then InvalidBitmap;
  2296.  
  2297.   Size := GetDInColors(BitmapHeader.bcBitCount) * SizeOf(TRGBTriple);
  2298.   BitmapInfo := AllocMem(Size + SizeOf(TBitmapCoreInfo));
  2299.   try
  2300.     with BitmapInfo^ do
  2301.     begin
  2302.       bmciHeader := BitmapHeader;
  2303.       Stream.Read(bmciColors, Size);
  2304.  
  2305.       Pal := PaletteFromPM1DIB(BitmapInfo^);
  2306.  
  2307.       { size of image = Width of a scan line * number of scan lines Width = Pixel
  2308.         Width * bits per pixel rounded to a DWORD boundary }
  2309.       with bmciHeader do
  2310.         MaxSize := ((((bcWidth * bcBitCount) + 31) div 32) * 4) * bcHeight;
  2311.  
  2312.       BitsMem := AllocMem(MaxSize);
  2313.       try
  2314.         Stream.Read(BitsMem^, MaxSize);
  2315.  
  2316.         Focus := GetFocus;
  2317.         DC := GetDC(Focus);
  2318.         if DC = 0 then OutOfResources;
  2319.         try
  2320.           OldPal := 0;
  2321.           if Pal <> 0 then
  2322.           begin
  2323.             OldPal := SelectPalette(DC, Pal, False);
  2324.             RealizePalette(DC);
  2325.           end;
  2326.           try
  2327.             Bits := CreateDIBitmap(DC, PBitmapInfoHeader(@bmciHeader)^, CBM_INIT,
  2328.               BitsMem, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS);
  2329.             if Bits = 0 then OutOfResources;
  2330.           finally
  2331.             if OldPal <> 0 then
  2332.               SelectPalette(DC, OldPal, False);
  2333.           end;
  2334.         finally
  2335.           ReleaseDC(Focus, DC);
  2336.         end;
  2337.       finally
  2338.         FreeMem(BitsMem, MaxSize);
  2339.       end;
  2340.     end;
  2341.   finally
  2342.     FreeMem(BitmapInfo, Size + SizeOf(TBitmapCoreInfo));
  2343.   end;
  2344. end;
  2345.  
  2346. procedure ReadDIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  2347.   Size: Longint);
  2348. var
  2349.   HeaderSize: Longint;
  2350. begin
  2351.   Stream.Read(HeaderSize, SizeOf(HeaderSize));
  2352.   if HeaderSize = SizeOf(TBitmapInfoHeader) then
  2353.     ReadWin3DIB(Stream, Bits, Pal, HeaderSize, Size)
  2354.   else if HeaderSize = SizeOf(TBitmapCoreHeader) then
  2355.     ReadPM1DIB(Stream, Bits, Pal, HeaderSize, Size)
  2356.   else
  2357.     InvalidBitmap;
  2358. end;
  2359.  
  2360. function WidthBytes(I: Longint): Longint;
  2361. begin
  2362.   Result := ((I + 31) div 32) * 4;
  2363. end;
  2364.  
  2365. function MonoWidthBytes(I: Longint): Longint;
  2366. begin
  2367.   Result := ((I + 15) div 16) * 2;
  2368. end;
  2369.  
  2370. procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);
  2371. type
  2372.   PLongArray = ^TLongArray;
  2373.   TLongArray = array[0..1] of Longint;
  2374. var
  2375.   Temp: HBITMAP;
  2376.   NumColors: Integer;
  2377.   DC: HDC;
  2378.   Bits: Pointer;
  2379.   Colors: PLongArray;
  2380.   IconSize: TPoint;
  2381. begin
  2382.   IconSize.X := GetSystemMetrics(SM_CXICON);
  2383.   IconSize.Y := GetSystemMetrics(SM_CYICON);
  2384.   with BI do
  2385.   begin
  2386.     biHeight := biHeight shr 1; { Size in record is doubled }
  2387.     biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
  2388.     NumColors := GetDInColors(biBitCount);
  2389.   end;
  2390.   DC := GetDC(0);
  2391.   if DC = 0 then OutOfResources;
  2392.   try
  2393.     Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
  2394.     Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
  2395.     if Temp = 0 then OutOfResources;
  2396.     try
  2397.       XorBits := DupBits(Temp, IconSize, False);
  2398.     finally
  2399.       DeleteObject(Temp);
  2400.     end;
  2401.     with BI do
  2402.     begin
  2403.       Inc(Longint(Bits), biSizeImage);
  2404.       biBitCount := 1;
  2405.       biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
  2406.       biClrUsed := 2;
  2407.       biClrImportant := 2;
  2408.     end;
  2409.     Colors := Pointer(Longint(@BI) + SizeOf(BI));
  2410.     Colors^[0] := 0;
  2411.     Colors^[1] := $FFFFFF;
  2412.     Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
  2413.     if Temp = 0 then OutOfResources;
  2414.     try
  2415.       AndBits := DupBits(Temp, IconSize, True);
  2416.     finally
  2417.       DeleteObject(Temp);
  2418.     end;
  2419.   finally
  2420.     ReleaseDC(0, DC);
  2421.   end;
  2422. end;
  2423.  
  2424. procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  2425.   StartOffset: Integer);
  2426. type
  2427.   PIconRecArray = ^TIconRecArray;
  2428.   TIconRecArray = array[0..300] of TIconRec;
  2429. var
  2430.   List: PIconRecArray;
  2431.   HeaderLen, Length: Integer;
  2432.   Colors, BitsPerPixel: Word;
  2433.   C1, C2, N, Index: Integer;
  2434.   IconSize: TPoint;
  2435.   DC: HDC;
  2436.   BI: PBitmapInfoHeader;
  2437.   ResData: Pointer;
  2438.   XorBits, AndBits: HBITMAP;
  2439.   XorInfo, AndInfo: Windows.TBitmap;
  2440.   XorMem, AndMem: Pointer;
  2441.   XorLen, AndLen: Integer;
  2442. begin
  2443.   HeaderLen := SizeOf(TIconRec) * ImageCount;
  2444.   List := AllocMem(HeaderLen);
  2445.   try
  2446.     Stream.Read(List^, HeaderLen);
  2447.     IconSize.X := GetSystemMetrics(SM_CXICON);
  2448.     IconSize.Y := GetSystemMetrics(SM_CYICON);
  2449.     DC := GetDC(0);
  2450.     if DC = 0 then OutOfResources;
  2451.     try
  2452.       BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  2453.       if BitsPerPixel = 24 then
  2454.         Colors := 0
  2455.       else
  2456.         Colors := 1 shl BitsPerPixel;
  2457.     finally
  2458.       ReleaseDC(0, DC);
  2459.     end;
  2460.     Index := -1;
  2461.  
  2462.     { the following code determines which image most closely matches the
  2463.       current device. It is not meant to absolutely match Windows
  2464.       (known broken) algorithm }
  2465.     C2 := 0;
  2466.     for N := 0 to ImageCount - 1 do
  2467.     begin
  2468.       C1 := List^[N].Colors;
  2469.       if C1 = Colors then
  2470.       begin
  2471.         Index := N;
  2472.         Break;
  2473.       end
  2474.       else if Index = -1 then
  2475.       begin
  2476.         if C1 <= Colors then
  2477.         begin
  2478.           Index := N;
  2479.           C2 := List^[N].Colors;
  2480.         end;
  2481.       end
  2482.       else
  2483.         if C1 > C2 then
  2484.           Index := N;
  2485.     end;
  2486.     if Index = -1 then Index := 0;
  2487.     with List^[Index] do
  2488.     begin
  2489.       BI := AllocMem(DIBSize);
  2490.       try
  2491.         Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
  2492.         Stream.Read(BI^, DIBSize);
  2493.         TwoBitsFromDIB(BI^, XorBits, AndBits);
  2494.         GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
  2495.         GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
  2496.         with AndInfo do
  2497.           AndLen := bmWidthBytes * bmHeight * bmPlanes;
  2498.         with XorInfo do
  2499.           XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
  2500.         Length := AndLen + XorLen;
  2501.         ResData := AllocMem(Length);
  2502.         try
  2503.           AndMem := ResData;
  2504.           with AndInfo do
  2505.             XorMem := Pointer(Longint(ResData) + AndLen);
  2506.           GetBitmapBits(AndBits, AndLen, AndMem);
  2507.           GetBitmapBits(XorBits, XorLen, XorMem);
  2508.           DeleteObject(XorBits);
  2509.           DeleteObject(AndBits);
  2510.           Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
  2511.             XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
  2512.           if Icon = 0 then OutOfResources;
  2513.         finally
  2514.           FreeMem(ResData, Length);
  2515.         end;
  2516.       finally
  2517.         FreeMem(BI, DIBSize);
  2518.       end;
  2519.     end;
  2520.   finally
  2521.     FreeMem(List, HeaderLen);
  2522.   end;
  2523. end;
  2524.  
  2525. function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
  2526. type
  2527.   PWord = ^Word;
  2528. var
  2529.   pW: PWord;
  2530.   pEnd: PWord;
  2531. begin
  2532.   Result := 0;
  2533.   pW := @WMF;
  2534.   pEnd := @WMF.CheckSum;
  2535.   while Longint(pW) < Longint(pEnd) do
  2536.   begin
  2537.     Result := Result xor pW^;
  2538.     Inc(Longint(pW), SizeOf(Word));
  2539.   end;
  2540. end;
  2541.  
  2542. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  2543.   Colors: Integer);
  2544. var
  2545.   BM: Windows.TBitmap;
  2546. begin
  2547.   GetObject(Bitmap, SizeOf(BM), @BM);
  2548.   with BI do
  2549.   begin
  2550.     biSize := SizeOf(BI);
  2551.     biWidth := BM.bmWidth;
  2552.     biHeight := BM.bmHeight;
  2553.     if Colors <> 0 then
  2554.       case Colors of
  2555.         2: biBitCount := 1;
  2556.         16: biBitCount := 4;
  2557.         256: biBitCount := 8;
  2558.       end
  2559.     else biBitCount := BM.bmBitsPixel * BM.bmPlanes;
  2560.     biPlanes := 1;
  2561.     biXPelsPerMeter := 0;
  2562.     biYPelsPerMeter := 0;
  2563.     biClrUsed := 0;
  2564.     biClrImportant := 0;
  2565.     biCompression := BI_RGB;
  2566.     if biBitCount in [16, 32] then biBitCount := 24;
  2567.     biSizeImage := WidthBytes(biWidth * biBitCount) * biHeight;
  2568.   end;
  2569. end;
  2570.  
  2571. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2572.   var ImageSize: DWORD; Colors: Integer);
  2573. var
  2574.   BI: TBitmapInfoHeader;
  2575. begin
  2576.   InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  2577.   with BI do
  2578.   begin
  2579.     case biBitCount of
  2580.       24: InfoHeaderSize := SizeOf(TBitmapInfoHeader);
  2581.     else
  2582.       InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
  2583.        (1 shl biBitCount);
  2584.     end;
  2585.   end;
  2586.   ImageSize := BI.biSizeImage;
  2587. end;
  2588.  
  2589. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2590.   var ImageSize: DWORD);
  2591. begin
  2592.   InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
  2593. end;
  2594.  
  2595. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  2596.   var BitmapInfo; var Bits; Colors: Integer): Boolean;
  2597. var
  2598.   OldPal: HPALETTE;
  2599.   Focus: HWND;
  2600.   DC: HDC;
  2601. begin
  2602.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  2603.   OldPal := 0;
  2604.   Focus := GetFocus;
  2605.   DC := GetDC(Focus);
  2606.   try
  2607.     if Palette <> 0 then
  2608.     begin
  2609.       OldPal := SelectPalette(DC, Palette, False);
  2610.       RealizePalette(DC);
  2611.     end;
  2612.     Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
  2613.       TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  2614.   finally
  2615.     if OldPal <> 0 then SelectPalette(DC, OldPal, False);
  2616.     ReleaseDC(Focus, DC);
  2617.   end;
  2618. end;
  2619.  
  2620. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  2621. begin
  2622.   Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
  2623. end;
  2624.  
  2625. procedure DIBFromBit(Stream: TMemoryStream; Src: HBITMAP;
  2626.   Pal: HPALETTE; Colors: Integer; var DIBHeader, DIBBits: Pointer);
  2627. var
  2628.   HeaderSize: Integer;
  2629.   ImageSize: DWORD;
  2630. begin
  2631.   if Src = 0 then InvalidBitmap;
  2632.   InternalGetDIBSizes(Src, HeaderSize, ImageSize, Colors);
  2633.   Stream.SetSize(HeaderSize + ImageSize);
  2634.   DIBHeader := Stream.Memory;
  2635.   DIBBits := Pointer(Longint(DIBHeader) + HeaderSize);
  2636.   InternalGetDIB(Src, Pal, DIBHeader^, DIBBits^, Colors);
  2637. end;
  2638.  
  2639. procedure WinError;
  2640. begin
  2641. end;
  2642.  
  2643. procedure CheckBool(Result: Bool);
  2644. begin
  2645.   if not Result then WinError;
  2646. end;
  2647.  
  2648. procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
  2649. var
  2650.   IconInfo: TIconInfo;
  2651.   MonoInfoSize, ColorInfoSize: Integer;
  2652.   MonoBitsSize, ColorBitsSize: DWORD;
  2653.   MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  2654.   CI: TCursorOrIcon;
  2655.   List: TIconRec;
  2656.   Length: Longint;
  2657. begin
  2658.   FillChar(CI, SizeOf(CI), 0);
  2659.   FillChar(List, SizeOf(List), 0);
  2660.   CheckBool(GetIconInfo(Icon, IconInfo));
  2661.   try
  2662.     InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
  2663.     InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
  2664.     MonoInfo := nil;
  2665.     MonoBits := nil;
  2666.     ColorInfo := nil;
  2667.     ColorBits := nil;
  2668.     try
  2669.       MonoInfo := AllocMem(MonoInfoSize);
  2670.       MonoBits := AllocMem(MonoBitsSize);
  2671.       ColorInfo := AllocMem(ColorInfoSize);
  2672.       ColorBits := AllocMem(ColorBitsSize);
  2673.       InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
  2674.       InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
  2675.       if WriteLength then
  2676.       begin
  2677.         Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
  2678.           ColorBitsSize + MonoBitsSize;
  2679.         Stream.Write(Length, SizeOf(Length));
  2680.       end;
  2681.       with CI do
  2682.       begin
  2683.         CI.wType := RC3_ICON;
  2684.         CI.Count := 1;
  2685.       end;
  2686.       Stream.Write(CI, SizeOf(CI));
  2687.       with List, PBitmapInfoHeader(ColorInfo)^ do
  2688.       begin
  2689.         Width := biWidth;
  2690.         Height := biHeight;
  2691.         Colors := biPlanes * biBitCount;
  2692.         DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
  2693.         DIBOffset := SizeOf(CI) + SizeOf(List);
  2694.       end;
  2695.       Stream.Write(List, SizeOf(List));
  2696.       with PBitmapInfoHeader(ColorInfo)^ do
  2697.         Inc(biHeight, biHeight); { color height includes mono bits }
  2698.       Stream.Write(ColorInfo^, ColorInfoSize);
  2699.       Stream.Write(ColorBits^, ColorBitsSize);
  2700.       Stream.Write(MonoBits^, MonoBitsSize);
  2701.     finally
  2702.       FreeMem(ColorInfo, ColorInfoSize);
  2703.       FreeMem(ColorBits, ColorBitsSize);
  2704.       FreeMem(MonoInfo, MonoInfoSize);
  2705.       FreeMem(MonoBits, MonoBitsSize);
  2706.     end;
  2707.   finally
  2708.     DeleteObject(IconInfo.hbmColor);
  2709.     DeleteObject(IconInfo.hbmMask);
  2710.   end;
  2711. end;
  2712.  
  2713. { TGraphic }
  2714.  
  2715. constructor TGraphic.Create;
  2716. begin
  2717.   inherited Create;
  2718. end;
  2719.  
  2720. procedure TGraphic.Changed(Sender: TObject);
  2721. begin
  2722.   FModified := True;
  2723.   if Assigned(FOnChange) then FOnChange(Self);
  2724. end;
  2725.  
  2726. procedure TGraphic.DefineProperties(Filer: TFiler);
  2727.  
  2728.   function DoWrite: Boolean;
  2729.   begin
  2730.     if Filer.Ancestor <> nil then
  2731.       Result := not (Filer.Ancestor is TGraphic) or
  2732.         not Equals(TGraphic(Filer.Ancestor))
  2733.     else
  2734.       Result := not Empty;
  2735.   end;
  2736.  
  2737. begin
  2738.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  2739. end;
  2740.  
  2741. function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  2742. asm
  2743.         PUSH    ESI
  2744.         PUSH    EDI
  2745.         MOV     ESI,P1
  2746.         MOV     EDI,P2
  2747.         MOV     EDX,ECX
  2748.         XOR     EAX,EAX
  2749.         AND     EDX,3
  2750.         SHR     ECX,1
  2751.         SHR     ECX,1
  2752.         REPE    CMPSD
  2753.         JNE     @@2
  2754.         MOV     ECX,EDX
  2755.         REPE    CMPSB
  2756.         JNE     @@2
  2757. @@1:    INC     EAX
  2758. @@2:    POP     EDI
  2759.         POP     ESI
  2760. end;
  2761.  
  2762.  
  2763. function StreamsEqual(S1, S2: TMemoryStream): Boolean;
  2764. begin
  2765.   Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  2766. end;
  2767.  
  2768. function TGraphic.Equals(Graphic: TGraphic): Boolean;
  2769. var
  2770.   MyImage, GraphicsImage: TMemoryStream;
  2771. begin
  2772.   Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
  2773.   if Empty or Graphic.Empty then
  2774.   begin
  2775.     Result := Empty and Graphic.Empty;
  2776.     Exit;
  2777.   end;
  2778.   if Result then
  2779.   begin
  2780.     MyImage := TMemoryStream.Create;
  2781.     try
  2782.       WriteData(MyImage);
  2783.       GraphicsImage := TMemoryStream.Create;
  2784.       try
  2785.         Graphic.WriteData(GraphicsImage);
  2786.         Result := StreamsEqual(MyImage, GraphicsImage);
  2787.       finally
  2788.         GraphicsImage.Free;
  2789.       end;
  2790.     finally
  2791.       MyImage.Free;
  2792.     end;
  2793.   end;
  2794. end;
  2795.  
  2796. procedure TGraphic.SetModified(Value: Boolean);
  2797. begin
  2798.   if Value then
  2799.     Changed(Self) else
  2800.     FModified := False;
  2801. end;
  2802.  
  2803. procedure TGraphic.LoadFromFile(const Filename: string);
  2804. var
  2805.   Stream: TStream;
  2806. begin
  2807.   Stream := TFileStream.Create(Filename, fmOpenRead);
  2808.   try
  2809.     LoadFromStream(Stream);
  2810.   finally
  2811.     Stream.Free;
  2812.   end;
  2813. end;
  2814.  
  2815. procedure TGraphic.SaveToFile(const Filename: string);
  2816. var
  2817.   Stream: TStream;
  2818. begin
  2819.   Stream := TFileStream.Create(Filename, fmCreate);
  2820.   try
  2821.     SaveToStream(Stream);
  2822.   finally
  2823.     Stream.Free;
  2824.   end;
  2825. end;
  2826.  
  2827. procedure TGraphic.ReadData(Stream: TStream);
  2828. begin
  2829.   LoadFromStream(Stream);
  2830. end;
  2831.  
  2832. procedure TGraphic.WriteData(Stream: TStream);
  2833. begin
  2834.   SaveToStream(Stream);
  2835. end;
  2836.  
  2837. { TPicture }
  2838.  
  2839. type
  2840.   PFileFormat = ^TFileFormat;
  2841.   TFileFormat = record
  2842.     GraphicClass: TGraphicClass;
  2843.     Extension: string;
  2844.     Description: string;
  2845.     DescResID: Integer;
  2846.     Next: PFileFormat;
  2847.   end;
  2848.  
  2849. { Pre-registered file formats }
  2850.  
  2851. const
  2852.   WMFMetafileFormat: TFileFormat = (
  2853.     GraphicClass: TMetafile;
  2854.     Extension: 'wmf';
  2855.     Description: '';
  2856.     DescResID: SVMetafiles;
  2857.     Next: nil);
  2858.   MetaFileFormat: TFileFormat = (
  2859.     GraphicClass: TMetafile;
  2860.     Extension: 'emf';
  2861.     Description: '';
  2862.     DescResID: SVEnhMetafiles;
  2863.     Next: @WMFMetaFileFormat);
  2864.   IconFormat: TFileFormat = (
  2865.     GraphicClass: TIcon;
  2866.     Extension: 'ico';
  2867.     Description: '';
  2868.     DescResID: SVIcons;
  2869.     Next: @MetafileFormat);
  2870.   BitmapFormat: TFileFormat = (
  2871.     GraphicClass: TBitmap;
  2872.     Extension: 'bmp';
  2873.     Description: '';
  2874.     DescResID: SVBitmaps;
  2875.     Next: @IconFormat);
  2876. var
  2877.   FileFormatList: PFileFormat = @BitmapFormat;
  2878.  
  2879. type
  2880.   PClipboardFormat = ^TClipboardFormat;
  2881.   TClipboardFormat = record
  2882.     GraphicClass: TGraphicClass;
  2883.     Format: Word;
  2884.     Next: PClipboardFormat;
  2885.   end;
  2886.  
  2887. const
  2888.   WMFMetafileClipFormat: TClipboardFormat = (
  2889.     GraphicClass: TMetafile;
  2890.     Format: CF_METAFILEPICT;
  2891.     Next: nil);
  2892.   MetafileClipFormat: TClipboardFormat = (
  2893.     GraphicClass: TMetafile;
  2894.     Format: CF_ENHMETAFILE;
  2895.     Next: @WMFMetaFileClipFormat);
  2896.   BitmapClipFormat: TClipboardFormat = (
  2897.     GraphicClass: TBitmap;
  2898.     Format: CF_BITMAP;
  2899.     Next: @MetafileClipFormat);
  2900. //  DIBClipFormat: TClipboardFormat = (...
  2901. var
  2902.   ClipboardFormatList: PClipboardFormat = @BitmapClipFormat;
  2903.  
  2904. destructor TPicture.Destroy;
  2905. begin
  2906.   FGraphic.Free;
  2907.   inherited Destroy;
  2908. end;
  2909.  
  2910. procedure TPicture.AssignTo(Dest: TPersistent);
  2911. begin
  2912.   if Graphic is Dest.ClassType then
  2913.     Dest.Assign(Graphic)
  2914.   else
  2915.     inherited AssignTo(Dest);
  2916. end;
  2917.  
  2918. procedure TPicture.ForceType(GraphicType: TGraphicClass);
  2919. begin
  2920.   if not (Graphic is GraphicType) then
  2921.   begin
  2922.     FGraphic.Free;
  2923.     FGraphic := nil;
  2924.     FGraphic := GraphicType.Create;
  2925.     FGraphic.OnChange := Changed;
  2926.     Changed(Self);
  2927.   end;
  2928. end;
  2929.  
  2930. function TPicture.GetBitmap: TBitmap;
  2931. begin
  2932.   ForceType(TBitmap);
  2933.   Result := TBitmap(Graphic);
  2934. end;
  2935.  
  2936. function TPicture.GetIcon: TIcon;
  2937. begin
  2938.   ForceType(TIcon);
  2939.   Result := TIcon(Graphic);
  2940. end;
  2941.  
  2942. function TPicture.GetMetafile: TMetafile;
  2943. begin
  2944.   ForceType(TMetafile);
  2945.   Result := TMetafile(Graphic);
  2946. end;
  2947.  
  2948. procedure TPicture.SetBitmap(Value: TBitmap);
  2949. begin
  2950.   SetGraphic(Value);
  2951. end;
  2952.  
  2953. procedure TPicture.SetIcon(Value: TIcon);
  2954. begin
  2955.   SetGraphic(Value);
  2956. end;
  2957.  
  2958. procedure TPicture.SetMetafile(Value: TMetafile);
  2959. begin
  2960.   SetGraphic(Value);
  2961. end;
  2962.  
  2963. procedure TPicture.SetGraphic(Value: TGraphic);
  2964. var
  2965.   NewGraphic: TGraphic;
  2966. begin
  2967.   NewGraphic := nil;
  2968.   if Value <> nil then
  2969.   begin
  2970.     NewGraphic := TGraphicClass(Value.ClassType).Create;
  2971.     NewGraphic.Assign(Value);
  2972.     NewGraphic.OnChange := Changed;
  2973.   end;
  2974.   try
  2975.     FGraphic.Free;
  2976.     FGraphic := NewGraphic;
  2977.     Changed(Self);
  2978.   except
  2979.     NewGraphic.Free;
  2980.     raise;
  2981.   end;
  2982. end;
  2983.  
  2984. { Based on the extension of Filename, create the cooresponding TGraphic class
  2985.   and call its LoadFromFile method. }
  2986.  
  2987. procedure TPicture.LoadFromFile(const Filename: string);
  2988. var
  2989.   Ext: string;
  2990.   Graphic: PFileFormat;
  2991.   NewGraphic: TGraphic;
  2992. begin
  2993.   Ext := LowerCase(Copy(ExtractFileExt(Filename), 2, Maxint));
  2994.   Graphic := FileFormatList;
  2995.   while Graphic <> nil do
  2996.     with Graphic^ do
  2997.     begin
  2998.       if Extension <> Ext then
  2999.         Graphic := Next
  3000.       else
  3001.       begin
  3002.         NewGraphic := GraphicClass.Create;
  3003.         try
  3004.           NewGraphic.LoadFromFile(Filename);
  3005.         except
  3006.           NewGraphic.Free;
  3007.           raise;
  3008.         end;
  3009.         FGraphic.Free;
  3010.         FGraphic := NewGraphic;
  3011.         FGraphic.OnChange := Changed;
  3012.         Changed(Self);
  3013.         Exit;
  3014.       end;
  3015.     end;
  3016.   raise EInvalidGraphic.CreateResFmt(SUnknownExtension, [Ext]);
  3017. end;
  3018.  
  3019. procedure TPicture.SaveToFile(const Filename: string);
  3020. begin
  3021.   if FGraphic <> nil then FGraphic.SaveToFile(Filename);
  3022. end;
  3023.  
  3024. procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3025.   APalette: HPALETTE);
  3026. var
  3027.   NewGraphic: TGraphic;
  3028.   Graphic: PClipboardFormat;
  3029. begin
  3030.   Graphic := ClipboardFormatList;
  3031.   while Graphic <> nil do
  3032.     with Graphic^ do
  3033.     begin
  3034.       if AFormat <> Format then
  3035.         Graphic := Next
  3036.       else
  3037.       begin
  3038.         NewGraphic := GraphicClass.Create;
  3039.         try
  3040.           NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
  3041.         except
  3042.           NewGraphic.Free;
  3043.           raise;
  3044.         end;
  3045.         FGraphic.Free;
  3046.         FGraphic := NewGraphic;
  3047.         FGraphic.OnChange := Changed;
  3048.         Changed(Self);
  3049.         Exit;
  3050.       end;
  3051.     end;
  3052.   InvalidGraphic(SUnknownClipboardFormat);
  3053. end;
  3054.  
  3055. procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  3056.   var APalette: HPALETTE);
  3057. begin
  3058.   if FGraphic <> nil then
  3059.     FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
  3060. end;
  3061.  
  3062. class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
  3063. var
  3064.   Graphic: PClipboardFormat;
  3065. begin
  3066.   Result := True;
  3067.   Graphic := ClipboardFormatList;
  3068.   while Graphic <> nil do
  3069.     with Graphic^ do
  3070.       if AFormat = Format then Exit
  3071.       else Graphic := Next;
  3072.   Result := False;
  3073. end;
  3074.  
  3075. procedure TPicture.Assign(Source: TPersistent);
  3076. begin
  3077.   if Source = nil then
  3078.     SetGraphic(nil)
  3079.   else if Source is TPicture then
  3080.     SetGraphic(TPicture(Source).Graphic)
  3081.   else if Source is TGraphic then
  3082.     SetGraphic(TGraphic(Source))
  3083.   else
  3084.     inherited Assign(Source);
  3085. end;
  3086.  
  3087. { Add AGraphicClass to the list of registered TGraphic classes. }
  3088.  
  3089. procedure AppendFileFormat(const Ext, Desc: String; DescID: Integer;
  3090.   AClass: TGraphicClass);
  3091. var
  3092.   NewRec: PFileFormat;
  3093. begin
  3094.   New(NewRec);
  3095.   with NewRec^ do
  3096.   begin
  3097.     Extension := LowerCase(Ext);
  3098.     GraphicClass := AClass;
  3099.     Description := Desc;
  3100.     DescResID := DescID;
  3101.     Next := FileFormatList;
  3102.   end;
  3103.   FileFormatList := NewRec;
  3104. end;
  3105.  
  3106. class procedure TPicture.RegisterFileFormat(const AExtension,
  3107.   ADescription: string; AGraphicClass: TGraphicClass);
  3108. begin
  3109.   AppendFileFormat(AExtension, ADescription, 0, AGraphicClass);
  3110. end;
  3111.  
  3112. class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  3113.   ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  3114. begin
  3115.   AppendFileFormat(AExtension, '', ADescriptionResID, AGraphicClass);
  3116. end;
  3117.  
  3118. class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  3119.   AGraphicClass: TGraphicClass);
  3120. var
  3121.   NewRec: PClipboardFormat;
  3122. begin
  3123.   New(NewRec);
  3124.   with NewRec^ do
  3125.   begin
  3126.     GraphicClass := AGraphicClass;
  3127.     Format := AFormat;
  3128.     Next := ClipboardFormatList;
  3129.   end;
  3130.   ClipboardFormatList := NewRec;
  3131. end;
  3132.  
  3133. procedure TPicture.Changed(Sender: TObject);
  3134. begin
  3135.   if Assigned(FOnChange) then FOnChange(Self);
  3136. end;
  3137.  
  3138. procedure TPicture.ReadData(Stream: TStream);
  3139. var
  3140.   CName: string[63];
  3141.   Format: PFileFormat;
  3142.   NewGraphic: TGraphic;
  3143. begin
  3144.   with Stream do
  3145.   begin
  3146.     Read(CName[0], 1);
  3147.     Read(CName[1], Integer(CName[0]));
  3148.     Format := FileFormatList;
  3149.     while Format <> nil do
  3150.       with Format^ do
  3151.         if GraphicClass.ClassName <> CName then Format := Next
  3152.         else
  3153.         begin
  3154.           NewGraphic := GraphicClass.Create;
  3155.           try
  3156.             NewGraphic.ReadData(Stream);
  3157.           except
  3158.             NewGraphic.Free;
  3159.             raise;
  3160.           end;
  3161.           FGraphic.Free;
  3162.           FGraphic := NewGraphic;
  3163.           FGraphic.OnChange := Changed;
  3164.           Changed(Self);
  3165.           Exit;
  3166.         end;
  3167.   end;
  3168. end;
  3169.  
  3170. procedure TPicture.WriteData(Stream: TStream);
  3171. var
  3172.   CName: string[63];
  3173. begin
  3174.   with Stream do
  3175.   begin
  3176.     CName := Graphic.ClassName;
  3177.     Write(CName, Length(CName) + 1);
  3178.     Graphic.WriteData(Stream);
  3179.   end;
  3180. end;
  3181.  
  3182. procedure TPicture.DefineProperties(Filer: TFiler);
  3183.  
  3184.   function DoWrite: Boolean;
  3185.   var
  3186.     Ancestor: TPicture;
  3187.   begin
  3188.     if Filer.Ancestor <> nil then
  3189.     begin
  3190.       Result := True;
  3191.       if Filer.Ancestor is TPicture then
  3192.       begin
  3193.         Ancestor := TPicture(Filer.Ancestor);
  3194.         Result := not ((Graphic = Ancestor.Graphic) or
  3195.           ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
  3196.           Graphic.Equals(Ancestor.Graphic)));
  3197.       end;
  3198.     end
  3199.     else Result := Graphic <> nil;
  3200.   end;
  3201.  
  3202. begin
  3203.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3204. end;
  3205.  
  3206. function TPicture.GetWidth: Integer;
  3207. begin
  3208.   Result := 0;
  3209.   if FGraphic <> nil then Result := FGraphic.Width;
  3210. end;
  3211.  
  3212. function TPicture.GetHeight: Integer;
  3213. begin
  3214.   Result := 0;
  3215.   if FGraphic <> nil then Result := FGraphic.Height;
  3216. end;
  3217.  
  3218. { TMetafileImage }
  3219.  
  3220. procedure TMetafileImage.Reference;
  3221. begin
  3222.   Inc(FRefCount);
  3223. end;
  3224.  
  3225. procedure TMetafileImage.Release;
  3226. begin
  3227.   if Assigned(Self) then
  3228.   begin
  3229.     Dec(FRefCount);
  3230.     if FRefCount = 0 then
  3231.     begin
  3232.       if FHandle <> 0 then DeleteEnhMetafile(FHandle);
  3233.       if FPalette <> 0 then DeleteObject(FPalette);
  3234.       Free;
  3235.     end;
  3236.   end;
  3237. end;
  3238.  
  3239.  
  3240. { TMetafileCanvas }
  3241.  
  3242. constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  3243. begin
  3244.   CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
  3245.     AMetafile.Description);
  3246. end;
  3247.  
  3248. constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
  3249.   ReferenceDevice: HDC; const CreatedBy, Description: String);
  3250. var
  3251.   RefDC: HDC;
  3252.   R: TRect;
  3253.   Temp: HDC;
  3254.   P: PChar;
  3255. begin
  3256.   inherited Create;
  3257.   FMetafile := AMetafile;
  3258.   RefDC := ReferenceDevice;
  3259.   if ReferenceDevice = 0 then RefDC := GetDC(0);
  3260.   try
  3261.     if FMetafile.MMWidth = 0 then
  3262.       if FMetafile.Width = 0 then
  3263.         FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
  3264.       else
  3265.         FMetafile.MMWidth := MulDiv(FMetafile.Width,
  3266.           GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
  3267.     if FMetafile.MMHeight = 0 then
  3268.       if FMetafile.Height = 0 then
  3269.         FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
  3270.       else
  3271.         FMetafile.MMHeight := MulDiv(FMetafile.Height,
  3272.           GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
  3273.     R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
  3274.     if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
  3275.       P := PChar(CreatedBy+#0+Description+#0#0)
  3276.     else
  3277.       P := nil;
  3278.     Temp := CreateEnhMetafile(RefDC, nil, @R, P);
  3279.     if Temp = 0 then OutOfResources;
  3280.     Handle := Temp;
  3281.   finally
  3282.     if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  3283.   end;
  3284. end;
  3285.  
  3286. destructor TMetafileCanvas.Destroy;
  3287. var
  3288.   Temp: HDC;
  3289. begin
  3290.   Temp := Handle;
  3291.   Handle := 0;
  3292.   FMetafile.Handle := CloseEnhMetafile(Temp);
  3293.   inherited Destroy;
  3294. end;
  3295.  
  3296. { TMetafile }
  3297.  
  3298. constructor TMetafile.Create;
  3299. begin
  3300.   inherited Create;
  3301.   FEnhanced := True;
  3302.   Assign(nil);
  3303. end;
  3304.  
  3305. destructor TMetafile.Destroy;
  3306. begin
  3307.   FImage.Release;
  3308.   inherited Destroy;
  3309. end;
  3310.  
  3311. procedure TMetafile.Assign(Source: TPersistent);
  3312. begin
  3313.   if (Source = nil) or (Source is TMetafile) then
  3314.   begin
  3315.     FImage.Release;
  3316.     if Assigned(Source) then
  3317.     begin
  3318.       FImage := TMetafile(Source).FImage;
  3319.       FEnhanced := TMetafile(Source).Enhanced;
  3320.     end
  3321.     else
  3322.     begin
  3323.       FImage := TMetafileImage.Create;
  3324.       FEnhanced := True;
  3325.     end;
  3326.     FImage.Reference;
  3327.     Changed(Self);
  3328.   end
  3329.   else
  3330.     inherited Assign(Source);
  3331. end;
  3332.  
  3333. procedure TMetafile.Clear;
  3334. begin
  3335.   NewImage;
  3336. end;
  3337.  
  3338. procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
  3339. var
  3340.   MetaPal, OldPal: HPALETTE;
  3341.   R: TRect;
  3342. begin
  3343.   if FImage = nil then Exit;
  3344.   MetaPal := Palette;
  3345.   OldPal := 0;
  3346.   if MetaPal <> 0 then
  3347.   begin
  3348.     OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
  3349.     RealizePalette(ACanvas.Handle);
  3350.   end;
  3351.   R := Rect;
  3352.   Dec(R.Right);  // Metafile rect includes right and bottom coords
  3353.   Dec(R.Bottom);
  3354.   PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
  3355.   if MetaPal <> 0 then
  3356.     SelectPalette(ACanvas.Handle, OldPal, True);
  3357. end;
  3358.  
  3359. function TMetafile.GetAuthor: String;
  3360. var
  3361.   Temp: Integer;
  3362. begin
  3363.   Result := '';
  3364.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3365.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3366.   if Temp <= 0 then Exit;
  3367.   SetLength(Result, Temp);
  3368.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3369.   SetLength(Result, StrLen(PChar(Result)));
  3370. end;
  3371.  
  3372. function TMetafile.GetDesc: String;
  3373. var
  3374.   Temp: Integer;
  3375. begin
  3376.   Result := '';
  3377.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3378.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3379.   if Temp <= 0 then Exit;
  3380.   SetLength(Result, Temp);
  3381.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3382.   Delete(Result, 1, StrLen(PChar(Result)));
  3383.   SetLength(Result, StrLen(PChar(Result)));
  3384. end;
  3385.  
  3386. function TMetafile.GetEmpty;
  3387. begin
  3388.   Result := FImage = nil;
  3389. end;
  3390.  
  3391. function TMetafile.GetHandle: HENHMETAFILE;
  3392. begin
  3393.   if Assigned(FImage) then
  3394.     Result := FImage.FHandle
  3395.   else
  3396.     Result := 0;
  3397. end;
  3398.  
  3399. function TMetafile.GetHeight: Integer;
  3400. var
  3401.   EMFHeader: TEnhMetaHeader;
  3402. begin
  3403.   if FImage = nil then NewImage;
  3404.   with FImage do
  3405.    if FInch = 0 then
  3406.      if FHandle = 0 then
  3407.        Result := FTempHeight
  3408.      else
  3409.      begin               { convert 0.01mm units to referenceDC device pixels }
  3410.        GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3411.        Result := MulDiv(FHeight,                     { metafile height in 0.01mm }
  3412.          EMFHeader.szlDevice.cy,                      { device height in pixels }
  3413.          EMFHeader.szlMillimeters.cy*100);            { device height in mm }
  3414.      end
  3415.    else          { for WMF files, convert to font dpi based device pixels }
  3416.      Result := MulDiv(FHeight, Screen.PixelsPerInch, 25400);
  3417. end;
  3418.  
  3419. function TMetafile.GetInch: Word;
  3420. begin
  3421.   Result := 0;
  3422.   if FImage <> nil then Result := FImage.FInch;
  3423. end;
  3424.  
  3425. function TMetafile.GetMMHeight: Integer;
  3426. begin
  3427.   if FImage = nil then NewImage;
  3428.   Result := FImage.FHeight;
  3429. end;
  3430.  
  3431. function TMetafile.GetMMWidth: Integer;
  3432. begin
  3433.   if FImage = nil then NewImage;
  3434.   Result := FImage.FWidth;
  3435. end;
  3436.  
  3437. function TMetafile.GetPalette: HPALETTE;
  3438. var
  3439.   LogPal: PLogPalette;
  3440.   Count: Integer;
  3441. begin
  3442.   Result := 0;
  3443.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3444.   if FImage.FPalette = 0 then
  3445.   begin
  3446.     Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
  3447.     if Count = 0 then Exit;
  3448.     if FImage.FPalette <> 0 then DeleteObject(FImage.FPalette);
  3449.     GetMem(LogPal, Sizeof(TLogPalette) + Count * Sizeof(TPaletteEntry));
  3450.     try
  3451.       LogPal^.palVersion := $300;
  3452.       LogPal^.palNumEntries := Count;
  3453.       GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, @LogPal^.palPalEntry);
  3454.       FImage.FPalette := CreatePalette(LogPal^);
  3455.     finally
  3456.       FreeMem(LogPal,Sizeof(TLogPalette) + Count * Sizeof(TPaletteEntry));
  3457.     end;
  3458.   end;
  3459.   Result := FImage.FPalette;
  3460. end;
  3461.  
  3462. function TMetafile.GetWidth: Integer;
  3463. var
  3464.   EMFHeader: TEnhMetaHeader;
  3465. begin
  3466.   if FImage = nil then NewImage;
  3467.   with FImage do
  3468.     if FInch = 0 then
  3469.       if FHandle = 0 then
  3470.         Result := FTempWidth
  3471.       else
  3472.       begin     { convert 0.01mm units to referenceDC device pixels }
  3473.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3474.         Result := MulDiv(FWidth,                      { metafile width in 0.01mm }
  3475.           EMFHeader.szlDevice.cx,                      { device width in pixels }
  3476.           EMFHeader.szlMillimeters.cx*100);            { device width in 0.01mm }
  3477.       end
  3478.     else      { for WMF files, convert to font dpi based device pixels }
  3479.       Result := MulDiv(FWidth, Screen.PixelsPerInch, 25400);
  3480. end;
  3481.  
  3482. procedure TMetafile.LoadFromStream(Stream: TStream);
  3483. begin
  3484.   NewImage;
  3485.   if TestEMF(Stream) then
  3486.     ReadEMFStream(Stream)
  3487.   else
  3488.     ReadWMFStream(Stream, Stream.Size - Stream.Position);
  3489.   Changed(Self);
  3490. end;
  3491.  
  3492. procedure TMetafile.NewImage;
  3493. begin
  3494.   FImage.Release;
  3495.   FImage := TMetafileImage.Create;
  3496.   FImage.Reference;
  3497. end;
  3498.  
  3499. procedure TMetafile.ReadData(Stream: TStream);
  3500. var
  3501.   Length: Longint;
  3502. begin
  3503.   Stream.Read(Length, SizeOf(Longint));
  3504.   if TestEMF(Stream) then
  3505.     ReadEMFStream(Stream)
  3506.   else
  3507.     ReadWMFStream(Stream, Length);
  3508.   Changed(Self);
  3509. end;
  3510.  
  3511. procedure TMetafile.ReadEMFStream(Stream: TStream);
  3512. var
  3513.   EnhHeader: TEnhMetaheader;
  3514.   Buf: PChar;
  3515. begin
  3516.   NewImage;
  3517.   Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
  3518.   if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  3519.   GetMem(Buf, EnhHeader.nBytes);
  3520.   with FImage do
  3521.   try
  3522.     Move(EnhHeader, Buf^, Sizeof(EnhHeader));
  3523.     Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
  3524.       EnhHeader.nBytes - Sizeof(EnhHeader));
  3525.     FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
  3526.     if FHandle = 0 then InvalidMetafile;
  3527.     FInch := 0;
  3528.     with EnhHeader.rclFrame do
  3529.     begin
  3530.       FWidth := Right - Left;    { in 0.01 mm units }
  3531.       FHeight := Bottom - Top;
  3532.     end;
  3533.     Enhanced := True;
  3534.   finally
  3535.     FreeMem(Buf, EnhHeader.nBytes);
  3536.   end;
  3537. end;
  3538.  
  3539. procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
  3540. var
  3541.   WMF: TMetafileHeader;
  3542.   BitMem: Pointer;
  3543.   MFP: TMetaFilePict;
  3544. begin
  3545.   NewImage;
  3546.   Stream.Read(WMF, SizeOf(WMF));
  3547.   if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
  3548.     InvalidMetafile;
  3549.   Dec(Length, SizeOf(WMF));
  3550.   GetMem(Bitmem, Length);
  3551.   with FImage do
  3552.   try
  3553.     Stream.Read(BitMem^, Length);
  3554.     FImage.FInch := WMF.Inch;
  3555.     if WMF.Inch = 0 then WMF.Inch := 96;
  3556.     FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left,25400,WMF.Inch);
  3557.     FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top,25400,WMF.Inch);
  3558.     with MFP do
  3559.     begin
  3560.       MM := MM_ANISOTROPIC;
  3561.       xExt := 0;
  3562.       yExt := 0;
  3563.       hmf := 0;
  3564.     end;
  3565.     FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
  3566.     if FHandle = 0 then InvalidMetafile;
  3567.     Enhanced := False;
  3568.   finally
  3569.     Freemem(BitMem, Length);
  3570.   end;
  3571. end;
  3572.  
  3573. procedure TMetafile.SaveToFile(const Filename: String);
  3574. var
  3575.   SaveEnh: Boolean;
  3576. begin
  3577.   SaveEnh := Enhanced;
  3578.   if LowerCase(ExtractFileExt(Filename)) = '.wmf' then
  3579.     Enhanced := False;              { For 16 bit compatibility }
  3580.   inherited SaveToFile(Filename);
  3581.   Enhanced := SaveEnh;
  3582. end;
  3583.  
  3584. procedure TMetafile.SaveToStream(Stream: TStream);
  3585. begin
  3586.   if FImage <> nil then
  3587.     if Enhanced then
  3588.       WriteEMFStream(Stream)
  3589.     else
  3590.       WriteWMFStream(Stream);
  3591. end;
  3592.  
  3593. procedure TMetafile.SetHandle(Value: HENHMETAFILE);
  3594. var
  3595.   EnhHeader: TEnhMetaHeader;
  3596. begin
  3597.   if (Value <> 0) and
  3598.     (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
  3599.     InvalidMetafile;
  3600.   UniqueImage;
  3601.   if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
  3602.   if FImage.FPalette <> 0 then DeleteObject(FImage.FPalette);
  3603.   FImage.FPalette := 0;
  3604.   FImage.FHandle := Value;
  3605.   FImage.FTempWidth := 0;
  3606.   FImage.FTempHeight := 0;
  3607.   if Value <> 0 then
  3608.     with EnhHeader.rclFrame do
  3609.     begin
  3610.       FImage.FWidth := Right - Left;
  3611.       FImage.FHeight := Bottom - Top;
  3612.     end;
  3613.   Changed(Self);
  3614. end;
  3615.  
  3616. procedure TMetafile.SetHeight(Value: Integer);
  3617. var
  3618.   EMFHeader: TEnhMetaHeader;
  3619. begin
  3620.   if FImage = nil then NewImage;
  3621.   with FImage do
  3622.     if FInch = 0 then
  3623.       if FHandle = 0 then
  3624.         FTempHeight := Value
  3625.       else
  3626.       begin                 { convert device pixels to 0.01mm units }
  3627.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3628.         MMHeight := MulDiv(Value,                      { metafile height in pixels }
  3629.           EMFHeader.szlMillimeters.cy*100,             { device height in 0.01mm }
  3630.           EMFHeader.szlDevice.cy);                     { device height in pixels }
  3631.       end
  3632.     else
  3633.       MMHeight := MulDiv(Value, 25400, Screen.PixelsPerInch);
  3634. end;
  3635.  
  3636. procedure TMetafile.SetInch(Value: Word);
  3637. begin
  3638.   if FImage = nil then NewImage;
  3639.   if FImage.FInch <> Value then
  3640.   begin
  3641.     UniqueImage;
  3642.     FImage.FInch := Value;
  3643.     Changed(Self);
  3644.   end;
  3645. end;
  3646.  
  3647. procedure TMetafile.SetMMHeight(Value: Integer);
  3648. begin
  3649.   if FImage = nil then NewImage;
  3650.   FImage.FTempHeight := 0;
  3651.   if FImage.FHeight <> Value then
  3652.   begin
  3653.     UniqueImage;
  3654.     FImage.FHeight := Value;
  3655.     Changed(Self);
  3656.   end;
  3657. end;
  3658.  
  3659. procedure TMetafile.SetMMWidth(Value: Integer);
  3660. begin
  3661.   if FImage = nil then NewImage;
  3662.   FImage.FTempWidth := 0;
  3663.   if FImage.FWidth <> Value then
  3664.   begin
  3665.     UniqueImage;
  3666.     FImage.FWidth := Value;
  3667.     Changed(Self);
  3668.   end;
  3669. end;
  3670.  
  3671. procedure TMetafile.SetWidth(Value: Integer);
  3672. var
  3673.   EMFHeader: TEnhMetaHeader;
  3674. begin
  3675.   if FImage = nil then NewImage;
  3676.   with FImage do
  3677.     if FInch = 0 then
  3678.       if FHandle = 0 then
  3679.         FTempWidth := Value
  3680.       else
  3681.       begin                 { convert device pixels to 0.01mm units }
  3682.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3683.         MMWidth := MulDiv(Value,                      { metafile width in pixels }
  3684.           EMFHeader.szlMillimeters.cx*100,            { device width in mm }
  3685.           EMFHeader.szlDevice.cx);                    { device width in pixels }
  3686.       end
  3687.     else
  3688.       MMWidth := MulDiv(Value, 25400, Screen.PixelsPerInch);
  3689. end;
  3690.  
  3691. function TMetafile.TestEMF(Stream: TStream): Boolean;
  3692. var
  3693.   Size: Longint;
  3694.   Header: TEnhMetaHeader;
  3695. begin
  3696.   Size := Stream.Size - Stream.Position;
  3697.   if Size > Sizeof(Header) then
  3698.   begin
  3699.     Stream.Read(Header, Sizeof(Header));
  3700.     Stream.Seek(-Sizeof(Header), soFromCurrent);
  3701.   end;
  3702.   Result := (Size > Sizeof(Header)) and
  3703.     (Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
  3704. end;
  3705.  
  3706. procedure TMetafile.UniqueImage;
  3707. var
  3708.   NewImage: TMetafileImage;
  3709. begin
  3710.   if FImage = nil then
  3711.     Self.NewImage
  3712.   else
  3713.     if FImage.FRefCount > 1 then
  3714.     begin
  3715.       NewImage:= TMetafileImage.Create;
  3716.       if FImage.FHandle <> 0 then
  3717.         NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
  3718.       NewImage.FHeight := FImage.FHeight;
  3719.       NewImage.FWidth := FImage.FWidth;
  3720.       NewImage.FInch := FImage.FInch;
  3721.       NewImage.FTempWidth := FImage.FTempWidth;
  3722.       NewImage.FTempHeight := FImage.FTempHeight;
  3723.       FImage.Release;
  3724.       FImage := NewImage;
  3725.       FImage.Reference;
  3726.     end;
  3727. end;
  3728.  
  3729. procedure TMetafile.WriteData(Stream: TStream);
  3730. var
  3731.   SavePos: Longint;
  3732. begin
  3733.   if FImage <> nil then
  3734.   begin
  3735.     SavePos := 0;
  3736.     Stream.Write(SavePos, Sizeof(SavePos));
  3737.     SavePos := Stream.Position - Sizeof(SavePos);
  3738.     if Enhanced then
  3739.       WriteEMFStream(Stream)
  3740.     else
  3741.       WriteWMFStream(Stream);
  3742.     Stream.Seek(SavePos, soFromBeginning);
  3743.     SavePos := Stream.Size - SavePos;
  3744.     Stream.Write(SavePos, Sizeof(SavePos));
  3745.     Stream.Seek(0, soFromEnd);
  3746.   end;
  3747. end;
  3748.  
  3749. procedure TMetafile.WriteEMFStream(Stream: TStream);
  3750. var
  3751.   Buf: Pointer;
  3752.   Length: Longint;
  3753. begin
  3754.   if FImage = nil then Exit;
  3755.   Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  3756.   GetMem(Buf, Length);
  3757.   try
  3758.     GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
  3759.     Stream.WriteBuffer(Buf^, Length);
  3760.   finally
  3761.     FreeMem(Buf, Length);
  3762.   end;
  3763. end;
  3764.  
  3765. procedure TMetafile.WriteWMFStream(Stream: TStream);
  3766. var
  3767.   WMF: TMetafileHeader;
  3768.   Bits: Pointer;
  3769.   Length: Longint;
  3770.   RefDC: HDC;
  3771. begin
  3772.   if FImage = nil then Exit;
  3773.   FillChar(WMF, SizeOf(WMF), 0);
  3774.   with FImage do
  3775.   begin
  3776.     with WMF do
  3777.     begin
  3778.       Key := WMFKEY;
  3779.       if FInch = 0 then
  3780.         Inch := 2540          { 2540 0.01mm units per inch }
  3781.       else
  3782.         Inch := FInch;
  3783.       with Box do
  3784.       begin
  3785.         Left := 0;
  3786.         Top := 0;
  3787.         Right := FWidth;
  3788.         Bottom := FHeight;
  3789.       end;
  3790.       CheckSum := ComputeAldusChecksum(WMF);
  3791.     end;
  3792.     RefDC := GetDC(0);
  3793.     try
  3794.       Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
  3795.       GetMem(Bits, Length);
  3796.       try
  3797.         if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
  3798.           RefDC) < Length then OutOfResources;
  3799.         Stream.WriteBuffer(WMF, SizeOf(WMF));
  3800.         Stream.WriteBuffer(Bits^, Length);
  3801.       finally
  3802.         FreeMem(Bits, Length);
  3803.       end;
  3804.     finally
  3805.       ReleaseDC(0, RefDC);
  3806.     end;
  3807.   end;
  3808. end;
  3809.  
  3810. procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3811.   APalette: HPALETTE);
  3812. var
  3813.   EnhHeader: TEnhMetaHeader;
  3814. begin
  3815.   AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
  3816.   if AData = 0 then  InvalidGraphic(SUnknownClipboardFormat);
  3817.   NewImage;
  3818.   with FImage do
  3819.   begin
  3820.     FHandle := CopyEnhMetafile(AData, nil);
  3821.     GetEnhMetaFileHeader(FHandle, sizeof(EnhHeader), @EnhHeader);
  3822.     with EnhHeader.rclFrame do
  3823.     begin
  3824.       FWidth := Right - Left;
  3825.       FHeight := Bottom - Top;
  3826.     end;
  3827.     FInch := 0;
  3828.   end;
  3829.   Enhanced := True;
  3830.   Changed(Self);
  3831. end;
  3832.  
  3833. procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  3834.   var APalette: HPALETTE);
  3835. begin
  3836.   if FImage = nil then Exit;
  3837.   AFormat := CF_ENHMETAFILE;
  3838.   APalette := 0;
  3839.   AData := CopyEnhMetaFile(FImage.FHandle, nil);
  3840. end;
  3841.  
  3842. var
  3843.   BitmapCanvasList: TList = nil;
  3844.  
  3845. { TBitmapCanvas }
  3846. { Create a canvas that gets its DC from the memory DC cache }
  3847. type
  3848.   TBitmapCanvas = class(TCanvas)
  3849.   private
  3850.     FBitmap: TBitmap;
  3851.     FOldBitmap: HBITMAP;
  3852.     FOldPalette: HPALETTE;
  3853.     procedure FreeContext;
  3854.   protected
  3855.     procedure CreateHandle; override;
  3856.   public
  3857.     constructor Create(ABitmap: TBitmap);
  3858.     destructor Destroy; override;
  3859.   end;
  3860.  
  3861. procedure FreeMemoryContexts;
  3862. begin
  3863.   while BitmapCanvasList.Count > 0 do
  3864.     TBitmapCanvas(BitmapCanvasList[0]).FreeContext;
  3865. end;
  3866.  
  3867. procedure DeselectBitmap(AHandle: HBITMAP);
  3868. var
  3869.   I: Integer;
  3870. begin
  3871.   for I := BitmapCanvasList.Count - 1 downto 0 do
  3872.     with TBitmapCanvas(BitmapCanvasList[I]) do
  3873.       if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
  3874.         FreeContext;
  3875. end;
  3876.  
  3877. constructor TBitmapCanvas.Create(ABitmap: TBitmap);
  3878. begin
  3879.   inherited Create;
  3880.   FBitmap := ABitmap;
  3881. end;
  3882.  
  3883. destructor TBitmapCanvas.Destroy;
  3884. begin
  3885.   FreeContext;
  3886.   inherited Destroy;
  3887. end;
  3888.  
  3889. procedure TBitmapCanvas.FreeContext;
  3890. var
  3891.   H: HBITMAP;
  3892. begin
  3893.   if FHandle <> 0 then
  3894.   begin
  3895.     if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
  3896.     if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
  3897.     H := FHandle;
  3898.     Handle := 0;
  3899.     DeleteDC(H);
  3900.     BitmapCanvasList.Remove(Self);
  3901.   end;
  3902. end;
  3903.  
  3904. procedure TBitmapCanvas.CreateHandle;
  3905. var
  3906.   H: HBITMAP;
  3907. begin
  3908.   if FBitmap <> nil then
  3909.   begin
  3910.     FBitmap.HandleNeeded;
  3911.     DeselectBitmap(FBitmap.FImage.FHandle);
  3912.     H := CreateCompatibleDC(0);
  3913.     if FBitmap.FImage.FHandle <> 0 then
  3914.       FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
  3915.       FOldBitmap := 0;
  3916.     if FBitmap.FImage.FPalette <> 0 then
  3917.     begin
  3918.       FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
  3919.       RealizePalette(H);
  3920.     end
  3921.     else
  3922.       FOldPalette := 0;
  3923.     Handle := H;
  3924.     BitmapCanvasList.Add(Self);
  3925.   end;
  3926. end;
  3927.  
  3928. { TInternalImage }
  3929.  
  3930. procedure TInternalImage.Reference;
  3931. begin
  3932.   Inc(FRefCount);
  3933. end;
  3934.  
  3935. procedure TInternalImage.Release;
  3936. begin
  3937.   if Pointer(Self) <> nil then
  3938.   begin
  3939.     Dec(FRefCount);
  3940.     if FRefCount = 0 then
  3941.     begin
  3942.       FMemoryImage.Free;
  3943.       FreeHandle;
  3944.       Free;
  3945.     end;
  3946.   end;
  3947. end;
  3948.  
  3949. { TBitmapImage }
  3950.  
  3951. procedure TBitmapImage.FreeHandle;
  3952. begin
  3953.   if FHandle <> 0 then
  3954.   begin
  3955.     DeselectBitmap(FHandle);
  3956.     DeleteObject(FHandle);
  3957.   end;
  3958.   if FPalette <> 0 then DeleteObject(FPalette);
  3959.   FHandle := 0;
  3960.   FPalette := 0;
  3961. end;
  3962.  
  3963. { TBitmap }
  3964.  
  3965. function CopyBitmap(Handle: HBITMAP; Palette: HPALETTE; NewWidth,
  3966.   NewHeight: Integer; Canvas: TCanvas; Monochrome: Boolean): HBITMAP;
  3967. var
  3968.   OldScr, NewScr: HBITMAP;
  3969.   ScreenDC, NewImageDC, OldImageDC: HDC;
  3970. begin
  3971.   Result := 0;
  3972.   if (Handle = 0) and ((NewWidth = 0) or (NewHeight = 0)) then Exit;
  3973.   ScreenDC := GetDC(0);
  3974.   NewImageDC := CreateCompatibleDC(ScreenDC);
  3975.   try
  3976.     if Monochrome then
  3977.       Result := CreateBitmap(NewWidth, NewHeight, 1, 1, nil)
  3978.     else
  3979.       Result := CreateCompatibleBitmap(ScreenDC, NewWidth, NewHeight);
  3980.     if Result = 0 then OutOfResources;
  3981.     NewScr := SelectObject(NewImageDC, Result);
  3982.     try
  3983.       if Canvas <> nil then
  3984.       begin
  3985.         FillRect(NewImageDC, Rect(0, 0, NewWidth, NewHeight),
  3986.           Canvas.Brush.Handle);
  3987.         SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
  3988.         SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
  3989.       end
  3990.       else
  3991.         PatBlt(NewImageDC, 0, 0, NewWidth, NewHeight, WHITENESS);
  3992.       if Handle <> 0 then
  3993.       begin
  3994.         OldImageDC := CreateCompatibleDC(ScreenDC);
  3995.         if OldImageDC = 0 then OutOfResources;
  3996.         try
  3997.           DeselectBitmap(Handle);
  3998.           OldScr := SelectObject(OldImageDC, Handle);
  3999.           if Palette <> 0 then
  4000.           begin
  4001.             SelectPalette(OldImageDC, Palette, True);
  4002.             RealizePalette(OldImageDC);
  4003.             SelectPalette(NewImageDC, Palette, True);
  4004.             RealizePalette(NewImageDC);
  4005.           end;
  4006.           if Canvas <> nil then
  4007.           begin
  4008.             SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
  4009.             SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
  4010.           end;
  4011.           BitBlt(NewImageDC, 0, 0, NewWidth, NewHeight, OldImageDC, 0, 0, SRCCOPY);
  4012.           SelectObject(OldImageDC, OldScr);
  4013.         finally
  4014.           DeleteDC(OldImageDC);
  4015.         end;
  4016.       end;
  4017.     except
  4018.       SelectObject(NewImageDC, NewScr);
  4019.       DeleteObject(Result);
  4020.       raise;
  4021.     end;
  4022.   finally
  4023.     DeleteDC(NewImageDC);
  4024.     ReleaseDC(0, ScreenDC);
  4025.   end;
  4026. end;
  4027.  
  4028. function CopyPalette(Palette: HPALETTE): HPALETTE;
  4029. var
  4030.   PaletteSize: Integer;
  4031.   LogSize: Integer;
  4032.   LogPalette: PLogPalette;
  4033. begin
  4034.   Result := 0;
  4035.   if Palette = 0 then Exit;
  4036.   PaletteSize := 0;
  4037.   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  4038.   if PaletteSize = 0 then Exit;
  4039.   LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  4040.   GetMem(LogPalette, LogSize);
  4041.   try
  4042.     with LogPalette^ do
  4043.     begin
  4044.       palVersion := $0300;
  4045.       palNumEntries := PaletteSize;
  4046.       GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  4047.     end;
  4048.     Result := CreatePalette(LogPalette^);
  4049.   finally
  4050.     FreeMem(LogPalette, LogSize);
  4051.   end;
  4052. end;
  4053.  
  4054. constructor TBitmap.Create;
  4055. begin
  4056.   inherited Create;
  4057.   FImage := TBitmapImage.Create;
  4058.   FImage.Reference;
  4059. end;
  4060.  
  4061. destructor TBitmap.Destroy;
  4062. begin
  4063.   FImage.Release;
  4064.   FCanvas.Free;
  4065.   inherited Destroy;
  4066. end;
  4067.  
  4068. procedure TBitmap.Assign(Source: TPersistent);
  4069. begin
  4070.   if (Source = nil) or (Source is TBitmap) then
  4071.   begin
  4072.     if Source <> nil then
  4073.     begin
  4074.       TBitmap(Source).FImage.Reference;
  4075.       FImage.Release;
  4076.       FImage := TBitmap(Source).FImage;
  4077.     end else
  4078.       NewImage(0, 0, 0, 0, False, nil, dtNone, nil, nil);
  4079.     Changed(Self);
  4080.     Exit;
  4081.   end;
  4082.   inherited Assign(Source);
  4083. end;
  4084.  
  4085. procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE;
  4086.   AWidth, AHeight: Integer; AMonochrome: Boolean);
  4087. begin
  4088.   FreeContext;
  4089.   AHandle := CopyBitmap(AHandle, APalette, AWidth, AHeight, FCanvas, AMonochrome);
  4090.   try
  4091.     APalette := CopyPalette(APalette);
  4092.     try
  4093.       NewImage(AHandle, APalette, AWidth, AHeight, AMonochrome, nil, dtNone, nil, nil);
  4094.     except
  4095.       DeleteObject(APalette);
  4096.       raise;
  4097.     end;
  4098.   except
  4099.     DeleteObject(AHandle);
  4100.     raise;
  4101.   end;
  4102. end;
  4103.  
  4104. { Called by the FCanvas whenever an operation is going to be performed on the
  4105.   bitmap that would modify it.  Since modifications should only affect this
  4106.   TBitmap, the handle needs to be 'cloned' if it is being refered to by more
  4107.   than one TBitmap }
  4108. procedure TBitmap.Changing(Sender: TObject);
  4109. begin
  4110.   FreeImage;
  4111. end;
  4112.  
  4113. procedure TBitmap.Dormant;
  4114. begin
  4115.   MemoryImageNeeded;
  4116.   FImage.FreeHandle;
  4117. end;
  4118.  
  4119. procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
  4120. var
  4121.   OldPalette: HPalette;
  4122.   UseHandle: Boolean;
  4123.   RestorePalette: Boolean;
  4124. begin
  4125.   if not Monochrome then SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
  4126.   UseHandle := (Assigned(FCanvas) and (FImage.FHandle <> 0)) or
  4127.     ((GetDeviceCaps(ACanvas.Handle, RASTERCAPS) and RC_STRETCHDIB) = 0) or
  4128.     (FImage.FDIBType <> dtWin) or (FImage.FMemoryImage = nil) or
  4129.     (FImage.FMemoryImage.Size = 0);
  4130.  
  4131.   with Rect, FImage do
  4132.   begin
  4133.     ACanvas.RequiredState(csAllValid);
  4134.     PaletteNeeded;
  4135.     OldPalette := 0;
  4136.     RestorePalette := False;
  4137.     if FPalette <> 0 then
  4138.     begin
  4139.       OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
  4140.       RealizePalette(ACanvas.FHandle);
  4141.       RestorePalette := True;
  4142.     end;
  4143.     try
  4144.       if UseHandle then
  4145.       begin
  4146.         Canvas.RequiredState(csAllValid);
  4147.         StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
  4148.           Canvas.FHandle, 0, 0, FWidth, FHeight, ACanvas.CopyMode);
  4149.       end
  4150.       else   { Draw without requiring a bitmap handle and memory dc }
  4151.         StretchDIBits(ACanvas.FHandle, Left, Top, Right-Left, Bottom - Top,
  4152.           0, 0, FWidth, FHeight, FDIBBits, PBitmapInfo(FDIBHeader)^,
  4153.           DIB_RGB_COLORS, ACanvas.CopyMode);
  4154.     finally
  4155.       if RestorePalette then
  4156.         SelectPalette(ACanvas.FHandle, OldPalette, True);
  4157.     end;
  4158.   end;
  4159. end;
  4160.  
  4161. procedure TBitmap.FreeImage;
  4162. begin
  4163.   with FImage do
  4164.     if FRefCount > 1 then
  4165.       CopyImage(FHandle, FPalette, FWidth, FHeight, FMonochrome)
  4166.     else
  4167.     begin
  4168.       FMemoryImage.Free;
  4169.       FMemoryImage := nil;
  4170.       FDIBHeader := nil;
  4171.       FDIBBits := nil;
  4172.       FDIBType := dtNone;
  4173.     end;
  4174. end;
  4175.  
  4176. function TBitmap.GetEmpty;
  4177. begin
  4178.   with FImage do
  4179.     Result := (FHandle = 0) and (FMemoryImage = nil);
  4180. end;
  4181.  
  4182. function TBitmap.GetCanvas: TCanvas;
  4183. begin
  4184.   if FCanvas = nil then
  4185.   begin
  4186.     HandleNeeded;
  4187.     FCanvas := TBitmapCanvas.Create(Self);
  4188.     FCanvas.OnChange := Changed;
  4189.     FCanvas.OnChanging := Changing;
  4190.   end;
  4191.   Result := FCanvas;
  4192. end;
  4193.  
  4194. { Since the user might modify the contents of the HBITMAP it must not be
  4195.   shared by another TBitmap when given to the user nor should it be selected
  4196.   into a DC. }
  4197. function TBitmap.GetHandle: HBITMAP;
  4198. begin
  4199.   FreeContext;
  4200.   HandleNeeded;
  4201.   Changing(Self);
  4202.   Result := FImage.FHandle;
  4203. end;
  4204.  
  4205. function TBitmap.GetHeight: Integer;
  4206. begin
  4207.   Result := FImage.FHeight;
  4208. end;
  4209.  
  4210. function TBitmap.GetMonochrome: Boolean;
  4211. begin
  4212.   Result := FImage.FMonochrome;
  4213. end;
  4214.  
  4215. function TBitmap.GetPalette: HPALETTE;
  4216. begin
  4217.   PaletteNeeded;
  4218.   Result := FImage.FPalette;
  4219. end;
  4220.  
  4221. function TBitmap.GetTransparentColor: TColor;
  4222. begin
  4223.   if Monochrome then
  4224.     Result := clWhite else
  4225.     Result := Canvas.Pixels[0, Height - 1];
  4226.   Result := Result or $02000000;
  4227. end;
  4228.  
  4229. function TBitmap.GetWidth: Integer;
  4230. begin
  4231.   Result := FImage.FWidth;
  4232. end;
  4233.  
  4234. procedure TBitmap.FreeContext;
  4235. begin
  4236.   if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
  4237. end;
  4238.  
  4239. procedure TBitmap.HandleNeeded;
  4240. begin
  4241.   with FImage do
  4242.   begin
  4243.     if FHandle <> 0 then Exit;
  4244.     if FMemoryImage = nil then Exit;
  4245.     FMemoryImage.Position := 0;
  4246.     ReadDIB(FMemoryImage, FHandle, FPalette, FMemoryImage.Size);
  4247.   end;
  4248. end;
  4249.  
  4250. procedure TBitmap.MemoryImageNeeded;
  4251. var
  4252.   Image: TMemoryStream;
  4253.   Header, Bits: Pointer;
  4254. begin
  4255.   with FImage do
  4256.   begin
  4257.     if FMemoryImage = nil then
  4258.     begin
  4259.       Image := TMemoryStream.Create;
  4260.       try
  4261.         if FHandle <> 0 then
  4262.           DIBFromBit(Image, FHandle, FPalette, 0, Header, Bits);
  4263.         Image.Position := 0;
  4264.       except
  4265.         Image.Free;
  4266.         raise;
  4267.       end;
  4268.       FMemoryImage := Image;
  4269.       FDIBHeader := Header;
  4270.       FDIBBits := Bits;
  4271.       case PLongint(FDIBHeader)^ of
  4272.         sizeof(TBitmapInfoHeader): FDIBType := dtWin;
  4273.         sizeof(TBitmapCoreHeader): FDIBType := dtPM;
  4274.       else
  4275.         FDIBType := dtNone;
  4276.       end;
  4277.     end;
  4278.   end;
  4279. end;
  4280.  
  4281. procedure TBitmap.PaletteNeeded;
  4282. begin
  4283.   if FIgnorePalette then Exit;
  4284.   with FImage do
  4285.     if FPalette = 0 then
  4286.       case FDIBType of
  4287.         dtWin: FPalette := PaletteFromW3DIB(PBitmapInfo(FDIBHeader)^);
  4288.         dtPM: FPalette := PaletteFromPM1DIB(PBitmapCoreInfo(FDIBHeader)^);
  4289.       end;
  4290. end;
  4291.  
  4292. procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  4293.   APalette: HPALETTE);
  4294. var
  4295.   ABitmap: HBITMAP;
  4296.   BitmapInfo: Windows.TBitmap;
  4297. begin
  4298.   if (AFormat <> CF_BITMAP) or (AData = 0) then
  4299.     InvalidGraphic(SUnknownClipboardFormat);
  4300.   FreeContext;
  4301.   GetObject(AData, SizeOf(BitmapInfo), @BitmapInfo);
  4302.   ABitmap := CopyBitmap(AData, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
  4303.     nil, (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1));
  4304.   try
  4305.     APalette := CopyPalette(APalette);
  4306.     try
  4307.       NewImage(ABitmap, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
  4308.         (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1), nil,
  4309.         dtNone, nil, nil);
  4310.     except
  4311.       DeleteObject(APalette);
  4312.       raise;
  4313.     end;
  4314.   except
  4315.     DeleteObject(ABitmap);
  4316.     raise;
  4317.   end;
  4318.   Changed(Self);
  4319. end;
  4320.  
  4321. procedure TBitmap.LoadFromStream(Stream: TStream);
  4322. begin
  4323.   ReadStream(Stream.Size - Stream.Position, Stream);
  4324.   Changed(Self);
  4325. end;
  4326.  
  4327. procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
  4328. var
  4329.   Stream: TCustomMemoryStream;
  4330. begin
  4331.   Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  4332.   try
  4333.     ReadStreamDIB(Stream);
  4334.   except
  4335.     Stream.Free;
  4336.     raise;
  4337.   end;
  4338.   Changed(Self);
  4339. end;
  4340.  
  4341. procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
  4342. var
  4343.   Stream: TCustomMemoryStream;
  4344. begin
  4345.   Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  4346.   try
  4347.     ReadStreamDIB(Stream);
  4348.   except
  4349.     Stream.Free;
  4350.     raise;
  4351.   end;
  4352.   Changed(Self);
  4353. end;
  4354.  
  4355. procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  4356.   NewWidth, NewHeight: Integer; NewMonochrome: Boolean; NewImage: TCustomMemoryStream;
  4357.   NewDIBType: TDIBType; NewDIBHeader, NewDIBBits: Pointer);
  4358. var
  4359.   Image: TBitmapImage;
  4360. begin
  4361.   Image := TBitmapImage.Create;
  4362.   with Image do
  4363.   try
  4364.     FHandle := NewHandle;
  4365.     FPalette := NewPalette;
  4366.     FWidth := NewWidth;
  4367.     FHeight := NewHeight;
  4368.     FMonochrome := NewMonochrome;
  4369.     FMemoryImage := NewImage;
  4370.     FDIBType := NewDIBType;
  4371.     FDIBHeader := NewDIBHeader;
  4372.     FDIBBits := NewDIBBits;
  4373.   except
  4374.     Image.Free;
  4375.     raise;
  4376.   end;
  4377.   FImage.Release;
  4378.   FImage := Image;
  4379.   FImage.Reference;
  4380. end;
  4381.  
  4382. procedure TBitmap.ReadData(Stream: TStream);
  4383. var
  4384.   Size: Longint;
  4385. begin
  4386.   Stream.Read(Size, SizeOf(Size));
  4387.   ReadStream(Size, Stream);
  4388.   Changed(Self);
  4389. end;
  4390.  
  4391. procedure TBitmap.ReadStream(Size: Longint; Stream: TStream);
  4392. var
  4393.   Bmf: TBitmapFileHeader;
  4394.   Image: TMemoryStream;
  4395. begin
  4396.   FreeContext;
  4397.   if Size = 0 then
  4398.     NewImage(0, 0, 0, 0, False, nil, dtNone, nil, nil)
  4399.   else
  4400.   begin
  4401.     Stream.ReadBuffer(Bmf, SizeOf(Bmf));
  4402.     if Bmf.bfType <> $4D42 then InvalidBitmap;
  4403.     Image := TMemoryStream.Create;
  4404.     try
  4405.       Image.SetSize(Size - sizeof(BMF));
  4406.       Stream.ReadBuffer(Image.Memory^, Size - sizeof(BMF));
  4407.       ReadStreamDIB(Image);
  4408.     except
  4409.       Image.Free;
  4410.       raise;
  4411.     end;
  4412.   end;
  4413. end;
  4414.  
  4415. procedure TBitmap.ReadStreamDIB(Image: TCustomMemoryStream);
  4416. var
  4417.   BC: TBitmapCoreHeader;
  4418.   BI: TBitmapInfoHeader;
  4419.   IWidth, IHeight: Integer;
  4420.   IMonochrome: Boolean;
  4421.   IDIBType: TDIBType;
  4422.   IDIBHeader, IDIBBits: Pointer;
  4423.   Size: Integer;
  4424. begin
  4425.   IDIBHeader := Image.Memory;
  4426.   Image.Read(Size, SizeOf(Size));
  4427.   Image.Seek(-SizeOf(Size), 1);
  4428.   if Size = SizeOf(BC) then
  4429.   begin
  4430.     Image.Read(BC, SizeOf(BC));
  4431.     IHeight := BC.bcHeight;
  4432.     IWidth := BC.bcWidth;
  4433.     IMonochrome := (BC.bcPlanes = 1) and (BC.bcBitCount = 1);
  4434.     IDIBType := dtPM;
  4435.     IDIBBits := Pointer(Longint(IDIBHeader) + Sizeof(BC) +
  4436.       GetDInColors(BC.bcBitCount) * SizeOf(TRGBTriple));
  4437.   end
  4438.   else if Size = SizeOf(BI) then
  4439.   begin
  4440.     Image.Read(BI, SizeOf(BI));
  4441.     IHeight := BI.biHeight;
  4442.     IWidth := BI.biWidth;
  4443.     IMonochrome := (BI.biPlanes = 1) and (BI.biBitCount = 1);
  4444.     IDIBType := dtWin;
  4445.     if BI.biClrUsed = 0 then
  4446.       BI.biClrUsed := GetDInColors(BI.biBitCount);
  4447.     IDIBBits := Pointer(Longint(IDIBHeader) + sizeof(BI) +
  4448.       BI.biClrUsed * SizeOf(TRgbQuad));
  4449.   end
  4450.   else InvalidBitmap;
  4451.   Image.Position := 0;
  4452.   NewImage(0, 0, IWidth, IHeight, IMonochrome, Image, IDIBType,
  4453.     IDIBHeader, IDIBBits);
  4454. end;
  4455.  
  4456. procedure TBitmap.SetHandle(Value: HBITMAP);
  4457. var
  4458.   BitmapInfo: Windows.TBitmap;
  4459.   APalette: HPALETTE;
  4460. begin
  4461.   with FImage do
  4462.     if FHandle <> Value then
  4463.     begin
  4464.       FreeContext;
  4465.       if Value <> 0 then
  4466.         GetObject(Value, SizeOf(BitmapInfo), @BitmapInfo) else
  4467.         FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
  4468.       if FRefCount = 1 then
  4469.       begin
  4470.         APalette := FPalette;
  4471.         FPalette := 0;
  4472.       end
  4473.       else
  4474.         APalette := CopyPalette(FPalette);
  4475.       try
  4476.         NewImage(Value, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
  4477.           (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1), nil,
  4478.           dtNone, nil, nil);
  4479.       except
  4480.         DeleteObject(APalette);
  4481.         raise;
  4482.       end;
  4483.       Changed(Self);
  4484.     end;
  4485. end;
  4486.  
  4487. procedure TBitmap.SetPalette(Value: HPALETTE);
  4488. var
  4489.   AHandle: HBITMAP;
  4490. begin
  4491.   with FImage do
  4492.     if FPalette <> Value then
  4493.     begin
  4494.       FreeContext;
  4495.       HandleNeeded;
  4496.       if FRefCount = 1 then
  4497.       begin
  4498.         AHandle := FHandle;
  4499.         FHandle := 0;
  4500.       end
  4501.       else
  4502.         AHandle := CopyBitmap(FHandle, FPalette, FWidth, FHeight, nil, FMonochrome);
  4503.       try
  4504.         NewImage(AHandle, Value, FWidth, FHeight, FMonochrome, nil, dtNone, nil, nil);
  4505.       except
  4506.         DeleteObject(AHandle);
  4507.         raise;
  4508.       end;
  4509.       Changed(Self);
  4510.     end;
  4511. end;
  4512.  
  4513. procedure TBitmap.SetHeight(Value: Integer);
  4514. begin
  4515.   with FImage do
  4516.     if FHeight <> Value then
  4517.     begin
  4518.       CopyImage(FHandle, FPalette, FWidth, Value, FMonochrome);
  4519.       Changed(Self);
  4520.     end;
  4521. end;
  4522.  
  4523. procedure TBitmap.SetMonochrome(Value: Boolean);
  4524. begin
  4525.   with FImage do
  4526.     if Value <> FMonochrome then
  4527.     begin
  4528.       CopyImage(FHandle, FPalette, FWidth, FHeight, Value);
  4529.       Changed(Self);
  4530.     end;
  4531. end;
  4532.  
  4533. procedure TBitmap.SetWidth(Value: Integer);
  4534. begin
  4535.   with FImage do
  4536.     if FWidth <> Value then
  4537.     begin
  4538.       CopyImage(FHandle, FPalette, Value, FHeight, FMonochrome);
  4539.       Changed(Self);
  4540.     end;
  4541. end;
  4542.  
  4543. procedure TBitmap.WriteData(Stream: TStream);
  4544. begin
  4545.   WriteStream(Stream, True);
  4546. end;
  4547.  
  4548. procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
  4549. var
  4550.   Size: Longint;
  4551.   BMF: TBitmapFileHeader;
  4552. begin
  4553.   with FImage do
  4554.   begin
  4555.     MemoryImageNeeded;
  4556.     Size := FMemoryImage.Size;
  4557.     if Size <> 0 then Inc(Size, sizeof(BMF));
  4558.     if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
  4559.     if Size <> 0 then
  4560.     begin
  4561.       FillChar(BMF, sizeof(BMF), 0);
  4562.       BMF.bfType := $4D42;
  4563.       BMF.bfSize := Size;
  4564.       BMF.bfOffBits := Longint(FDIBBits) - Longint(FDIBHeader) + sizeof(BMF);
  4565.       Stream.WriteBuffer(BMF, Sizeof(BMF));
  4566.       Stream.WriteBuffer(FMemoryImage.Memory^, FMemoryImage.Size);
  4567.     end;
  4568.   end;
  4569. end;
  4570.  
  4571. function TBitmap.ReleaseHandle: HBITMAP;
  4572. begin
  4573.   HandleNeeded;
  4574.   Changing(Self);
  4575.   Result := FImage.FHandle;
  4576.   FImage.FHandle := 0;
  4577. end;
  4578.  
  4579. function TBitmap.ReleasePalette: HPALETTE;
  4580. begin
  4581.   HandleNeeded;
  4582.   Changing(Self);
  4583.   Result := FImage.FPalette;
  4584.   FImage.FPalette := 0;
  4585. end;
  4586.  
  4587. procedure TBitmap.SaveToStream(Stream: TStream);
  4588. begin
  4589.   WriteStream(Stream, False);
  4590. end;
  4591.  
  4592. procedure TBitmap.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  4593.   var APalette: HPALETTE);
  4594. begin
  4595.   Format := CF_BITMAP;
  4596.   HandleNeeded;
  4597.   with FImage do
  4598.     Data := CopyBitmap(FHandle, FPalette, FWidth, FHeight, FCanvas, FMonochrome);
  4599.   try
  4600.     APalette := CopyPalette(FImage.FPalette);
  4601.   except
  4602.     DeleteObject(Data);
  4603.     raise;
  4604.   end;
  4605. end;
  4606.  
  4607. { TIconImage }
  4608.  
  4609. procedure TIconImage.FreeHandle;
  4610. begin
  4611.   if FHandle <> 0 then DestroyIcon(FHandle);
  4612.   FHandle := 0;
  4613. end;
  4614.  
  4615. { TIcon }
  4616.  
  4617. constructor TIcon.Create;
  4618. begin
  4619.   inherited Create;
  4620.   FImage := TIconImage.Create;
  4621.   FImage.Reference;
  4622. end;
  4623.  
  4624. destructor TIcon.Destroy;
  4625. begin
  4626.   FImage.Release;
  4627.   inherited Destroy;
  4628. end;
  4629.  
  4630. procedure TIcon.Assign(Source: TPersistent);
  4631. begin
  4632.   if (Source = nil) or (Source is TIcon) then
  4633.   begin
  4634.     if Source <> nil then
  4635.     begin
  4636.       TIcon(Source).FImage.Reference;
  4637.       FImage.Release;
  4638.       FImage := TIcon(Source).FImage;
  4639.     end else
  4640.       NewImage(0, nil);
  4641.     Changed(Self);
  4642.     Exit;
  4643.   end;
  4644.   inherited Assign(Source);
  4645. end;
  4646.  
  4647. procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
  4648. begin
  4649.   with Rect.TopLeft do
  4650.   begin
  4651.     ACanvas.RequiredState([csHandleValid]);
  4652.     DrawIcon(ACanvas.FHandle, X, Y, Handle);
  4653.   end;
  4654. end;
  4655.  
  4656. function TIcon.GetEmpty: Boolean;
  4657. begin
  4658.   with FImage do
  4659.     Result := (FHandle = 0) and (FMemoryImage = nil);
  4660. end;
  4661.  
  4662. function TIcon.GetHandle: HICON;
  4663. begin
  4664.   HandleNeeded;
  4665.   Result := FImage.FHandle;
  4666. end;
  4667.  
  4668. function TIcon.GetHeight: Integer;
  4669. begin
  4670.   Result := GetSystemMetrics(SM_CYICON);
  4671. end;
  4672.  
  4673. function TIcon.GetWidth: Integer;
  4674. begin
  4675.   Result := GetSystemMetrics(SM_CXICON);
  4676. end;
  4677.  
  4678. procedure TIcon.HandleNeeded;
  4679. var
  4680.   CI: TCursorOrIcon;
  4681.   NewHandle: HICON;
  4682. begin
  4683.   with FImage do
  4684.   begin
  4685.     if FHandle <> 0 then Exit;
  4686.     if FMemoryImage = nil then Exit;
  4687.     FMemoryImage.Position := 0;
  4688.     FMemoryImage.ReadBuffer(CI, SizeOf(CI));
  4689.     case CI.wType of
  4690.       RC3_STOCKICON: NewHandle := StockIcon;
  4691.       RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI));
  4692.     else
  4693.       InvalidIcon;
  4694.     end;
  4695.     FHandle := NewHandle;
  4696.   end;
  4697. end;
  4698.  
  4699. procedure TIcon.ImageNeeded;
  4700. var
  4701.   Image: TMemoryStream;
  4702.   CI: TCursorOrIcon;
  4703. begin
  4704.   with FImage do
  4705.   begin
  4706.     if FMemoryImage <> nil then Exit;
  4707.     if FHandle = 0 then InvalidIcon;
  4708.     Image := TMemoryStream.Create;
  4709.     try
  4710.       if GetHandle = StockIcon then
  4711.       begin
  4712.         FillChar(CI, SizeOf(CI), 0);
  4713.         Image.WriteBuffer(CI, SizeOf(CI));
  4714.       end
  4715.       else
  4716.         WriteIcon(Image, Handle, False);
  4717.     except
  4718.       Image.Free;
  4719.       raise;
  4720.     end;
  4721.     FMemoryImage := Image;
  4722.   end;
  4723. end;
  4724.  
  4725. procedure TIcon.LoadFromStream(Stream: TStream);
  4726. var
  4727.   Image: TMemoryStream;
  4728.   CI: TCursorOrIcon;
  4729. begin
  4730.   Image := TMemoryStream.Create;
  4731.   try
  4732.     Image.SetSize(Stream.Size - Stream.Position);
  4733.     Stream.ReadBuffer(Image.Memory^, Image.Size);
  4734.     Image.ReadBuffer(CI, SizeOf(CI));
  4735.     if not (CI.wType in [RC3_STOCKICON, RC3_ICON]) then InvalidIcon;
  4736.     NewImage(0, Image);
  4737.   except
  4738.     Image.Free;
  4739.     raise;
  4740.   end;
  4741.   Changed(Self);
  4742. end;
  4743.  
  4744. procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  4745. var
  4746.   Image: TIconImage;
  4747. begin
  4748.   Image := TIconImage.Create;
  4749.   try
  4750.     Image.FHandle := NewHandle;
  4751.     Image.FMemoryImage := NewImage;
  4752.   except
  4753.     Image.Free;
  4754.     raise;
  4755.   end;
  4756.   Image.Reference;
  4757.   FImage.Release;
  4758.   FImage := Image;
  4759. end;
  4760.  
  4761. function TIcon.ReleaseHandle: HICON;
  4762. begin
  4763.   with FImage do
  4764.   begin
  4765.     if FRefCount > 1 then NewImage(CopyIcon(FHandle), nil);
  4766.     Result := FHandle;
  4767.     FHandle := 0;
  4768.   end;
  4769.   Changed(Self);
  4770. end;
  4771.  
  4772. procedure TIcon.SetHandle(Value: HICON);
  4773. begin
  4774.   NewImage(Value, nil);
  4775.   Changed(Self);
  4776. end;
  4777.  
  4778. procedure TIcon.SetHeight(Value: Integer);
  4779. begin
  4780.   InvalidOperation(SChangeIconSize);
  4781. end;
  4782.  
  4783. procedure TIcon.SetWidth(Value: Integer);
  4784. begin
  4785.   InvalidOperation(SChangeIconSize);
  4786. end;
  4787.  
  4788. procedure TIcon.SaveToStream(Stream: TStream);
  4789. begin
  4790.   ImageNeeded;
  4791.   with FImage.FMemoryImage do Stream.WriteBuffer(Memory^, Size);
  4792. end;
  4793.  
  4794. procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  4795.   APalette: HPALETTE);
  4796. begin
  4797.   InvalidOperation(SIconToClipboard);
  4798. end;
  4799.  
  4800.  
  4801. procedure TIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  4802.   var APalette: HPALETTE);
  4803. begin
  4804.   InvalidOperation(SIconToClipboard);
  4805. end;
  4806.  
  4807. function GraphicFilter(GraphicClass: TGraphicClass): string;
  4808. var
  4809.   Graphic: PFileFormat;
  4810.   Count: Integer;
  4811.   Filters: string;
  4812. begin
  4813.   Result := '';
  4814.   Filters := '';
  4815.   Count := 0;
  4816.   Graphic := FileFormatList;
  4817.   while Graphic <> nil do
  4818.   begin
  4819.     if Graphic^.GraphicClass.InheritsFrom(GraphicClass) then
  4820.       with Graphic^ do
  4821.       begin
  4822.         if Count <> 0 then
  4823.         begin
  4824.           Result := Result + '|';
  4825.           Filters := Filters + ';';
  4826.         end;
  4827.         if (Description = '') and (DescResID <> 0) then
  4828.           Description := LoadStr(DescResID);
  4829.         FmtStr(Result, '%s%s (*.%s)|*.%2:s', [Result, Description, Extension]);
  4830.         FmtStr(Filters, '%s*.%s', [Filters, Extension]);
  4831.         Inc(Count);
  4832.       end;
  4833.     Graphic := Graphic^.Next;
  4834.   end;
  4835.   if Count > 1 then
  4836.     FmtStr(Result, '%s (%s)|%1:s|%s', [LoadStr(sAllFilter), Filters, Result]);
  4837. end;
  4838.  
  4839. function GraphicExtension(GraphicClass: TGraphicClass): string;
  4840. var
  4841.   Graphic: PFileFormat;
  4842. begin
  4843.   Result := '';
  4844.   Graphic := FileFormatList;
  4845.   while Graphic <> nil do
  4846.     if Graphic^.GraphicClass.InheritsFrom(GraphicClass) then
  4847.     begin
  4848.       Result := Graphic^.Extension;
  4849.       Exit;
  4850.     end
  4851.     else Graphic := Graphic^.Next;
  4852. end;
  4853.  
  4854. procedure InitGraphics;
  4855. var
  4856.   DC: HDC;
  4857. begin
  4858.   DC := GetDC(0);
  4859.   ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  4860.   ReleaseDC(0,DC);
  4861.   DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  4862.   StockPen := GetStockObject(BLACK_PEN);
  4863.   StockBrush := GetStockObject(HOLLOW_BRUSH);
  4864.   StockFont := GetStockObject(SYSTEM_FONT);
  4865.   StockIcon := LoadIcon(0, IDI_APPLICATION);
  4866.   FontManager := TResourceManager.Create(SizeOf(TFontData));
  4867.   PenManager := TResourceManager.Create(SizeOf(TPenData));
  4868.   BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  4869.   BitmapCanvasList := TList.Create;
  4870.   CanvasList := TList.Create;
  4871.   RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
  4872. end;
  4873.  
  4874. end.
  4875.