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