home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / GRAPHICS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  176.8 KB  |  6,375 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Graphics;
  11.  
  12. {$P+,S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes;
  18.  
  19. { Graphics Objects }
  20.  
  21. type
  22.   TColor = $80000000..$7FFFFFFF;
  23.  
  24. const
  25.   clScrollBar = 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.  
  51.   clBlack = TColor($000000);
  52.   clMaroon = TColor($000080);
  53.   clGreen = TColor($008000);
  54.   clOlive = TColor($008080);
  55.   clNavy = TColor($800000);
  56.   clPurple = TColor($800080);
  57.   clTeal = TColor($808000);
  58.   clGray = TColor($808080);
  59.   clSilver = TColor($C0C0C0);
  60.   clRed = TColor($0000FF);
  61.   clLime = TColor($00FF00);
  62.   clYellow = TColor($00FFFF);
  63.   clBlue = TColor($FF0000);
  64.   clFuchsia = TColor($FF00FF);
  65.   clAqua = TColor($FFFF00);
  66.   clLtGray = TColor($C0C0C0);
  67.   clDkGray = TColor($808080);
  68.   clWhite = TColor($FFFFFF);
  69.   clNone = TColor($1FFFFFFF);
  70.   clDefault = TColor($20000000);
  71.  
  72. const
  73.   cmBlackness = BLACKNESS;
  74.   cmDstInvert = DSTINVERT;
  75.   cmMergeCopy = MERGECOPY;
  76.   cmMergePaint = MERGEPAINT;
  77.   cmNotSrcCopy = NOTSRCCOPY;
  78.   cmNotSrcErase = NOTSRCERASE;
  79.   cmPatCopy = PATCOPY;
  80.   cmPatInvert = PATINVERT;
  81.   cmPatPaint = PATPAINT;
  82.   cmSrcAnd = SRCAND;
  83.   cmSrcCopy = SRCCOPY;
  84.   cmSrcErase = SRCERASE;
  85.   cmSrcInvert = SRCINVERT;
  86.   cmSrcPaint = SRCPAINT;
  87.   cmWhiteness = WHITENESS;
  88.  
  89. type
  90.   HMETAFILE = THandle;
  91.   HENHMETAFILE = THandle;
  92.  
  93.   EInvalidGraphic = class(Exception);
  94.   EInvalidGraphicOperation = class(Exception);
  95.  
  96.   TGraphic = class;
  97.   TBitmap = class;
  98.   TIcon = class;
  99.   TMetafile = class;
  100.  
  101.   TResData = record
  102.     Handle: THandle;
  103.   end;
  104.  
  105.   TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  106.   TFontStyles = set of TFontStyle;
  107.   TFontPitch = (fpDefault, fpVariable, fpFixed);
  108.   TFontName = type string;
  109.   TFontCharset = 0..255;
  110.  
  111.   TFontData = record
  112.     Handle: HFont;
  113.     Height: Integer;
  114.     Pitch: TFontPitch;
  115.     Style: TFontStyles;
  116.     Charset: TFontCharset;
  117.     Name: string[LF_FACESIZE - 1];
  118.   end;
  119.  
  120.   TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
  121.     psInsideFrame);
  122.   TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
  123.     pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
  124.     pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);
  125.  
  126.   TPenData = record
  127.     Handle: HPen;
  128.     Color: TColor;
  129.     Width: Integer;
  130.     Style: TPenStyle;
  131.   end;
  132.  
  133.   TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
  134.     bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
  135.  
  136.   TBrushData = record
  137.     Handle: HBrush;
  138.     Color: TColor;
  139.     Bitmap: TBitmap;
  140.     Style: TBrushStyle;
  141.   end;
  142.  
  143.   PResource = ^TResource;
  144.   TResource = record
  145.     Next: PResource;
  146.     RefCount: Integer;
  147.     Handle: THandle;
  148.     HashCode: Word;
  149.     case Integer of
  150.       0: (Data: TResData);
  151.       1: (Font: TFontData);
  152.       2: (Pen: TPenData);
  153.       3: (Brush: TBrushData);
  154.   end;
  155.  
  156.   TGraphicsObject = class(TPersistent)
  157.   private
  158.     FOnChange: TNotifyEvent;
  159.     FResource: PResource;
  160.     FOwnerLock: PRTLCriticalSection;
  161.   protected
  162.     procedure Changed; dynamic;
  163.     procedure Lock;
  164.     procedure Unlock;
  165.   public
  166.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  167.     property OwnerCriticalSection: PRTLCriticalSection read FOwnerLock write FOwnerLock;
  168.   end;
  169.  
  170.   IChangeNotifier = interface
  171.     ['{1FB62321-44A7-11D0-9E93-0020AF3D82DA}']
  172.     procedure Changed;
  173.   end;
  174.  
  175.   TFont = class(TGraphicsObject)
  176.   private
  177.     FColor: TColor;
  178.     FPixelsPerInch: Integer;
  179.     FNotify: IChangeNotifier;
  180.     procedure GetData(var FontData: TFontData);
  181.     procedure SetData(const FontData: TFontData);
  182.   protected
  183.     procedure Changed; override;
  184.     function GetHandle: HFont;
  185.     function GetHeight: Integer;
  186.     function GetName: TFontName;
  187.     function GetPitch: TFontPitch;
  188.     function GetSize: Integer;
  189.     function GetStyle: TFontStyles;
  190.     function GetCharset: TFontCharset;
  191.     procedure SetColor(Value: TColor);
  192.     procedure SetHandle(Value: HFont);
  193.     procedure SetHeight(Value: Integer);
  194.     procedure SetName(const Value: TFontName);
  195.     procedure SetPitch(Value: TFontPitch);
  196.     procedure SetSize(Value: Integer);
  197.     procedure SetStyle(Value: TFontStyles);
  198.     procedure SetCharset(Value: TFontCharset);
  199.   public
  200.     constructor Create;
  201.     destructor Destroy; override;
  202.     procedure Assign(Source: TPersistent); override;
  203.     property FontAdapter: IChangeNotifier read FNotify write FNotify;
  204.     property Handle: HFont read GetHandle write SetHandle;
  205.     property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  206.   published
  207.     property Charset: TFontCharset read GetCharset write SetCharset;
  208.     property Color: TColor read FColor write SetColor;
  209.     property Height: Integer read GetHeight write SetHeight;
  210.     property Name: TFontName read GetName write SetName;
  211.     property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  212.     property Size: Integer read GetSize write SetSize stored False;
  213.     property Style: TFontStyles read GetStyle write SetStyle;
  214.   end;
  215.  
  216.   TPen = class(TGraphicsObject)
  217.   private
  218.     FMode: TPenMode;
  219.     procedure GetData(var PenData: TPenData);
  220.     procedure SetData(const PenData: TPenData);
  221.   protected
  222.     function GetColor: TColor;
  223.     procedure SetColor(Value: TColor);
  224.     function GetHandle: HPen;
  225.     procedure SetHandle(Value: HPen);
  226.     procedure SetMode(Value: TPenMode);
  227.     function GetStyle: TPenStyle;
  228.     procedure SetStyle(Value: TPenStyle);
  229.     function GetWidth: Integer;
  230.     procedure SetWidth(Value: Integer);
  231.   public
  232.     constructor Create;
  233.     destructor Destroy; override;
  234.     procedure Assign(Source: TPersistent); override;
  235.     property Handle: HPen read GetHandle write SetHandle;
  236.   published
  237.     property Color: TColor read GetColor write SetColor default clBlack;
  238.     property Mode: TPenMode read FMode write SetMode default pmCopy;
  239.     property Style: TPenStyle read GetStyle write SetStyle default psSolid;
  240.     property Width: Integer read GetWidth write SetWidth default 1;
  241.   end;
  242.  
  243.   TBrush = class(TGraphicsObject)
  244.   private
  245.     procedure GetData(var BrushData: TBrushData);
  246.     procedure SetData(const BrushData: TBrushData);
  247.   protected
  248.     function GetBitmap: TBitmap;
  249.     procedure SetBitmap(Value: TBitmap);
  250.     function GetColor: TColor;
  251.     procedure SetColor(Value: TColor);
  252.     function GetHandle: HBrush;
  253.     procedure SetHandle(Value: HBrush);
  254.     function GetStyle: TBrushStyle;
  255.     procedure SetStyle(Value: TBrushStyle);
  256.   public
  257.     constructor Create;
  258.     destructor Destroy; override;
  259.     procedure Assign(Source: TPersistent); override;
  260.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  261.     property Handle: HBrush read GetHandle write SetHandle;
  262.   published
  263.     property Color: TColor read GetColor write SetColor default clWhite;
  264.     property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  265.   end;
  266.  
  267.   TFillStyle = (fsSurface, fsBorder);
  268.   TFillMode = (fmAlternate, fmWinding);
  269.  
  270.   TCopyMode = Longint;
  271.  
  272.   TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  273.   TCanvasState = set of TCanvasStates;
  274.  
  275.   TCanvas = class(TPersistent)
  276.   private
  277.     FHandle: HDC;
  278.     State: TCanvasState;
  279.     FFont: TFont;
  280.     FPen: TPen;
  281.     FBrush: TBrush;
  282.     FPenPos: TPoint;
  283.     FCopyMode: TCopyMode;
  284.     FOnChange: TNotifyEvent;
  285.     FOnChanging: TNotifyEvent;
  286.     FLock: TRTLCriticalSection;
  287.     FLockCount: Integer;
  288.     procedure CreateBrush;
  289.     procedure CreateFont;
  290.     procedure CreatePen;
  291.     procedure BrushChanged(ABrush: TObject);
  292.     procedure DeselectHandles;
  293.     function GetClipRect: TRect;
  294.     function GetHandle: HDC;
  295.     function GetPenPos: TPoint;
  296.     function GetPixel(X, Y: Integer): TColor;
  297.     procedure FontChanged(AFont: TObject);
  298.     procedure PenChanged(APen: TObject);
  299.     procedure SetBrush(Value: TBrush);
  300.     procedure SetFont(Value: TFont);
  301.     procedure SetHandle(Value: HDC);
  302.     procedure SetPen(Value: TPen);
  303.     procedure SetPenPos(Value: TPoint);
  304.     procedure SetPixel(X, Y: Integer; Value: TColor);
  305.   protected
  306.     procedure Changed; virtual;
  307.     procedure Changing; virtual;
  308.     procedure CreateHandle; virtual;
  309.     procedure RequiredState(ReqState: TCanvasState);
  310.   public
  311.     constructor Create;
  312.     destructor Destroy; override;
  313.     procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  314.     procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  315.       const Source: TRect; Color: TColor);
  316.     procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  317.     procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
  318.       const Source: TRect);
  319.     procedure Draw(X, Y: Integer; Graphic: TGraphic);
  320.     procedure DrawFocusRect(const Rect: TRect);
  321.     procedure Ellipse(X1, Y1, X2, Y2: Integer);
  322.     procedure FillRect(const Rect: TRect);
  323.     procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
  324.     procedure FrameRect(const Rect: TRect);
  325.     procedure LineTo(X, Y: Integer);
  326.     procedure Lock;
  327.     procedure MoveTo(X, Y: Integer);
  328.     procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  329.     procedure Polygon(const Points: array of TPoint);
  330.     procedure Polyline(const Points: array of TPoint);
  331.     procedure Rectangle(X1, Y1, X2, Y2: Integer);
  332.     procedure Refresh;
  333.     procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  334.     procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
  335.     function TextExtent(const Text: string): TSize;
  336.     function TextHeight(const Text: string): Integer;
  337.     procedure TextOut(X, Y: Integer; const Text: string);
  338.     procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  339.     function TextWidth(const Text: string): Integer;
  340.     function TryLock: Boolean;
  341.     procedure Unlock;
  342.     property ClipRect: TRect read GetClipRect;
  343.     property Handle: HDC read GetHandle write SetHandle;
  344.     property LockCount: Integer read FLockCount;
  345.     property PenPos: TPoint read GetPenPos write SetPenPos;
  346.     property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
  347.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  348.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  349.   published
  350.     property Brush: TBrush read FBrush write SetBrush;
  351.     property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
  352.     property Font: TFont read FFont write SetFont;
  353.     property Pen: TPen read FPen write SetPen;
  354.   end;
  355.  
  356.   { TProgressEvent is a generic progress notification event which may be
  357.         used by TGraphic classes with computationally intensive (slow)
  358.         operations, such as loading, storing, or transforming image data.
  359.     Event params:
  360.       Stage - Indicates whether this call to the OnProgress event is to
  361.         prepare for, process, or clean up after a graphic operation.  If
  362.         OnProgress is called at all, the first call for a graphic operation
  363.         will be with Stage = psStarting, to allow the OnProgress event handler
  364.         to allocate whatever resources it needs to process subsequent progress
  365.         notifications.  After Stage = psStarting, you are guaranteed that
  366.         OnProgress will be called again with Stage = psEnding to allow you
  367.         to free those resources, even if the graphic operation is aborted by
  368.         an exception.  Zero or more calls to OnProgress with Stage = psRunning
  369.         may occur between the psStarting and psEnding calls.
  370.       PercentDone - The ratio of work done to work remaining, on a scale of
  371.         0 to 100.  Values may repeat or even regress (get smaller) in
  372.         successive calls.  PercentDone is usually only a guess, and the
  373.         guess may be dramatically altered as new information is discovered
  374.         in decoding the image.
  375.       RedrawNow - Indicates whether the graphic can be/should be redrawn
  376.         immediately.  Useful for showing successive approximations of
  377.         an image as data is available instead of waiting for all the data
  378.         to arrive before drawing anything.  Since there is no message loop
  379.         activity during graphic operations, you should call Update to force
  380.         a control to be redrawn immediately in the OnProgress event handler.
  381.         Redrawing a graphic when RedrawNow = False could corrupt the image
  382.         and/or cause exceptions.
  383.       Rect - Area of image that has changed and needs to be redrawn.
  384.       Msg - Optional text describing in one or two words what the graphic
  385.         class is currently working on.  Ex:  "Loading" "Storing"
  386.         "Reducing colors".  The Msg string can also be empty.
  387.         Msg strings should be resourced for translation,  should not
  388.         contain trailing periods, and should be used only for
  389.         display purposes.  (do not: if Msg = 'Loading' then...)
  390.   }
  391.  
  392.   TProgressStage = (psStarting, psRunning, psEnding);
  393.   TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
  394.     PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;
  395.  
  396.   { The TGraphic class is a abstract base class for dealing with graphic images
  397.     such as metafile, bitmaps, icons, and other image formats.
  398.       LoadFromFile - Read the graphic from the file system.  The old contents of
  399.         the graphic are lost.  If the file is not of the right format, an
  400.         exception will be generated.
  401.       SaveToFile - Writes the graphic to disk in the file provided.
  402.       LoadFromStream - Like LoadFromFile except source is a stream (e.g.
  403.         TBlobStream).
  404.       SaveToStream - stream analogue of SaveToFile.
  405.       LoadFromClipboardFormat - Replaces the current image with the data
  406.         provided.  If the TGraphic does not support that format it will generate
  407.         an exception.
  408.       SaveToClipboardFormats - Converts the image to a clipboard format.  If the
  409.         image does not support being translated into a clipboard format it
  410.         will generate an exception.
  411.       Height - The native, unstretched, height of the graphic.
  412.       Palette - Color palette of image.  Zero if graphic doesn't need/use palettes.
  413.       Transparent - Image does not completely cover its rectangular area
  414.       Width - The native, unstretched, width of the graphic.
  415.       OnChange - Called whenever the graphic changes
  416.       PaletteModified - Indicates in OnChange whether color palette has changed.
  417.         Stays true until whoever's responsible for realizing this new palette
  418.         (ex: TImage) sets it to False.
  419.       OnProgress - Generic progress indicator event. Propagates out to TPicture
  420.         and TImage OnProgress events.}
  421.  
  422.   TGraphic = class(TPersistent)
  423.   private
  424.     FOnChange: TNotifyEvent;
  425.     FOnProgress: TProgressEvent;
  426.     FModified: Boolean;
  427.     FTransparent: Boolean;
  428.     FPaletteModified: Boolean;
  429.     procedure SetModified(Value: Boolean);
  430.   protected
  431.     constructor Create; virtual;
  432.     procedure Changed(Sender: TObject); virtual;
  433.     procedure DefineProperties(Filer: TFiler); override;
  434.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
  435.     function Equals(Graphic: TGraphic): Boolean; virtual;
  436.     function GetEmpty: Boolean; virtual; abstract;
  437.     function GetHeight: Integer; virtual; abstract;
  438.     function GetPalette: HPALETTE; virtual;
  439.     function GetTransparent: Boolean; virtual;
  440.     function GetWidth: Integer; virtual; abstract;
  441.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  442.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  443.     procedure ReadData(Stream: TStream); virtual;
  444.     procedure SetHeight(Value: Integer); virtual; abstract;
  445.     procedure SetPalette(Value: HPALETTE); virtual;
  446.     procedure SetTransparent(Value: Boolean); virtual;
  447.     procedure SetWidth(Value: Integer); virtual; abstract;
  448.     procedure WriteData(Stream: TStream); virtual;
  449.   public
  450.     procedure LoadFromFile(const Filename: string); virtual;
  451.     procedure SaveToFile(const Filename: string); virtual;
  452.     procedure LoadFromStream(Stream: TStream); virtual; abstract;
  453.     procedure SaveToStream(Stream: TStream); virtual; abstract;
  454.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  455.       APalette: HPALETTE); virtual; abstract;
  456.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  457.       var APalette: HPALETTE); virtual; abstract;
  458.     property Empty: Boolean read GetEmpty;
  459.     property Height: Integer read GetHeight write SetHeight;
  460.     property Modified: Boolean read FModified write SetModified;
  461.     property Palette: HPALETTE read GetPalette write SetPalette;
  462.     property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
  463.     property Transparent: Boolean read GetTransparent write SetTransparent;
  464.     property Width: Integer read GetWidth write SetWidth;
  465.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  466.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  467.   end;
  468.  
  469.   TGraphicClass = class of TGraphic;
  470.  
  471.   { TPicture }
  472.   { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
  473.     graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
  474.     polymorphic. For example, if the TPicture is holding an Icon, you can
  475.     LoadFromFile a bitmap file, where if the class was TIcon you could only read
  476.     .ICO files.
  477.       LoadFromFile - Reads a picture from disk.  The TGraphic class created
  478.         determined by the file extension of the file.  If the file extension is
  479.         not recognized an exception is generated.
  480.       SaveToFile - Writes the picture to disk.
  481.       LoadFromClipboardFormat - Reads the picture from the handle provided in
  482.         the given clipboard format.  If the format is not supported, an
  483.         exception is generated.
  484.       SaveToClipboardFormats - Allocates a global handle and writes the picture
  485.         in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE
  486.         for metafiles, etc.).  Formats will contain the formats written.
  487.         Returns the number of clipboard items written to the array pointed to
  488.         by Formats and Datas or would be written if either Formats or Datas are
  489.         nil.
  490.       SupportsClipboardFormat - Returns true if the given clipboard format
  491.         is supported by LoadFromClipboardFormat.
  492.       Assign - Copys the contents of the given TPicture.  Used most often in
  493.         the implementation of TPicture properties.
  494.       RegisterFileFormat - Register a new TGraphic class for use in
  495.         LoadFromFile.
  496.       RegisterClipboardFormat - Registers a new TGraphic class for use in
  497.         LoadFromClipboardFormat.
  498.       UnRegisterGraphicClass - Removes all references to the specified TGraphic
  499.         class and all its descendents from the file format and clipboard format
  500.         internal lists.
  501.       Height - The native, unstretched, height of the picture.
  502.       Width - The native, unstretched, width of the picture.
  503.       Graphic - The TGraphic object contained by the TPicture
  504.       Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
  505.         contents are thrown away and a blank bitmap is returned.
  506.       Icon - Returns an icon.  If the contents is not already an icon, the
  507.         contents are thrown away and a blank icon is returned.
  508.       Metafile - Returns a metafile.  If the contents is not already a metafile,
  509.         the contents are thrown away and a blank metafile is returned. }
  510.   TPicture = class(TPersistent)
  511.   private
  512.     FGraphic: TGraphic;
  513.     FOnChange: TNotifyEvent;
  514.     FNotify: IChangeNotifier;
  515.     FOnProgress: TProgressEvent;
  516.     procedure ForceType(GraphicType: TGraphicClass);
  517.     function GetBitmap: TBitmap;
  518.     function GetHeight: Integer;
  519.     function GetIcon: TIcon;
  520.     function GetMetafile: TMetafile;
  521.     function GetWidth: Integer;
  522.     procedure ReadData(Stream: TStream);
  523.     procedure SetBitmap(Value: TBitmap);
  524.     procedure SetGraphic(Value: TGraphic);
  525.     procedure SetIcon(Value: TIcon);
  526.     procedure SetMetafile(Value: TMetafile);
  527.     procedure WriteData(Stream: TStream);
  528.   protected
  529.     procedure AssignTo(Dest: TPersistent); override;
  530.     procedure Changed(Sender: TObject); dynamic;
  531.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  532.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  533.     procedure DefineProperties(Filer: TFiler); override;
  534.   public
  535.     constructor Create;
  536.     destructor Destroy; override;
  537.     procedure LoadFromFile(const Filename: string);
  538.     procedure SaveToFile(const Filename: string);
  539.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  540.       APalette: HPALETTE);
  541.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  542.       var APalette: HPALETTE);
  543.     class function SupportsClipboardFormat(AFormat: Word): Boolean;
  544.     procedure Assign(Source: TPersistent); override;
  545.     class procedure RegisterFileFormat(const AExtension, ADescription: string;
  546.       AGraphicClass: TGraphicClass);
  547.     class procedure RegisterFileFormatRes(const AExtension: String;
  548.       ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  549.     class procedure RegisterClipboardFormat(AFormat: Word;
  550.       AGraphicClass: TGraphicClass);
  551.     class procedure UnregisterGraphicClass(AClass: TGraphicClass);
  552.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  553.     property Graphic: TGraphic read FGraphic write SetGraphic;
  554.     property PictureAdapter: IChangeNotifier read FNotify write FNotify;
  555.     property Height: Integer read GetHeight;
  556.     property Icon: TIcon read GetIcon write SetIcon;
  557.     property Metafile: TMetafile read GetMetafile write SetMetafile;
  558.     property Width: Integer read GetWidth;
  559.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  560.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  561.   end;
  562.  
  563.   { TMetafile }
  564.   { TMetafile is an encapsulation of the Win32 Enhanced metafile.
  565.       Handle - The metafile handle.
  566.       Enhanced - determines how the metafile will be stored on disk.
  567.         Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
  568.         Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
  569.         The in-memory format is always EMF.  WMF has very limited capabilities;
  570.         storing as WMF will lose information that would be retained by EMF.
  571.         This property is set to match the metafile type when loaded from a
  572.         stream or file.  This maintains form file compatibility with 16 bit
  573.         Delphi (If loaded as WMF, then save as WMF).
  574.       Inch - The units per inch assumed by a WMF metafile.  Used to alter
  575.         scale when writing as WMF, but otherwise this property is obsolete.
  576.         Enhanced metafiles maintain complete scale information internally.
  577.       MMWidth,
  578.       MMHeight: Width and Height in 0.01 millimeter units, the native
  579.         scale used by enhanced metafiles.  The Width and Height properties
  580.         are always in screen device pixel units; you can avoid loss of
  581.         precision in converting between device pixels and mm by setting
  582.         or reading the dimentions in mm with these two properties.
  583.       CreatedBy - Optional name of the author or application used to create
  584.         the metafile.
  585.       Description - Optional text description of the metafile.
  586.       You can set the CreatedBy and Description of a new metafile by calling
  587.       TMetafileCanvas.CreateWithComment.
  588.  
  589.     TMetafileCanvas
  590.       To create a metafile image from scratch, you must draw the image in
  591.       a metafile canvas.  When the canvas is destroyed, it transfers the
  592.       image into the metafile object provided to the canvas constructor.
  593.       After the image is drawn on the canvas and the canvas is destroyed,
  594.       the image is 'playable' in the metafile object.  Like this:
  595.  
  596.       MyMetafile := TMetafile.Create;
  597.       MyMetafile.Width := 200;
  598.       MyMetafile.Height := 200;
  599.       with TMetafileCanvas.Create(MyMetafile, 0) do
  600.       try
  601.         Brush.Color := clRed;
  602.         Ellipse(0,0,100,100);
  603.         ...
  604.       finally
  605.         Free;
  606.       end;
  607.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle  *)
  608.  
  609.       To add to an existing metafile image, create a metafile canvas
  610.       and play the source metafile into the metafile canvas.  Like this:
  611.  
  612.       (* continued from previous example, so MyMetafile contains an image *)
  613.       with TMetafileCanvas.Create(MyMetafile, 0) do
  614.       try
  615.         Draw(0,0,MyMetafile);
  616.         Brush.Color := clBlue;
  617.         Ellipse(100,100,200,200);
  618.         ...
  619.       finally
  620.         Free;
  621.       end;
  622.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle and 1 blue circle *)
  623.   }
  624.  
  625.   TMetafileCanvas = class(TCanvas)
  626.   private
  627.     FMetafile: TMetafile;
  628.   public
  629.     constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  630.     constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
  631.       const CreatedBy, Description: String);
  632.     destructor Destroy; override;
  633.   end;
  634.  
  635.   TSharedImage = class
  636.   private
  637.     FRefCount: Integer;
  638.   protected
  639.     procedure Reference;
  640.     procedure Release;
  641.     procedure FreeHandle; virtual; abstract;
  642.     property RefCount: Integer read FRefCount;
  643.   end;
  644.  
  645.   TMetafileImage = class(TSharedImage)
  646.   private
  647.     FHandle: HENHMETAFILE;
  648.     FWidth: Integer;      // FWidth and FHeight are in 0.01 mm logical pixels
  649.     FHeight: Integer;     // These are converted to device pixels in TMetafile
  650.     FPalette: HPALETTE;
  651.     FInch: Word;          // Used only when writing WMF files.
  652.     FTempWidth: Integer;  // FTempWidth and FTempHeight are in device pixels
  653.     FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
  654.   protected
  655.     procedure FreeHandle; override;
  656.   public
  657.     destructor Destroy; override;
  658.   end;
  659.  
  660.   TMetafile = class(TGraphic)
  661.   private
  662.     FImage: TMetafileImage;
  663.     FEnhanced: Boolean;
  664.     function GetAuthor: String;
  665.     function GetDesc: String;
  666.     function GetHandle: HENHMETAFILE;
  667.     function GetInch: Word;
  668.     function GetMMHeight: Integer;
  669.     function GetMMWidth: Integer;
  670.     procedure NewImage;
  671.     procedure SetHandle(Value: HENHMETAFILE);
  672.     procedure SetInch(Value: Word);
  673.     procedure SetMMHeight(Value: Integer);
  674.     procedure SetMMWidth(Value: Integer);
  675.     procedure UniqueImage;
  676.   protected
  677.     function GetEmpty: Boolean; override;
  678.     function GetHeight: Integer; override;
  679.     function GetPalette: HPALETTE; override;
  680.     function GetWidth: Integer; override;
  681.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  682.     procedure ReadData(Stream: TStream); override;
  683.     procedure ReadEMFStream(Stream: TStream);
  684.     procedure ReadWMFStream(Stream: TStream; Length: Longint);
  685.     procedure SetHeight(Value: Integer); override;
  686.     procedure SetWidth(Value: Integer); override;
  687.     function  TestEMF(Stream: TStream): Boolean;
  688.     procedure WriteData(Stream: TStream); override;
  689.     procedure WriteEMFStream(Stream: TStream);
  690.     procedure WriteWMFStream(Stream: TStream);
  691.   public
  692.     constructor Create; override;
  693.     destructor Destroy; override;
  694.     procedure Clear;
  695.     procedure LoadFromStream(Stream: TStream); override;
  696.     procedure SaveToFile(const Filename: String); override;
  697.     procedure SaveToStream(Stream: TStream); override;
  698.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  699.       APalette: HPALETTE); override;
  700.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  701.       var APalette: HPALETTE); override;
  702.     procedure Assign(Source: TPersistent); override;
  703.     function ReleaseHandle: HENHMETAFILE;
  704.     property CreatedBy: String read GetAuthor;
  705.     property Description: String read GetDesc;
  706.     property Enhanced: Boolean read FEnhanced write FEnhanced default True;
  707.     property Handle: HENHMETAFILE read GetHandle write SetHandle;
  708.     property MMWidth: Integer read GetMMWidth write SetMMWidth;
  709.     property MMHeight: Integer read GetMMHeight write SetMMHeight;
  710.     property Inch: Word read GetInch write SetInch;
  711.   end;
  712.  
  713.   { TBitmap }
  714.   { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
  715.     the palette realizing automatically as well as having a Canvas to allow
  716.     modifications to the image.  Creating copies of a TBitmap is very fast
  717.     since the handle is copied not the image.  If the image is modified, and
  718.     the handle is shared by more than one TBitmap object, the image is copied
  719.     before the modification is performed (i.e. copy on write).
  720.       Canvas - Allows drawing on the bitmap.
  721.       Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
  722.         directly should be avoided since it causes the HBITMAP to be copied if
  723.         more than one TBitmap share the handle.
  724.       Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
  725.         directly should be avoided since it causes the HPALETTE to be copied if
  726.         more than one TBitmap share the handle.
  727.       Monochrome - True if the bitmap is a monochrome bitmap }
  728.  
  729.   TBitmapImage = class(TSharedImage)
  730.   private
  731.     FHandle: HBITMAP;     // DDB or DIB handle, used for drawing
  732.     FMaskHandle: HBITMAP; // DDB handle
  733.     FPalette: HPALETTE;
  734.     FDIBHandle: HBITMAP;  // DIB handle corresponding to TDIBSection
  735.     FDIB: TDIBSection;
  736.     FOS2Format: Boolean;  // Write BMP file header, color table in OS/2 format
  737.     FHalftone: Boolean;   // FPalette is halftone; don't write to file
  738.   protected
  739.     destructor Destroy; override;
  740.     procedure FreeHandle; override;
  741.   end;
  742.  
  743.   TBitmapHandleType = (bmDIB, bmDDB);
  744.   TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
  745.   TTransparentMode = (tmAuto, tmFixed);
  746.  
  747.   TBitmap = class(TGraphic)
  748.   private
  749.     FImage: TBitmapImage;
  750.     FCanvas: TCanvas;
  751.     FIgnorePalette: Boolean;
  752.     FMaskBitsValid: Boolean;
  753.     FMaskValid: Boolean;
  754.     FTransparentColor: TColor;
  755.     FTransparentMode: TTransparentMode;
  756.     procedure Changing(Sender: TObject);
  757.     procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  758.     procedure DIBNeeded;
  759.     procedure FreeContext;
  760.     function GetCanvas: TCanvas;
  761.     function GetHandle: HBITMAP; virtual;
  762.     function GetHandleType: TBitmapHandleType;
  763.     function GetMaskHandle: HBITMAP; virtual;
  764.     function GetMonochrome: Boolean;
  765.     function GetPixelFormat: TPixelFormat;
  766.     function GetScanline(Row: Integer): Pointer;
  767.     function GetTransparentColor: TColor;
  768.     procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  769.       const NewDIB: TDIBSection; OS2Format: Boolean);
  770.     procedure ReadStream(Stream: TStream; Size: Longint);
  771.     procedure ReadDIB(Stream: TStream; ImageSize: Longint);
  772.     procedure SetHandle(Value: HBITMAP);
  773.     procedure SetHandleType(Value: TBitmapHandleType); virtual;
  774.     procedure SetMonochrome(Value: Boolean);
  775.     procedure SetPixelFormat(Value: TPixelFormat);
  776.     procedure SetTransparentColor(Value: TColor);
  777.     procedure SetTransparentMode(Value: TTransparentMode);
  778.     function TransparentColorStored: Boolean;
  779.     procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  780.   protected
  781.     procedure Changed(Sender: TObject); override;
  782.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  783.     function GetEmpty: Boolean; override;
  784.     function GetHeight: Integer; override;
  785.     function GetPalette: HPALETTE; override;
  786.     function GetWidth: Integer; override;
  787.     procedure HandleNeeded;
  788.     procedure MaskHandleNeeded;
  789.     procedure PaletteNeeded;
  790.     procedure ReadData(Stream: TStream); override;
  791.     procedure SetHeight(Value: Integer); override;
  792.     procedure SetPalette(Value: HPALETTE); override;
  793.     procedure SetWidth(Value: Integer); override;
  794.     procedure WriteData(Stream: TStream); override;
  795.   public
  796.     constructor Create; override;
  797.     destructor Destroy; override;
  798.     procedure Assign(Source: TPersistent); override;
  799.     procedure Dormant;
  800.     procedure FreeImage;
  801.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  802.       APalette: HPALETTE); override;
  803.     procedure LoadFromStream(Stream: TStream); override;
  804.     procedure LoadFromResourceName(Instance: THandle; const ResName: String);
  805.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
  806.     procedure Mask(TransparentColor: TColor);
  807.     function ReleaseHandle: HBITMAP;
  808.     function ReleaseMaskHandle: HBITMAP;
  809.     function ReleasePalette: HPALETTE;
  810.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  811.       var APalette: HPALETTE); override;
  812.     procedure SaveToStream(Stream: TStream); override;
  813.     property Canvas: TCanvas read GetCanvas;
  814.     property Handle: HBITMAP read GetHandle write SetHandle;
  815.     property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
  816.     property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
  817.     property MaskHandle: HBITMAP read GetMaskHandle;
  818.     property Monochrome: Boolean read GetMonochrome write SetMonochrome;
  819.     property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
  820.     property ScanLine[Row: Integer]: Pointer read GetScanLine;
  821.     property TransparentColor: TColor read GetTransparentColor
  822.       write SetTransparentColor stored TransparentColorStored;
  823.     property TransparentMode: TTransparentMode read FTransparentMode
  824.       write SetTransparentMode default tmAuto;
  825.   end;
  826.  
  827.   { TIcon }
  828.   { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
  829.     so calling stretch draw is not meaningful.
  830.       Handle - The HICON used by the TIcon. }
  831.  
  832.   TIconImage = class(TSharedImage)
  833.   private
  834.     FHandle: HICON;
  835.     FMemoryImage: TCustomMemoryStream;
  836.   protected
  837.     destructor Destroy; override;
  838.     procedure FreeHandle; override;
  839.   end;
  840.  
  841.   TIcon = class(TGraphic)
  842.   private
  843.     FImage: TIconImage;
  844.     function GetHandle: HICON;
  845.     procedure HandleNeeded;
  846.     procedure ImageNeeded;
  847.     procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  848.     procedure SetHandle(Value: HICON);
  849.   protected
  850.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  851.     function GetEmpty: Boolean; override;
  852.     function GetHeight: Integer; override;
  853.     function GetWidth: Integer; override;
  854.     procedure SetHeight(Value: Integer); override;
  855.     procedure SetWidth(Value: Integer); override;
  856.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  857.       APalette: HPALETTE); override;
  858.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  859.       var APalette: HPALETTE); override;
  860.   public
  861.     constructor Create; override;
  862.     destructor Destroy; override;
  863.     procedure Assign(Source: TPersistent); override;
  864.     procedure LoadFromStream(Stream: TStream); override;
  865.     function ReleaseHandle: HICON;
  866.     procedure SaveToStream(Stream: TStream); override;
  867.     property Handle: HICON read GetHandle write SetHandle;
  868.   end;
  869.  
  870. var    // New TFont instances are intialized with the values in this structure:
  871.   DefFontData: TFontData = (
  872.     Handle: 0;
  873.     Height: 0;
  874.     Pitch: fpDefault;
  875.     Style: [];
  876.     Charset : DEFAULT_CHARSET;
  877.     Name: 'MS Sans Serif');
  878.  
  879.  
  880. var
  881.   SystemPalette16: HPalette; // 16 color palette that maps to the system palette
  882.  
  883. var
  884.   DDBsOnly: Boolean = False; // True = Load all BMPs as device bitmaps.
  885.                              // Not recommended.
  886.  
  887. function GraphicFilter(GraphicClass: TGraphicClass): string;
  888. function GraphicExtension(GraphicClass: TGraphicClass): string;
  889. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  890.  
  891. function ColorToRGB(Color: TColor): Longint;
  892. function ColorToString(Color: TColor): string;
  893. function StringToColor(const S: string): TColor;
  894. procedure GetColorValues(Proc: TGetStrProc);
  895. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  896. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  897. procedure GetCharsetValues(Proc: TGetStrProc);
  898. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  899. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  900.  
  901. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  902.   var ImageSize: DWORD);
  903. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  904.  
  905. function CopyPalette(Palette: HPALETTE): HPALETTE;
  906.  
  907. procedure PaletteChanged;
  908. procedure FreeMemoryContexts;
  909.  
  910. function GetDefFontCharSet: TFontCharSet;
  911.  
  912. function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  913.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  914.   MaskY: Integer): Boolean;
  915.  
  916. function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
  917. function CreateMappedRes(Instance: THandle; ResName: PChar; const OldColors, NewColors: array of TColor): HBITMAP;
  918. function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
  919. function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  920.  
  921. implementation
  922.  
  923. { Things left out
  924.   ---------------
  925.   Regions
  926.   PatBlt
  927.   Tabbed text
  928.   Clipping regions
  929.   Coordinate transformations
  930.   Paths
  931.   Beziers }
  932.  
  933. uses Consts;
  934.  
  935. const
  936.   csAllValid = [csHandleValid..csBrushValid];
  937.  
  938. var
  939.   ScreenLogPixels: Integer;
  940.   StockPen: HPEN;
  941.   StockBrush: HBRUSH;
  942.   StockFont: HFONT;
  943.   StockIcon: HICON;
  944.   BitmapImageLock: TRTLCriticalSection;
  945.   CounterLock: TRTLCriticalSection;
  946.  
  947. procedure InternalDeletePalette(Pal: HPalette);
  948. begin
  949.   if (Pal <> 0) and (Pal <> SystemPalette16) then
  950.     DeleteObject(Pal);
  951. end;
  952.  
  953. { Resource managers }
  954.  
  955. const
  956.   ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);
  957.  
  958. type
  959.   TResourceManager = class(TObject)
  960.     ResList: PResource;
  961.     FLock: TRTLCriticalSection;
  962.     ResDataSize: Word;
  963.     constructor Create(AResDataSize: Word);
  964.     destructor Destroy; override;
  965.     function AllocResource(const ResData): PResource;
  966.     procedure FreeResource(Resource: PResource);
  967.     procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
  968.     procedure AssignResource(GraphicsObject: TGraphicsObject;
  969.       AResource: PResource);
  970.     procedure Lock;
  971.     procedure Unlock;
  972.   end;
  973.  
  974. var
  975.   FontManager: TResourceManager;
  976.   PenManager: TResourceManager;
  977.   BrushManager: TResourceManager;
  978.  
  979. function GetHashCode(const Buffer; Count: Integer): Word; assembler;
  980. asm
  981.         MOV     ECX,EDX
  982.         MOV     EDX,EAX
  983.         XOR     EAX,EAX
  984. @@1:    ROL     AX,5
  985.         XOR     AL,[EDX]
  986.         INC     EDX
  987.         DEC     ECX
  988.         JNE     @@1
  989. end;
  990.  
  991. constructor TResourceManager.Create(AResDataSize: Word);
  992. begin
  993.   ResDataSize := AResDataSize;
  994.   InitializeCriticalSection(FLock);
  995. end;
  996.  
  997. destructor TResourceManager.Destroy;
  998. begin
  999.   DeleteCriticalSection(FLock);
  1000. end;
  1001.  
  1002. procedure TResourceManager.Lock;
  1003. begin
  1004.   EnterCriticalSection(FLock);
  1005. end;
  1006.  
  1007. procedure TResourceManager.Unlock;
  1008. begin
  1009.   LeaveCriticalSection(FLock);
  1010. end;
  1011.  
  1012. function TResourceManager.AllocResource(const ResData): PResource;
  1013. var
  1014.   ResHash: Word;
  1015. begin
  1016.   ResHash := GetHashCode(ResData, ResDataSize);
  1017.   Lock;
  1018.   try
  1019.     Result := ResList;
  1020.     while (Result <> nil) and ((Result^.HashCode <> ResHash) or
  1021.       not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
  1022.       Result := Result^.Next;
  1023.     if Result = nil then
  1024.     begin
  1025.       GetMem(Result, ResDataSize + ResInfoSize);
  1026.       with Result^ do
  1027.       begin
  1028.         Next := ResList;
  1029.         RefCount := 0;
  1030.         Handle := TResData(ResData).Handle;
  1031.         HashCode := ResHash;
  1032.         Move(ResData, Data, ResDataSize);
  1033.       end;
  1034.       ResList := Result;
  1035.     end;
  1036.     Inc(Result^.RefCount);
  1037.   finally
  1038.     Unlock;
  1039.   end;
  1040. end;
  1041.  
  1042. procedure TResourceManager.FreeResource(Resource: PResource);
  1043. var
  1044.   P: PResource;
  1045.   DeleteIt: Boolean;
  1046. begin
  1047.   if Resource <> nil then
  1048.     with Resource^ do
  1049.     begin
  1050.       Lock;
  1051.       try
  1052.         Dec(RefCount);
  1053.         DeleteIt := RefCount = 0;
  1054.         if DeleteIt then
  1055.         begin
  1056.           if Resource = ResList then
  1057.             ResList := Resource^.Next
  1058.           else
  1059.           begin
  1060.             P := ResList;
  1061.             while P^.Next <> Resource do P := P^.Next;
  1062.             P^.Next := Resource^.Next;
  1063.           end;
  1064.         end;
  1065.       finally
  1066.         Unlock;
  1067.       end;
  1068.       if DeleteIt then
  1069.       begin  // this is outside the critsect to minimize lock time
  1070.         if Handle <> 0 then DeleteObject(Handle);
  1071.         FreeMem(Resource);
  1072.       end;
  1073.     end;
  1074. end;
  1075.  
  1076. procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  1077.   const ResData);
  1078. var
  1079.   P: PResource;
  1080. begin
  1081.   Lock;
  1082.   try  // prevent changes to GraphicsObject.FResource pointer between steps
  1083.     P := GraphicsObject.FResource;
  1084.     GraphicsObject.FResource := AllocResource(ResData);
  1085.     if GraphicsObject.FResource <> P then GraphicsObject.Changed;
  1086.     FreeResource(P);
  1087.   finally
  1088.     Unlock;
  1089.   end;
  1090. end;
  1091.  
  1092. procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  1093.   AResource: PResource);
  1094. var
  1095.   P: PResource;
  1096. begin
  1097.   Lock;
  1098.   try
  1099.     P := GraphicsObject.FResource;
  1100.     if P <> AResource then
  1101.     begin
  1102.       Inc(AResource^.RefCount);
  1103.       GraphicsObject.FResource := AResource;
  1104.       GraphicsObject.Changed;
  1105.       FreeResource(P);
  1106.     end;
  1107.   finally
  1108.     Unlock;
  1109.   end;
  1110. end;
  1111.  
  1112. var
  1113.   CanvasList: TThreadList;
  1114.  
  1115. procedure PaletteChanged;
  1116.  
  1117.   procedure ClearColor(ResMan: TResourceManager);
  1118.   var
  1119.     Resource: PResource;
  1120.   begin
  1121.     ResMan.Lock;
  1122.     try
  1123.       Resource := ResMan.ResList;
  1124.       while Resource <> nil do
  1125.       begin
  1126.         with Resource^ do
  1127.         { Assumes Pen.Color and Brush.Color share the same location }
  1128.           if (Handle <> 0) and (Pen.Color < 0) then
  1129.           begin
  1130.             DeleteObject(Handle);
  1131.             Handle := 0;
  1132.           end;
  1133.         Resource := Resource^.Next;
  1134.       end;
  1135.     finally
  1136.       ResMan.Unlock;
  1137.     end;
  1138.   end;
  1139.  
  1140. var
  1141.   I,J: Integer;
  1142. begin
  1143.   { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  1144.   I := 0;
  1145.   with CanvasList.LockList do
  1146.   try
  1147.     while I < Count do
  1148.     begin
  1149.       with TCanvas(Items[I]) do
  1150.       begin
  1151.         Lock;
  1152.         Inc(I);
  1153.         DeselectHandles;
  1154.       end;
  1155.     end;
  1156.     ClearColor(PenManager);
  1157.     ClearColor(BrushManager);
  1158.   finally
  1159.     for J := 0 to I-1 do  // Only unlock the canvases we actually locked
  1160.       TCanvas(Items[J]).Unlock;
  1161.     CanvasList.UnlockList;
  1162.   end;
  1163. end;
  1164.  
  1165. { Color mapping routines }
  1166.  
  1167. const
  1168.   Colors: array[0..41] of TIdentMapEntry = (
  1169.     (Value: clBlack; Name: 'clBlack'),
  1170.     (Value: clMaroon; Name: 'clMaroon'),
  1171.     (Value: clGreen; Name: 'clGreen'),
  1172.     (Value: clOlive; Name: 'clOlive'),
  1173.     (Value: clNavy; Name: 'clNavy'),
  1174.     (Value: clPurple; Name: 'clPurple'),
  1175.     (Value: clTeal; Name: 'clTeal'),
  1176.     (Value: clGray; Name: 'clGray'),
  1177.     (Value: clSilver; Name: 'clSilver'),
  1178.     (Value: clRed; Name: 'clRed'),
  1179.     (Value: clLime; Name: 'clLime'),
  1180.     (Value: clYellow; Name: 'clYellow'),
  1181.     (Value: clBlue; Name: 'clBlue'),
  1182.     (Value: clFuchsia; Name: 'clFuchsia'),
  1183.     (Value: clAqua; Name: 'clAqua'),
  1184.     (Value: clWhite; Name: 'clWhite'),
  1185.     (Value: clScrollBar; Name: 'clScrollBar'),
  1186.     (Value: clBackground; Name: 'clBackground'),
  1187.     (Value: clActiveCaption; Name: 'clActiveCaption'),
  1188.     (Value: clInactiveCaption; Name: 'clInactiveCaption'),
  1189.     (Value: clMenu; Name: 'clMenu'),
  1190.     (Value: clWindow; Name: 'clWindow'),
  1191.     (Value: clWindowFrame; Name: 'clWindowFrame'),
  1192.     (Value: clMenuText; Name: 'clMenuText'),
  1193.     (Value: clWindowText; Name: 'clWindowText'),
  1194.     (Value: clCaptionText; Name: 'clCaptionText'),
  1195.     (Value: clActiveBorder; Name: 'clActiveBorder'),
  1196.     (Value: clInactiveBorder; Name: 'clInactiveBorder'),
  1197.     (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
  1198.     (Value: clHighlight; Name: 'clHighlight'),
  1199.     (Value: clHighlightText; Name: 'clHighlightText'),
  1200.     (Value: clBtnFace; Name: 'clBtnFace'),
  1201.     (Value: clBtnShadow; Name: 'clBtnShadow'),
  1202.     (Value: clGrayText; Name: 'clGrayText'),
  1203.     (Value: clBtnText; Name: 'clBtnText'),
  1204.     (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
  1205.     (Value: clBtnHighlight; Name: 'clBtnHighlight'),
  1206.     (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
  1207.     (Value: cl3DLight; Name: 'cl3DLight'),
  1208.     (Value: clInfoText; Name: 'clInfoText'),
  1209.     (Value: clInfoBk; Name: 'clInfoBk'),
  1210.     (Value: clNone; Name: 'clNone'));
  1211.  
  1212. function ColorToRGB(Color: TColor): Longint;
  1213. begin
  1214.   if Color < 0 then
  1215.     Result := GetSysColor(Color and $000000FF) else
  1216.     Result := Color;
  1217. end;
  1218.  
  1219. function ColorToString(Color: TColor): string;
  1220. begin
  1221.   if not ColorToIdent(Color, Result) then
  1222.     FmtStr(Result, '$%.8x', [Color]);
  1223. end;
  1224.  
  1225. function StringToColor(const S: string): TColor;
  1226. begin
  1227.   if not IdentToColor(S, Longint(Result)) then
  1228.     Result := TColor(StrToInt(S));
  1229. end;
  1230.  
  1231. procedure GetColorValues(Proc: TGetStrProc);
  1232. var
  1233.   I: Integer;
  1234. begin
  1235.   for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
  1236. end;
  1237.  
  1238. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  1239. begin
  1240.   Result := IntToIdent(Color, Ident, Colors);
  1241. end;
  1242.  
  1243. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  1244. begin
  1245.   Result := IdentToInt(Ident, Color, Colors);
  1246. end;
  1247.  
  1248. { TGraphicsObject }
  1249.  
  1250. procedure TGraphicsObject.Changed;
  1251. begin
  1252.   if Assigned(FOnChange) then FOnChange(Self);
  1253. end;
  1254.  
  1255. procedure TGraphicsObject.Lock;
  1256. begin
  1257.   if Assigned(FOwnerLock) then EnterCriticalSection(FOwnerLock^);
  1258. end;
  1259.  
  1260. procedure TGraphicsObject.Unlock;
  1261. begin
  1262.   if Assigned(FOwnerLock) then LeaveCriticalSection(FOwnerLock^);
  1263. end;
  1264.  
  1265. { TFont }
  1266.  
  1267. const
  1268.   FontCharsets: array[0..17] of TIdentMapEntry = (
  1269.     (Value: 0; Name: 'ANSI_CHARSET'),
  1270.     (Value: 1; Name: 'DEFAULT_CHARSET'),
  1271.     (Value: 2; Name: 'SYMBOL_CHARSET'),
  1272.     (Value: 77; Name: 'MAC_CHARSET'),
  1273.     (Value: 128; Name: 'SHIFTJIS_CHARSET'),
  1274.     (Value: 129; Name: 'HANGEUL_CHARSET'),
  1275.     (Value: 130; Name: 'JOHAB_CHARSET'),
  1276.     (Value: 134; Name: 'GB2312_CHARSET'),
  1277.     (Value: 136; Name: 'CHINESEBIG5_CHARSET'),
  1278.     (Value: 161; Name: 'GREEK_CHARSET'),
  1279.     (Value: 162; Name: 'TURKISH_CHARSET'),
  1280.     (Value: 177; Name: 'HEBREW_CHARSET'),
  1281.     (Value: 178; Name: 'ARABIC_CHARSET'),
  1282.     (Value: 186; Name: 'BALTIC_CHARSET'),
  1283.     (Value: 204; Name: 'RUSSIAN_CHARSET'),
  1284.     (Value: 222; Name: 'THAI_CHARSET'),
  1285.     (Value: 238; Name: 'EASTEUROPE_CHARSET'),
  1286.     (Value: 255; Name: 'OEM_CHARSET'));
  1287.  
  1288. procedure GetCharsetValues(Proc: TGetStrProc);
  1289. var
  1290.   I: Integer;
  1291. begin
  1292.   for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
  1293. end;
  1294.  
  1295. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  1296. begin
  1297.   Result := IntToIdent(Charset, Ident, FontCharsets);
  1298. end;
  1299.  
  1300. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  1301. begin
  1302.   Result := IdentToInt(Ident, CharSet, FontCharsets);
  1303. end;
  1304.  
  1305. function GetFontData(Font: HFont): TFontData;
  1306. var
  1307.   LogFont: TLogFont;
  1308. begin
  1309.   Result := DefFontData;
  1310.   if Font <> 0 then
  1311.   begin
  1312.     if GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 then
  1313.     with Result, LogFont do
  1314.     begin
  1315.       Height := lfHeight;
  1316.       if lfWeight >= FW_BOLD then
  1317.         Include(Style, fsBold);
  1318.       if lfItalic = 1 then
  1319.         Include(Style, fsItalic);
  1320.       if lfUnderline = 1 then
  1321.         Include(Style, fsUnderline);
  1322.       if lfStrikeOut = 1 then
  1323.         Include(Style, fsStrikeOut);
  1324.       Charset := TFontCharset(lfCharSet);
  1325.       Name := lfFaceName;
  1326.       case lfPitchAndFamily and $F of
  1327.         VARIABLE_PITCH: Pitch := fpVariable;
  1328.         FIXED_PITCH: Pitch := fpFixed;
  1329.       else
  1330.         Pitch := fpDefault;
  1331.       end;
  1332.       Handle := Font;
  1333.     end;
  1334.   end;
  1335. end;
  1336.  
  1337. constructor TFont.Create;
  1338. begin
  1339.   DefFontData.Handle := 0;
  1340.   FResource := FontManager.AllocResource(DefFontData);
  1341.   FColor := clWindowText;
  1342.   FPixelsPerInch := ScreenLogPixels;
  1343. end;
  1344.  
  1345. destructor TFont.Destroy;
  1346. begin
  1347.   FontManager.FreeResource(FResource);
  1348. end;
  1349.  
  1350. procedure TFont.Changed;
  1351. begin
  1352.   inherited Changed;
  1353.   if FNotify <> nil then FNotify.Changed;
  1354. end;
  1355.  
  1356. procedure TFont.Assign(Source: TPersistent);
  1357. begin
  1358.   if Source is TFont then
  1359.   begin
  1360.     Lock;
  1361.     try
  1362.       TFont(Source).Lock;
  1363.       try
  1364.         FontManager.AssignResource(Self, TFont(Source).FResource);
  1365.         Color := TFont(Source).Color;
  1366.         if PixelsPerInch <> TFont(Source).PixelsPerInch then
  1367.           Size := TFont(Source).Size;
  1368.       finally
  1369.         TFont(Source).Unlock;
  1370.       end;
  1371.     finally
  1372.       Unlock;
  1373.     end;
  1374.     Exit;
  1375.   end;
  1376.   inherited Assign(Source);
  1377. end;
  1378.  
  1379. procedure TFont.GetData(var FontData: TFontData);
  1380. begin
  1381.   FontData := FResource^.Font;
  1382.   FontData.Handle := 0;
  1383. end;
  1384.  
  1385. procedure TFont.SetData(const FontData: TFontData);
  1386. begin
  1387.   Lock;
  1388.   try
  1389.     FontManager.ChangeResource(Self, FontData);
  1390.   finally
  1391.     Unlock;
  1392.   end;
  1393. end;
  1394.  
  1395. procedure TFont.SetColor(Value: TColor);
  1396. begin
  1397.   if FColor <> Value then
  1398.   begin
  1399.     FColor := Value;
  1400.     Changed;
  1401.   end;
  1402. end;
  1403.  
  1404. function TFont.GetHandle: HFont;
  1405. var
  1406.   LogFont: TLogFont;
  1407. begin
  1408.   with FResource^ do
  1409.   begin
  1410.     if Handle = 0 then
  1411.     begin
  1412.       FontManager.Lock;
  1413.       with LogFont do
  1414.       try
  1415.         if Handle = 0 then
  1416.         begin
  1417.           lfHeight := Font.Height;
  1418.           lfWidth := 0; { have font mapper choose }
  1419.           lfEscapement := 0; { only straight fonts }
  1420.           lfOrientation := 0; { no rotation }
  1421.           if fsBold in Font.Style then
  1422.             lfWeight := FW_BOLD
  1423.           else
  1424.             lfWeight := FW_NORMAL;
  1425.           lfItalic := Byte(fsItalic in Font.Style);
  1426.           lfUnderline := Byte(fsUnderline in Font.Style);
  1427.           lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  1428.           lfCharSet := Byte(Font.Charset);
  1429.           if AnsiCompareText(Font.Name, 'Default') = 0 then  // do not localize
  1430.             StrPCopy(lfFaceName, DefFontData.Name)
  1431.           else
  1432.             StrPCopy(lfFaceName, Font.Name);
  1433.           lfQuality := DEFAULT_QUALITY;
  1434.           { Everything else as default }
  1435.           lfOutPrecision := OUT_DEFAULT_PRECIS;
  1436.           lfClipPrecision := CLIP_DEFAULT_PRECIS;
  1437.           case Pitch of
  1438.             fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  1439.             fpFixed: lfPitchAndFamily := FIXED_PITCH;
  1440.           else
  1441.             lfPitchAndFamily := DEFAULT_PITCH;
  1442.           end;
  1443.           Handle := CreateFontIndirect(LogFont);
  1444.         end;
  1445.       finally
  1446.         FontManager.Unlock;
  1447.       end;
  1448.     end;
  1449.     Result := Handle;
  1450.   end;
  1451. end;
  1452.  
  1453. procedure TFont.SetHandle(Value: HFont);
  1454. begin
  1455.   SetData(GetFontData(Value));
  1456. end;
  1457.  
  1458. function TFont.GetHeight: Integer;
  1459. begin
  1460.   Result := FResource^.Font.Height;
  1461. end;
  1462.  
  1463. procedure TFont.SetHeight(Value: Integer);
  1464. var
  1465.   FontData: TFontData;
  1466. begin
  1467.   GetData(FontData);
  1468.   FontData.Height := Value;
  1469.   SetData(FontData);
  1470. end;
  1471.  
  1472. function TFont.GetName: TFontName;
  1473. begin
  1474.   Result := FResource^.Font.Name;
  1475. end;
  1476.  
  1477. procedure TFont.SetName(const Value: TFontName);
  1478. var
  1479.   FontData: TFontData;
  1480. begin
  1481.   if Value <> '' then
  1482.   begin
  1483.     GetData(FontData);
  1484.     FillChar(FontData.Name, SizeOf(FontData.Name), 0);
  1485.     FontData.Name := Value;
  1486.     SetData(FontData);
  1487.   end;
  1488. end;
  1489.  
  1490. function TFont.GetSize: Integer;
  1491. begin
  1492.   Result := -MulDiv(Height, 72, FPixelsPerInch);
  1493. end;
  1494.  
  1495. procedure TFont.SetSize(Value: Integer);
  1496. begin
  1497.   Height := -MulDiv(Value, FPixelsPerInch, 72);
  1498. end;
  1499.  
  1500. function TFont.GetStyle: TFontStyles;
  1501. begin
  1502.   Result := FResource^.Font.Style;
  1503. end;
  1504.  
  1505. procedure TFont.SetStyle(Value: TFontStyles);
  1506. var
  1507.   FontData: TFontData;
  1508. begin
  1509.   GetData(FontData);
  1510.   FontData.Style := Value;
  1511.   SetData(FontData);
  1512. end;
  1513.  
  1514. function TFont.GetPitch: TFontPitch;
  1515. begin
  1516.   Result := FResource^.Font.Pitch;
  1517. end;
  1518.  
  1519. procedure TFont.SetPitch(Value: TFontPitch);
  1520. var
  1521.   FontData: TFontData;
  1522. begin
  1523.   GetData(FontData);
  1524.   FontData.Pitch := Value;
  1525.   SetData(FontData);
  1526. end;
  1527.  
  1528. function TFont.GetCharset: TFontCharset;
  1529. begin
  1530.   Result := FResource^.Font.Charset;
  1531. end;
  1532.  
  1533. procedure TFont.SetCharset(Value: TFontCharset);
  1534. var
  1535.   FontData: TFontData;
  1536. begin
  1537.   GetData(FontData);
  1538.   FontData.Charset := Value;
  1539.   SetData(FontData);
  1540. end;
  1541.  
  1542. { TPen }
  1543.  
  1544. const
  1545.   DefPenData: TPenData = (
  1546.     Handle: 0;
  1547.     Color: clBlack;
  1548.     Width: 1;
  1549.     Style: psSolid);
  1550.  
  1551. constructor TPen.Create;
  1552. begin
  1553.   FResource := PenManager.AllocResource(DefPenData);
  1554.   FMode := pmCopy;
  1555. end;
  1556.  
  1557. destructor TPen.Destroy;
  1558. begin
  1559.   PenManager.FreeResource(FResource);
  1560. end;
  1561.  
  1562. procedure TPen.Assign(Source: TPersistent);
  1563. begin
  1564.   if Source is TPen then
  1565.   begin
  1566.     Lock;
  1567.     try
  1568.       TPen(Source).Lock;
  1569.       try
  1570.         PenManager.AssignResource(Self, TPen(Source).FResource);
  1571.         SetMode(TPen(Source).FMode);
  1572.       finally
  1573.         TPen(Source).Unlock;
  1574.       end;
  1575.     finally
  1576.       Unlock;
  1577.     end;
  1578.     Exit;
  1579.   end;
  1580.   inherited Assign(Source);
  1581. end;
  1582.  
  1583. procedure TPen.GetData(var PenData: TPenData);
  1584. begin
  1585.   PenData := FResource^.Pen;
  1586.   PenData.Handle := 0;
  1587. end;
  1588.  
  1589. procedure TPen.SetData(const PenData: TPenData);
  1590. begin
  1591.   Lock;
  1592.   try
  1593.     PenManager.ChangeResource(Self, PenData);
  1594.   finally
  1595.     Unlock;
  1596.   end;
  1597. end;
  1598.  
  1599. function TPen.GetColor: TColor;
  1600. begin
  1601.   Result := FResource^.Pen.Color;
  1602. end;
  1603.  
  1604. procedure TPen.SetColor(Value: TColor);
  1605. var
  1606.   PenData: TPenData;
  1607. begin
  1608.   GetData(PenData);
  1609.   PenData.Color := Value;
  1610.   SetData(PenData);
  1611. end;
  1612.  
  1613. function TPen.GetHandle: HPen;
  1614. const
  1615.   PenStyles: array[TPenStyle] of Word =
  1616.     (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
  1617.      PS_INSIDEFRAME);
  1618. var
  1619.   LogPen: TLogPen;
  1620. begin
  1621.   with FResource^ do
  1622.   begin
  1623.     if Handle = 0 then
  1624.     begin
  1625.       PenManager.Lock;
  1626.       with LogPen do
  1627.       try
  1628.         if Handle = 0 then
  1629.         begin
  1630.           lopnStyle := PenStyles[Pen.Style];
  1631.           lopnWidth.X := Pen.Width;
  1632.           lopnColor := ColorToRGB(Pen.Color);
  1633.           Handle := CreatePenIndirect(LogPen);
  1634.         end;
  1635.       finally
  1636.         PenManager.Unlock;
  1637.       end;
  1638.     end;
  1639.     Result := Handle;
  1640.   end;
  1641. end;
  1642.  
  1643. procedure TPen.SetHandle(Value: HPen);
  1644. var
  1645.   PenData: TPenData;
  1646. begin
  1647.   PenData := DefPenData;
  1648.   PenData.Handle := Value;
  1649.   SetData(PenData);
  1650. end;
  1651.  
  1652. procedure TPen.SetMode(Value: TPenMode);
  1653. begin
  1654.   if FMode <> Value then
  1655.   begin
  1656.     FMode := Value;
  1657.     Changed;
  1658.   end;
  1659. end;
  1660.  
  1661. function TPen.GetStyle: TPenStyle;
  1662. begin
  1663.   Result := FResource^.Pen.Style;
  1664. end;
  1665.  
  1666. procedure TPen.SetStyle(Value: TPenStyle);
  1667. var
  1668.   PenData: TPenData;
  1669. begin
  1670.   GetData(PenData);
  1671.   PenData.Style := Value;
  1672.   SetData(PenData);
  1673. end;
  1674.  
  1675. function TPen.GetWidth: Integer;
  1676. begin
  1677.   Result := FResource^.Pen.Width;
  1678. end;
  1679.  
  1680. procedure TPen.SetWidth(Value: Integer);
  1681. var
  1682.   PenData: TPenData;
  1683. begin
  1684.   if Value >= 0 then
  1685.   begin
  1686.     GetData(PenData);
  1687.     PenData.Width := Value;
  1688.     SetData(PenData);
  1689.   end;
  1690. end;
  1691.  
  1692. { TBrush }
  1693.  
  1694. const
  1695.   DefBrushData: TBrushData = (
  1696.     Handle: 0;
  1697.     Color: clWhite;
  1698.     Bitmap: nil;
  1699.     Style: bsSolid);
  1700.  
  1701. constructor TBrush.Create;
  1702. begin
  1703.   FResource := BrushManager.AllocResource(DefBrushData);
  1704. end;
  1705.  
  1706. destructor TBrush.Destroy;
  1707. begin
  1708.   BrushManager.FreeResource(FResource);
  1709. end;
  1710.  
  1711. procedure TBrush.Assign(Source: TPersistent);
  1712. begin
  1713.   if Source is TBrush then
  1714.   begin
  1715.     Lock;
  1716.     try
  1717.       TBrush(Source).Lock;
  1718.       try
  1719.         BrushManager.AssignResource(Self, TBrush(Source).FResource);
  1720.       finally
  1721.         TBrush(Source).Unlock;
  1722.       end;
  1723.     finally
  1724.       Unlock;
  1725.     end;
  1726.     Exit;
  1727.   end;
  1728.   inherited Assign(Source);
  1729. end;
  1730.  
  1731. procedure TBrush.GetData(var BrushData: TBrushData);
  1732. begin
  1733.   BrushData := FResource^.Brush;
  1734.   BrushData.Handle := 0;
  1735.   BrushData.Bitmap := nil;
  1736. end;
  1737.  
  1738. procedure TBrush.SetData(const BrushData: TBrushData);
  1739. begin
  1740.   Lock;
  1741.   try
  1742.     BrushManager.ChangeResource(Self, BrushData);
  1743.   finally
  1744.     Unlock;
  1745.   end;
  1746. end;
  1747.  
  1748. function TBrush.GetBitmap: TBitmap;
  1749. begin
  1750.   Result := FResource^.Brush.Bitmap;
  1751. end;
  1752.  
  1753. procedure TBrush.SetBitmap(Value: TBitmap);
  1754. var
  1755.   BrushData: TBrushData;
  1756. begin
  1757.   BrushData := DefBrushData;
  1758.   BrushData.Bitmap := Value;
  1759.   SetData(BrushData);
  1760. end;
  1761.  
  1762. function TBrush.GetColor: TColor;
  1763. begin
  1764.   Result := FResource^.Brush.Color;
  1765. end;
  1766.  
  1767. procedure TBrush.SetColor(Value: TColor);
  1768. var
  1769.   BrushData: TBrushData;
  1770. begin
  1771.   GetData(BrushData);
  1772.   BrushData.Color := Value;
  1773.   if BrushData.Style = bsClear then BrushData.Style := bsSolid;
  1774.   SetData(BrushData);
  1775. end;
  1776.  
  1777. function TBrush.GetHandle: HBrush;
  1778. var
  1779.   LogBrush: TLogBrush;
  1780. begin
  1781.   with FResource^ do
  1782.   begin
  1783.     if Handle = 0 then
  1784.     begin
  1785.       BrushManager.Lock;
  1786.       try
  1787.         if Handle = 0 then
  1788.         begin
  1789.           with LogBrush do
  1790.           begin
  1791.             if Brush.Bitmap <> nil then
  1792.             begin
  1793.               lbStyle := BS_PATTERN;
  1794.               Brush.Bitmap.HandleType := bmDDB;
  1795.               lbHatch := Brush.Bitmap.Handle;
  1796.             end else
  1797.             begin
  1798.               lbHatch := 0;
  1799.               case Brush.Style of
  1800.                 bsSolid: lbStyle := BS_SOLID;
  1801.                 bsClear: lbStyle := BS_HOLLOW;
  1802.               else
  1803.                 lbStyle := BS_HATCHED;
  1804.                 lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
  1805.               end;
  1806.             end;
  1807.             lbColor := ColorToRGB(Brush.Color);
  1808.           end;
  1809.           Handle := CreateBrushIndirect(LogBrush);
  1810.         end;
  1811.       finally
  1812.         BrushManager.Unlock;
  1813.       end;
  1814.     end;
  1815.     Result := Handle;
  1816.   end;
  1817. end;
  1818.  
  1819. procedure TBrush.SetHandle(Value: HBrush);
  1820. var
  1821.   BrushData: TBrushData;
  1822. begin
  1823.   BrushData := DefBrushData;
  1824.   BrushData.Handle := Value;
  1825.   SetData(BrushData);
  1826. end;
  1827.  
  1828. function TBrush.GetStyle: TBrushStyle;
  1829. begin
  1830.   Result := FResource^.Brush.Style;
  1831. end;
  1832.  
  1833. procedure TBrush.SetStyle(Value: TBrushStyle);
  1834. var
  1835.   BrushData: TBrushData;
  1836. begin
  1837.   GetData(BrushData);
  1838.   BrushData.Style := Value;
  1839.   if BrushData.Style = bsClear then BrushData.Color := clWhite;
  1840.   SetData(BrushData);
  1841. end;
  1842.  
  1843. { TCanvas }
  1844.  
  1845. constructor TCanvas.Create;
  1846. begin
  1847.   inherited Create;
  1848.   InitializeCriticalSection(FLock);
  1849.   FFont := TFont.Create;
  1850.   FFont.OnChange := FontChanged;
  1851.   FFont.OwnerCriticalSection := @FLock;
  1852.   FPen := TPen.Create;
  1853.   FPen.OnChange := PenChanged;
  1854.   FPen.OwnerCriticalSection := @FLock;
  1855.   FBrush := TBrush.Create;
  1856.   FBrush.OnChange := BrushChanged;
  1857.   FBrush.OwnerCriticalSection := @FLock;
  1858.   FCopyMode := cmSrcCopy;
  1859.   State := [];
  1860.   CanvasList.Add(Self);
  1861. end;
  1862.  
  1863. destructor TCanvas.Destroy;
  1864. begin
  1865.   CanvasList.Remove(Self);
  1866.   SetHandle(0);
  1867.   FFont.Free;
  1868.   FPen.Free;
  1869.   FBrush.Free;
  1870.   DeleteCriticalSection(FLock);
  1871.   inherited Destroy;
  1872. end;
  1873.  
  1874. procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1875. begin
  1876.   Changing;
  1877.   RequiredState([csHandleValid, csPenValid]);
  1878.   Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1879.   Changed;
  1880. end;
  1881.  
  1882. procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  1883.   const Source: TRect; Color: TColor);
  1884. const
  1885.   ROP_DSPDxax = $00E20746;
  1886. var
  1887.   SrcW, SrcH, DstW, DstH: Integer;
  1888.   crBack, crText: TColorRef;
  1889.   MaskDC: HDC;
  1890.   Mask: TBitmap;
  1891.   MaskHandle: HBITMAP;
  1892. begin
  1893.   if Bitmap = nil then Exit;
  1894.   Lock;
  1895.   try
  1896.     Changing;
  1897.     RequiredState([csHandleValid, csBrushValid]);
  1898.     Bitmap.Canvas.Lock;
  1899.     try
  1900.       DstW := Dest.Right - Dest.Left;
  1901.       DstH := Dest.Bottom - Dest.Top;
  1902.       SrcW := Source.Right - Source.Left;
  1903.       SrcH := Source.Bottom - Source.Top;
  1904.  
  1905.       if Bitmap.TransparentColor = Color then
  1906.       begin
  1907.         Mask := nil;
  1908.         MaskHandle := Bitmap.MaskHandle;
  1909.         MaskDC := CreateCompatibleDC(0);
  1910.         MaskHandle := SelectObject(MaskDC, MaskHandle);
  1911.       end
  1912.       else
  1913.       begin
  1914.         Mask := TBitmap.Create;
  1915.         Mask.Assign(Bitmap);
  1916.         { Replace Color with black and all other colors with white }
  1917.         Mask.Mask(Color);
  1918.         Mask.Canvas.RequiredState([csHandleValid]);
  1919.         MaskDC := Mask.Canvas.FHandle;
  1920.         MaskHandle := 0;
  1921.       end;
  1922.  
  1923.       try
  1924.         Bitmap.Canvas.RequiredState([csHandleValid]);
  1925.         { Draw transparently or use brush color to fill background }
  1926.         if Brush.Style = bsClear then
  1927.         begin
  1928.           TransparentStretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1929.             Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH,
  1930.             MaskDC, Source.Left, Source.Top);
  1931.         end
  1932.         else
  1933.         begin
  1934.           StretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1935.             Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH, SrcCopy);
  1936.           crText := SetTextColor(Self.FHandle, 0);
  1937.           crBack := SetBkColor(Self.FHandle, $FFFFFF);
  1938.           StretchBlt(Self.FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1939.             MaskDC, Source.Left, Source.Top, SrcW, SrcH, ROP_DSPDxax);
  1940.           SetTextColor(Self.FHandle, crText);
  1941.           SetBkColor(Self.FHandle, crBack);
  1942.         end;
  1943.       finally
  1944.         if Assigned(Mask) then Mask.Free
  1945.         else
  1946.         begin
  1947.           if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
  1948.           DeleteDC(MaskDC);
  1949.         end;
  1950.       end;
  1951.     finally
  1952.       Bitmap.Canvas.Unlock;
  1953.     end;
  1954.     Changed;
  1955.   finally
  1956.     Unlock;
  1957.   end;
  1958. end;
  1959.  
  1960. procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1961. begin
  1962.   Changing;
  1963.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1964.   Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1965.   Changed;
  1966. end;
  1967.  
  1968. procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
  1969.   const Source: TRect);
  1970. begin
  1971.   Changing;
  1972.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  1973.   Canvas.RequiredState([csHandleValid, csBrushValid]);
  1974.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  1975.     Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
  1976.     Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
  1977.   Changed;
  1978. end;
  1979.  
  1980. procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
  1981. begin
  1982.   if (Graphic <> nil) and not Graphic.Empty then
  1983.   begin
  1984.     Changing;
  1985.     RequiredState([csHandleValid]);
  1986.     SetBkColor(FHandle, ColorToRGB(FBrush.Color));
  1987.     SetTextColor(FHandle, ColorToRGB(FFont.Color));
  1988.     Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
  1989.     Changed;
  1990.   end;
  1991. end;
  1992.  
  1993. procedure TCanvas.DrawFocusRect(const Rect: TRect);
  1994. begin
  1995.   Changing;
  1996.   RequiredState([csHandleValid, csBrushValid]);
  1997.   Windows.DrawFocusRect(FHandle, Rect);
  1998.   Changed;
  1999. end;
  2000.  
  2001. procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
  2002. begin
  2003.   Changing;
  2004.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2005.   Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
  2006.   Changed;
  2007. end;
  2008.  
  2009. procedure TCanvas.FillRect(const Rect: TRect);
  2010. begin
  2011.   Changing;
  2012.   RequiredState([csHandleValid, csBrushValid]);
  2013.   Windows.FillRect(FHandle, Rect, Brush.GetHandle);
  2014.   Changed;
  2015. end;
  2016.  
  2017. procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  2018.   FillStyle: TFillStyle);
  2019. const
  2020.   FillStyles: array[TFillStyle] of Word =
  2021.     (FLOODFILLSURFACE, FLOODFILLBORDER);
  2022. begin
  2023.   Changing;
  2024.   RequiredState([csHandleValid, csBrushValid]);
  2025.   Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  2026.   Changed;
  2027. end;
  2028.  
  2029. procedure TCanvas.FrameRect(const Rect: TRect);
  2030. begin
  2031.   Changing;
  2032.   RequiredState([csHandleValid, csBrushValid]);
  2033.   Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
  2034.   Changed;
  2035. end;
  2036.  
  2037. procedure TCanvas.LineTo(X, Y: Integer);
  2038. begin
  2039.   Changing;
  2040.   RequiredState([csHandleValid, csPenValid]);
  2041.   Windows.LineTo(FHandle, X, Y);
  2042.   Changed;
  2043. end;
  2044.  
  2045. procedure TCanvas.Lock;
  2046. begin
  2047.   EnterCriticalSection(CounterLock);
  2048.   Inc(FLockCount);
  2049.   LeaveCriticalSection(CounterLock);
  2050.   EnterCriticalSection(FLock);
  2051. end;
  2052.  
  2053. procedure TCanvas.MoveTo(X, Y: Integer);
  2054. begin
  2055.   RequiredState([csHandleValid]);
  2056.   Windows.MoveToEx(FHandle, X, Y, nil);
  2057. end;
  2058.  
  2059. procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  2060. begin
  2061.   Changing;
  2062.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2063.   Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  2064.   Changed;
  2065. end;
  2066.  
  2067. type
  2068.   PPoints = ^TPoints;
  2069.   TPoints = array[0..0] of TPoint;
  2070.  
  2071. procedure TCanvas.Polygon(const Points: array of TPoint);
  2072. begin
  2073.   Changing;
  2074.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2075.   Windows.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
  2076.   Changed;
  2077. end;
  2078.  
  2079. procedure TCanvas.Polyline(const Points: array of TPoint);
  2080. begin
  2081.   Changing;
  2082.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2083.   Windows.Polyline(FHandle, PPoints(@Points)^, High(Points) + 1);
  2084.   Changed;
  2085. end;
  2086.  
  2087. procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
  2088. begin
  2089.   Changing;
  2090.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2091.   Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
  2092.   Changed;
  2093. end;
  2094.  
  2095. procedure TCanvas.Refresh;
  2096. begin
  2097.   DeselectHandles;
  2098. end;
  2099.  
  2100. procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  2101. begin
  2102.   Changing;
  2103.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2104.   Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
  2105.   Changed;
  2106. end;
  2107.  
  2108. procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
  2109. begin
  2110.   if Graphic <> nil then
  2111.   begin
  2112.     Changing;
  2113.     RequiredState(csAllValid);
  2114.     Graphic.Draw(Self, Rect);
  2115.     Changed;
  2116.   end;
  2117. end;
  2118.  
  2119. procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
  2120. begin
  2121.   Changing;
  2122.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2123.   Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));
  2124.   MoveTo(X + TextWidth(Text), Y);
  2125.   Changed;
  2126. end;
  2127.  
  2128. procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  2129. var
  2130.   Options: Integer;
  2131. begin
  2132.   Changing;
  2133.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2134.   Options := ETO_CLIPPED;
  2135.   if Brush.Style <> bsClear then Inc(Options, ETO_OPAQUE);
  2136.   Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text),
  2137.     Length(Text), nil);
  2138.   Changed;
  2139. end;
  2140.  
  2141. function TCanvas.TextExtent(const Text: string): TSize;
  2142. begin
  2143.   RequiredState([csHandleValid, csFontValid]);
  2144.   Result.cX := 0;
  2145.   Result.cY := 0;
  2146.   Windows.GetTextExtentPoint(FHandle, PChar(Text), Length(Text), Result);
  2147. end;
  2148.  
  2149. function TCanvas.TextWidth(const Text: string): Integer;
  2150. begin
  2151.   Result := TextExtent(Text).cX;
  2152. end;
  2153.  
  2154. function TCanvas.TextHeight(const Text: string): Integer;
  2155. begin
  2156.   Result := TextExtent(Text).cY;
  2157. end;
  2158.  
  2159. function TCanvas.TryLock: Boolean;
  2160. begin
  2161.   EnterCriticalSection(CounterLock);
  2162.   try
  2163.     Result := FLockCount = 0;
  2164.     if Result then Lock;
  2165.   finally
  2166.     LeaveCriticalSection(CounterLock);
  2167.   end;
  2168. end;
  2169.  
  2170. procedure TCanvas.Unlock;
  2171. begin
  2172.   LeaveCriticalSection(FLock);
  2173.   EnterCriticalSection(CounterLock);
  2174.   Dec(FLockCount);
  2175.   LeaveCriticalSection(CounterLock);
  2176. end;
  2177.  
  2178. procedure TCanvas.SetFont(Value: TFont);
  2179. begin
  2180.   FFont.Assign(Value);
  2181. end;
  2182.  
  2183. procedure TCanvas.SetPen(Value: TPen);
  2184. begin
  2185.   FPen.Assign(Value);
  2186. end;
  2187.  
  2188. procedure TCanvas.SetBrush(Value: TBrush);
  2189. begin
  2190.   FBrush.Assign(Value);
  2191. end;
  2192.  
  2193. function TCanvas.GetPenPos: TPoint;
  2194. begin
  2195.   RequiredState([csHandleValid]);
  2196.   Windows.GetCurrentPositionEx(FHandle, @Result);
  2197. end;
  2198.  
  2199. procedure TCanvas.SetPenPos(Value: TPoint);
  2200. begin
  2201.   MoveTo(Value.X, Value.Y);
  2202. end;
  2203.  
  2204. function TCanvas.GetPixel(X, Y: Integer): TColor;
  2205. begin
  2206.   RequiredState([csHandleValid]);
  2207.   GetPixel := Windows.GetPixel(FHandle, X, Y);
  2208. end;
  2209.  
  2210. procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
  2211. begin
  2212.   Changing;
  2213.   RequiredState([csHandleValid, csPenValid]);
  2214.   Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
  2215.   Changed;
  2216. end;
  2217.  
  2218. function TCanvas.GetClipRect: TRect;
  2219. begin
  2220.   RequiredState([csHandleValid]);
  2221.   GetClipBox(FHandle, Result);
  2222. end;
  2223.  
  2224. function TCanvas.GetHandle: HDC;
  2225. begin
  2226.   Changing;
  2227.   RequiredState(csAllValid);
  2228.   Result := FHandle;
  2229. end;
  2230.  
  2231. procedure TCanvas.DeselectHandles;
  2232. begin
  2233.   if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
  2234.   begin
  2235.     SelectObject(FHandle, StockPen);
  2236.     SelectObject(FHandle, StockBrush);
  2237.     SelectObject(FHandle, StockFont);
  2238.     State := State - [csPenValid, csBrushValid, csFontValid];
  2239.   end;
  2240. end;
  2241.  
  2242. procedure TCanvas.CreateHandle;
  2243. begin
  2244. end;
  2245.  
  2246. procedure TCanvas.SetHandle(Value: HDC);
  2247. begin
  2248.   if FHandle <> Value then
  2249.   begin
  2250.     if FHandle <> 0 then
  2251.     begin
  2252.       DeselectHandles;
  2253.       FPenPos := GetPenPos;
  2254.       FHandle := 0;
  2255.       Exclude(State, csHandleValid);
  2256.     end;
  2257.     if Value <> 0 then
  2258.     begin
  2259.       Include(State, csHandleValid);
  2260.       FHandle := Value;
  2261.       SetPenPos(FPenPos);
  2262.     end;
  2263.   end;
  2264. end;
  2265.  
  2266. procedure TCanvas.RequiredState(ReqState: TCanvasState);
  2267.  
  2268.   procedure Error;
  2269.   begin
  2270.     raise EInvalidOperation.Create(SNoCanvasHandle);
  2271.   end;
  2272.  
  2273. var
  2274.   NeededState: TCanvasState;
  2275. begin
  2276.   NeededState := ReqState - State;
  2277.   if NeededState <> [] then
  2278.   begin
  2279.     if csHandleValid in NeededState then
  2280.     begin
  2281.       CreateHandle;
  2282.       if FHandle = 0 then Error;
  2283.     end;
  2284.     if csFontValid in NeededState then CreateFont;
  2285.     if csPenValid in NeededState then
  2286.     begin
  2287.       CreatePen;
  2288.       if Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
  2289.         Include(NeededState, csBrushValid);
  2290.     end;
  2291.     if csBrushValid in NeededState then CreateBrush;
  2292.     State := State + NeededState;
  2293.   end;
  2294. end;
  2295.  
  2296. procedure TCanvas.Changing;
  2297. begin
  2298.   if Assigned(FOnChanging) then FOnChanging(Self);
  2299. end;
  2300.  
  2301. procedure TCanvas.Changed;
  2302. begin
  2303.   if Assigned(FOnChange) then FOnChange(Self);
  2304. end;
  2305.  
  2306. procedure TCanvas.CreateFont;
  2307. begin
  2308.   SelectObject(FHandle, Font.GetHandle);
  2309.   SetTextColor(FHandle, ColorToRGB(Font.Color));
  2310. end;
  2311.  
  2312. procedure TCanvas.CreatePen;
  2313. const
  2314.   PenModes: array[TPenMode] of Word =
  2315.     (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
  2316.      R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
  2317.      R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);
  2318. begin
  2319.   SelectObject(FHandle, Pen.GetHandle);
  2320.   SetROP2(FHandle, PenModes[Pen.Mode]);
  2321. end;
  2322.  
  2323. procedure TCanvas.CreateBrush;
  2324. begin
  2325.   UnrealizeObject(Brush.Handle);
  2326.   SelectObject(FHandle, Brush.Handle);
  2327.   if Brush.Style = bsSolid then
  2328.   begin
  2329.     SetBkColor(FHandle, ColorToRGB(Brush.Color));
  2330.     SetBkMode(FHandle, OPAQUE);
  2331.   end
  2332.   else
  2333.   begin
  2334.     { Win95 doesn't draw brush hatches if bkcolor = brush color }
  2335.     { Since bkmode is transparent, nothing should use bkcolor anyway }
  2336.     SetBkColor(FHandle, not ColorToRGB(Brush.Color));
  2337.     SetBkMode(FHandle, TRANSPARENT);
  2338.   end;
  2339. end;
  2340.  
  2341. procedure TCanvas.FontChanged(AFont: TObject);
  2342. begin
  2343.   if csFontValid in State then
  2344.   begin
  2345.     Exclude(State, csFontValid);
  2346.     SelectObject(FHandle, StockFont);
  2347.   end;
  2348. end;
  2349.  
  2350. procedure TCanvas.PenChanged(APen: TObject);
  2351. begin
  2352.   if csPenValid in State then
  2353.   begin
  2354.     Exclude(State, csPenValid);
  2355.     SelectObject(FHandle, StockPen);
  2356.   end;
  2357. end;
  2358.  
  2359. procedure TCanvas.BrushChanged(ABrush: TObject);
  2360. begin
  2361.   if csBrushValid in State then
  2362.   begin
  2363.     Exclude(State, csBrushValid);
  2364.     SelectObject(FHandle, StockBrush);
  2365.   end;
  2366. end;
  2367.  
  2368. { Picture support }
  2369.  
  2370. { Icon and cursor types }
  2371.  
  2372. const
  2373.   rc3_StockIcon = 0;
  2374.   rc3_Icon = 1;
  2375.   rc3_Cursor = 2;
  2376.  
  2377. type
  2378.   PCursorOrIcon = ^TCursorOrIcon;
  2379.   TCursorOrIcon = packed record
  2380.     Reserved: Word;
  2381.     wType: Word;
  2382.     Count: Word;
  2383.   end;
  2384.  
  2385.   PIconRec = ^TIconRec;
  2386.   TIconRec = packed record
  2387.     Width: Byte;
  2388.     Height: Byte;
  2389.     Colors: Word;
  2390.     Reserved1: Word;
  2391.     Reserved2: Word;
  2392.     DIBSize: Longint;
  2393.     DIBOffset: Longint;
  2394.   end;
  2395.  
  2396.  
  2397. { Metafile types }
  2398.  
  2399. const
  2400.   WMFKey = $9AC6CDD7;
  2401.   WMFWord = $CDD7;
  2402.  
  2403. type
  2404.   PMetafileHeader = ^TMetafileHeader;
  2405.   TMetafileHeader = packed record
  2406.     Key: Longint;
  2407.     Handle: SmallInt;
  2408.     Box: TSmallRect;
  2409.     Inch: Word;
  2410.     Reserved: Longint;
  2411.     CheckSum: Word;
  2412.   end;
  2413.  
  2414. { Exception routines }
  2415.  
  2416. procedure InvalidOperation(const Str: string); near;
  2417. begin
  2418.   raise EInvalidGraphicOperation.Create(Str);
  2419. end;
  2420.  
  2421. procedure InvalidGraphic(const Str: string); near;
  2422. begin
  2423.   raise EInvalidGraphic.Create(Str);
  2424. end;
  2425.  
  2426. procedure InvalidBitmap; near;
  2427. begin
  2428.   InvalidGraphic(SInvalidBitmap);
  2429. end;
  2430.  
  2431. procedure InvalidIcon;
  2432. begin
  2433.   InvalidGraphic(SInvalidIcon);
  2434. end;
  2435.  
  2436. procedure InvalidMetafile;
  2437. begin
  2438.   InvalidGraphic(SInvalidMetafile);
  2439. end;
  2440.  
  2441. procedure OutOfResources;
  2442. begin
  2443.   raise EOutOfResources.Create(SOutOfResources);
  2444. end;
  2445.  
  2446. procedure GDIError;
  2447. var
  2448.   ErrorCode: Integer;
  2449.   Buf: array [Byte] of Char;
  2450. begin
  2451.   ErrorCode := GetLastError;
  2452.   if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
  2453.     ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
  2454.     raise EOutOfResources.Create(Buf)
  2455.   else
  2456.     OutOfResources;
  2457. end;
  2458.  
  2459. function GDICheck(Value: Integer): Integer;
  2460. begin
  2461.   if Value = 0 then GDIError;
  2462.   Result := Value;
  2463. end;
  2464.  
  2465. function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
  2466. var
  2467.   DC, Mem1, Mem2: HDC;
  2468.   Old1, Old2: HBITMAP;
  2469.   Bitmap: Windows.TBitmap;
  2470. begin
  2471.   Mem1 := CreateCompatibleDC(0);
  2472.   Mem2 := CreateCompatibleDC(0);
  2473.  
  2474.   try
  2475.     GetObject(Src, SizeOf(Bitmap), @Bitmap);
  2476.     if Mono then
  2477.       Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
  2478.     else
  2479.     begin
  2480.       DC := GetDC(0);
  2481.       if DC = 0 then GDIError;
  2482.       try
  2483.         Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
  2484.         if Result = 0 then GDIError;
  2485.       finally
  2486.         ReleaseDC(0, DC);
  2487.       end;
  2488.     end;
  2489.  
  2490.     if Result <> 0 then
  2491.     begin
  2492.       Old1 := SelectObject(Mem1, Src);
  2493.       Old2 := SelectObject(Mem2, Result);
  2494.  
  2495.       StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
  2496.         Bitmap.bmHeight, SrcCopy);
  2497.       if Old1 <> 0 then SelectObject(Mem1, Old1);
  2498.       if Old2 <> 0 then SelectObject(Mem2, Old2);
  2499.     end;
  2500.   finally
  2501.     DeleteDC(Mem1);
  2502.     DeleteDC(Mem2);
  2503.   end;
  2504. end;
  2505.  
  2506. function GetDInColors(BitCount: Word): Integer;
  2507. begin
  2508.   case BitCount of
  2509.     1, 4, 8: Result := 1 shl BitCount;
  2510.   else
  2511.     Result := 0;
  2512.   end;
  2513. end;
  2514.  
  2515. function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  2516. begin
  2517.   Dec(Alignment);
  2518.   Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  2519.   Result := Result div 8;
  2520. end;
  2521.  
  2522. function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  2523.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  2524.   MaskY: Integer): Boolean;
  2525. const
  2526.   ROP_DstCopy = $00AA0029;
  2527. var
  2528.   MemDC: HDC;
  2529.   MemBmp: HBITMAP;
  2530.   Save: THandle;
  2531.   crText, crBack: TColorRef;
  2532.   SavePal: HPALETTE;
  2533. begin
  2534.   Result := True;
  2535.   if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
  2536.   begin
  2537.     MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
  2538.     MemBmp := SelectObject(MaskDC, MemBmp);
  2539.     try
  2540.       MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
  2541.         MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
  2542.     finally
  2543.       MemBmp := SelectObject(MaskDC, MemBmp);
  2544.       DeleteObject(MemBmp);
  2545.     end;
  2546.     Exit;
  2547.   end;
  2548.   SavePal := 0;
  2549.   MemDC := GDICheck(CreateCompatibleDC(0));
  2550.   try
  2551.     MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, SrcW, SrcH));
  2552.     Save := SelectObject(MemDC, MemBmp);
  2553.     SavePal := SelectPalette(SrcDC, SystemPalette16, False);
  2554.     SelectPalette(SrcDC, SavePal, False);
  2555.     if SavePal <> 0 then
  2556.       SavePal := SelectPalette(MemDC, SavePal, True)
  2557.     else
  2558.       SavePal := SelectPalette(MemDC, SystemPalette16, True);
  2559.     RealizePalette(MemDC);
  2560.  
  2561.     StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcCopy);
  2562.     StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcErase);
  2563.     crText := SetTextColor(DstDC, $0);
  2564.     crBack := SetBkColor(DstDC, $FFFFFF);
  2565.     StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
  2566.     StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
  2567.     SetTextColor(DstDC, crText);
  2568.     SetBkColor(DstDC, crBack);
  2569.  
  2570.     if Save <> 0 then SelectObject(MemDC, Save);
  2571.     DeleteObject(MemBmp);
  2572.   finally
  2573.     if SavePal <> 0 then SelectPalette(MemDC, SavePal, False);
  2574.     DeleteDC(MemDC);
  2575.   end;
  2576. end;
  2577.  
  2578. type
  2579.   PRGBTripleArray = ^TRGBTripleArray;
  2580.   TRGBTripleArray = array [Byte] of TRGBTriple;
  2581.   PRGBQuadArray = ^TRGBQuadArray;
  2582.   TRGBQuadArray = array [Byte] of TRGBQuad;
  2583.  
  2584. { RGBTripleToQuad performs in-place conversion of an OS2 color
  2585.   table into a DIB color table.   }
  2586. procedure RGBTripleToQuad(var ColorTable);
  2587. var
  2588.   I: Integer;
  2589.   P3: PRGBTripleArray;
  2590.   P4: PRGBQuadArray;
  2591. begin
  2592.   P3 := PRGBTripleArray(@ColorTable);
  2593.   P4 := Pointer(P3);
  2594.   for I := 255 downto 1 do  // don't move zeroth item
  2595.     with P4^[I], P3^[I] do
  2596.     begin                     // order is significant for last item moved
  2597.       rgbRed := rgbtRed;
  2598.       rgbGreen := rgbtGreen;
  2599.       rgbBlue := rgbtBlue;
  2600.       rgbReserved := 0;
  2601.     end;
  2602.   P4^[0].rgbReserved := 0;
  2603. end;
  2604.  
  2605. { RGBQuadToTriple performs the inverse of RGBTripleToQuad. }
  2606. procedure RGBQuadToTriple(var ColorTable; var ColorCount: Integer);
  2607. var
  2608.   I: Integer;
  2609.   P3: PRGBTripleArray;
  2610.   P4: PRGBQuadArray;
  2611. begin
  2612.   P3 := PRGBTripleArray(@ColorTable);
  2613.   P4 := Pointer(P3);
  2614.   for I := 1 to ColorCount-1 do  // don't move zeroth item
  2615.     with P4^[I], P3^[I] do
  2616.     begin
  2617.       rgbtRed := rgbRed;
  2618.       rgbtGreen := rgbGreen;
  2619.       rgbtBlue := rgbBlue;
  2620.     end;
  2621.   if ColorCount < 256 then
  2622.   begin
  2623.     FillChar(P3^[ColorCount], (256 - ColorCount) * sizeof(TRGBTriple), 0);
  2624.     ColorCount := 256;   // OS2 color tables always have 256 entries
  2625.   end;
  2626. end;
  2627.  
  2628. procedure ByteSwapColors(var Colors; Count: Integer);
  2629. var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  2630.   SysInfo: TSystemInfo;
  2631. begin
  2632.   GetSystemInfo(SysInfo);
  2633.   asm
  2634.         MOV   EDX, Colors
  2635.         MOV   ECX, Count
  2636.         DEC   ECX
  2637.         JS    @@END
  2638.         LEA   EAX, SysInfo
  2639.         CMP   [EAX].TSystemInfo.wProcessorLevel, 3
  2640.         JE    @@386
  2641.   @@1:  MOV   EAX, [EDX+ECX*4]
  2642.         BSWAP EAX
  2643.         SHR   EAX,8
  2644.         MOV   [EDX+ECX*4],EAX
  2645.         DEC   ECX
  2646.         JNS   @@1
  2647.         JMP   @@END
  2648.   @@386:
  2649.         PUSH  EBX
  2650.   @@2:  XOR   EBX,EBX
  2651.         MOV   EAX, [EDX+ECX*4]
  2652.         MOV   BH, AL
  2653.         MOV   BL, AH
  2654.         SHR   EAX,16
  2655.         SHL   EBX,8
  2656.         MOV   BL, AL
  2657.         MOV   [EDX+ECX*4],EBX
  2658.         DEC   ECX
  2659.         JNS   @@2
  2660.         POP   EBX
  2661.     @@END:
  2662.   end;
  2663. end;
  2664.  
  2665. function CreateSystemPalette(const Entries: array of TColor): HPALETTE;
  2666. var
  2667.   DC: HDC;
  2668.   SysPalSize: Integer;
  2669.   Pal: TMaxLogPalette;
  2670. begin
  2671.   Pal.palVersion := $300;
  2672.   Pal.palNumEntries := 16;
  2673.   Move(Entries, Pal.palPalEntry, 16 * SizeOf(TColor));
  2674.   DC := GetDC(0);
  2675.   try
  2676.     SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2677.     { Ignore the disk image of the palette for 16 color bitmaps.
  2678.       Replace with the first and last 8 colors of the system palette }
  2679.     if SysPalSize >= 16 then
  2680.     begin
  2681.       GetSystemPaletteEntries(DC, 0, 8, Pal.palPalEntry);
  2682.       { Is light and dark gray swapped? }
  2683.       if TColor(Pal.palPalEntry[7]) = clSilver then
  2684.       begin
  2685.         GetSystemPaletteEntries(DC, SysPalSize - 8, 1, Pal.palPalEntry[7]);
  2686.         GetSystemPaletteEntries(DC, SysPalSize - 7, 7, Pal.palPalEntry[Pal.palNumEntries - 7]);
  2687.         GetSystemPaletteEntries(DC, 7, 1, Pal.palPalEntry[8]);
  2688.       end
  2689.       else
  2690.         GetSystemPaletteEntries(DC, SysPalSize - 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
  2691.     end
  2692.     else
  2693.     begin
  2694.     end;
  2695.   finally
  2696.     ReleaseDC(0,DC);
  2697.   end;
  2698.   Result := CreatePalette(PLogPalette(@Pal)^);
  2699. end;
  2700.  
  2701. function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
  2702. var
  2703.   DC: HDC;
  2704.   SysPalSize: Integer;
  2705. begin
  2706.   Result := False;
  2707.   if SystemPalette16 <> 0 then
  2708.   begin
  2709.     DC := GetDC(0);
  2710.     try
  2711.       SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2712.       if SysPalSize >= 16 then
  2713.       begin
  2714.         { Ignore the disk image of the palette for 16 color bitmaps.
  2715.           Replace with the first and last 8 colors of the system palette }
  2716.         GetPaletteEntries(SystemPalette16, 0, 8, Pal.palPalEntry);
  2717.         GetPaletteEntries(SystemPalette16, 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
  2718.         Result := True;
  2719.       end
  2720.     finally
  2721.       ReleaseDC(0,DC);
  2722.     end;
  2723.   end;
  2724. end;
  2725.  
  2726. function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
  2727.   ColorCount: Integer): HPalette;
  2728. var
  2729.   DC: HDC;
  2730.   Save: THandle;
  2731.   Pal: TMaxLogPalette;
  2732. begin
  2733.   Result := 0;
  2734.   Pal.palVersion := $300;
  2735.   if DIBHandle <> 0 then
  2736.   begin
  2737.     DC := CreateCompatibleDC(0);
  2738.     Save := SelectObject(DC, DIBHandle);
  2739.     Pal.palNumEntries := GetDIBColorTable(DC, 0, 256, Pal.palPalEntry);
  2740.     SelectObject(DC, Save);
  2741.     DeleteDC(DC);
  2742.   end
  2743.   else
  2744.   begin
  2745.     Pal.palNumEntries := ColorCount;
  2746.     Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
  2747.   end;
  2748.   if Pal.palNumEntries = 0 then Exit;
  2749.   if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
  2750.     ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  2751.   Result := CreatePalette(PLogPalette(@Pal)^);
  2752. end;
  2753.  
  2754. function PaletteToDIBColorTable(Pal: HPalette;
  2755.   var ColorTable: array of TRGBQuad): Integer;
  2756. begin
  2757.   Result := 0;
  2758.   if (Pal = 0) or
  2759.      (GetObject(Pal, sizeof(Result), @Result) = 0) or
  2760.      (Result = 0) then Exit;
  2761.   if Result > High(ColorTable)+1 then Result := High(ColorTable)+1;
  2762.   GetPaletteEntries(Pal, 0, Result, ColorTable);
  2763.   ByteSwapColors(ColorTable, Result);
  2764. end;
  2765.  
  2766. procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);
  2767. type
  2768.   PLongArray = ^TLongArray;
  2769.   TLongArray = array[0..1] of Longint;
  2770. var
  2771.   Temp: HBITMAP;
  2772.   NumColors: Integer;
  2773.   DC: HDC;
  2774.   Bits: Pointer;
  2775.   Colors: PLongArray;
  2776.   IconSize: TPoint;
  2777. begin
  2778.   IconSize.X := GetSystemMetrics(SM_CXICON);
  2779.   IconSize.Y := GetSystemMetrics(SM_CYICON);
  2780.   with BI do
  2781.   begin
  2782.     biHeight := biHeight shr 1; { Size in record is doubled }
  2783.     biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2784.     NumColors := GetDInColors(biBitCount);
  2785.   end;
  2786.   DC := GetDC(0);
  2787.   if DC = 0 then OutOfResources;
  2788.   try
  2789.     Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
  2790.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2791.     try
  2792.       XorBits := DupBits(Temp, IconSize, False);
  2793.     finally
  2794.       DeleteObject(Temp);
  2795.     end;
  2796.     with BI do
  2797.     begin
  2798.       Inc(Longint(Bits), biSizeImage);
  2799.       biBitCount := 1;
  2800.       biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2801.       biClrUsed := 2;
  2802.       biClrImportant := 2;
  2803.     end;
  2804.     Colors := Pointer(Longint(@BI) + SizeOf(BI));
  2805.     Colors^[0] := 0;
  2806.     Colors^[1] := $FFFFFF;
  2807.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2808.     try
  2809.       AndBits := DupBits(Temp, IconSize, True);
  2810.     finally
  2811.       DeleteObject(Temp);
  2812.     end;
  2813.   finally
  2814.     ReleaseDC(0, DC);
  2815.   end;
  2816. end;
  2817.  
  2818. procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  2819.   StartOffset: Integer);
  2820. type
  2821.   PIconRecArray = ^TIconRecArray;
  2822.   TIconRecArray = array[0..300] of TIconRec;
  2823. var
  2824.   List: PIconRecArray;
  2825.   HeaderLen, Length: Integer;
  2826.   Colors, BitsPerPixel: Word;
  2827.   C1, C2, N, Index: Integer;
  2828.   IconSize: TPoint;
  2829.   DC: HDC;
  2830.   BI: PBitmapInfoHeader;
  2831.   ResData: Pointer;
  2832.   XorBits, AndBits: HBITMAP;
  2833.   XorInfo, AndInfo: Windows.TBitmap;
  2834.   XorMem, AndMem: Pointer;
  2835.   XorLen, AndLen: Integer;
  2836. {
  2837. var
  2838.   P: PChar;
  2839. begin
  2840.   P := Pointer(Integer((Stream as TCustomMemoryStream).Memory) + Stream.Position);
  2841. //  N := LookupIconIdFromDirectoryEx(Pointer(P), True, 0, 0, LR_DEFAULTCOLOR);
  2842.   Icon := GDICheck(CreateIconFromResourceEx(
  2843.     Pointer(P + PIconRec(P)^.DIBOffset - StartOffset),
  2844.     PIconRec(P)^.DIBSize, True, $00030000, 0, 0, LR_DEFAULTCOLOR));
  2845. }
  2846. begin
  2847.   HeaderLen := SizeOf(TIconRec) * ImageCount;
  2848.   List := AllocMem(HeaderLen);
  2849.   try
  2850.     Stream.Read(List^, HeaderLen);
  2851.     IconSize.X := GetSystemMetrics(SM_CXICON);
  2852.     IconSize.Y := GetSystemMetrics(SM_CYICON);
  2853.     DC := GetDC(0);
  2854.     if DC = 0 then OutOfResources;
  2855.     try
  2856.       BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  2857.       if BitsPerPixel = 24 then
  2858.         Colors := 0
  2859.       else
  2860.         Colors := 1 shl BitsPerPixel;
  2861.     finally
  2862.       ReleaseDC(0, DC);
  2863.     end;
  2864.     Index := -1;
  2865.  
  2866.     { the following code determines which image most closely matches the
  2867.       current device. It is not meant to absolutely match Windows
  2868.       (known broken) algorithm }
  2869.     C2 := 0;
  2870.     for N := 0 to ImageCount - 1 do
  2871.     begin
  2872.       C1 := List^[N].Colors;
  2873.       if C1 = Colors then
  2874.       begin
  2875.         Index := N;
  2876.         Break;
  2877.       end
  2878.       else if Index = -1 then
  2879.       begin
  2880.         if C1 <= Colors then
  2881.         begin
  2882.           Index := N;
  2883.           C2 := List^[N].Colors;
  2884.         end;
  2885.       end
  2886.       else
  2887.         if C1 > C2 then
  2888.           Index := N;
  2889.     end;
  2890.     if Index = -1 then Index := 0;
  2891.     with List^[Index] do
  2892.     begin
  2893.       BI := AllocMem(DIBSize);
  2894.       try
  2895.         Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
  2896.         Stream.Read(BI^, DIBSize);
  2897.         TwoBitsFromDIB(BI^, XorBits, AndBits);
  2898.         GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
  2899.         GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
  2900.         with AndInfo do
  2901.           AndLen := bmWidthBytes * bmHeight * bmPlanes;
  2902.         with XorInfo do
  2903.           XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
  2904.         Length := AndLen + XorLen;
  2905.         ResData := AllocMem(Length);
  2906.         try
  2907.           AndMem := ResData;
  2908.           with AndInfo do
  2909.             XorMem := Pointer(Longint(ResData) + AndLen);
  2910.           GetBitmapBits(AndBits, AndLen, AndMem);
  2911.           GetBitmapBits(XorBits, XorLen, XorMem);
  2912.           DeleteObject(XorBits);
  2913.           DeleteObject(AndBits);
  2914.           Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
  2915.             XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
  2916.           if Icon = 0 then GDIError;
  2917.         finally
  2918.           FreeMem(ResData, Length);
  2919.         end;
  2920.       finally
  2921.         FreeMem(BI, DIBSize);
  2922.       end;
  2923.     end;
  2924.   finally
  2925.     FreeMem(List, HeaderLen);
  2926.   end;
  2927. end;
  2928.  
  2929. function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
  2930. type
  2931.   PWord = ^Word;
  2932. var
  2933.   pW: PWord;
  2934.   pEnd: PWord;
  2935. begin
  2936.   Result := 0;
  2937.   pW := @WMF;
  2938.   pEnd := @WMF.CheckSum;
  2939.   while Longint(pW) < Longint(pEnd) do
  2940.   begin
  2941.     Result := Result xor pW^;
  2942.     Inc(Longint(pW), SizeOf(Word));
  2943.   end;
  2944. end;
  2945.  
  2946. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  2947.   Colors: Integer);
  2948. var
  2949.   DS: TDIBSection;
  2950.   Bytes: Integer;
  2951. begin
  2952.   DS.dsbmih.biSize := 0;
  2953.   Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
  2954.   if Bytes = 0 then InvalidBitmap
  2955.   else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
  2956.     (DS.dsbmih.biSize >= sizeof(DS.dsbmih)) then
  2957.     BI := DS.dsbmih
  2958.   else
  2959.   begin
  2960.     FillChar(BI, sizeof(BI), 0);
  2961.     with BI, DS.dsbm do
  2962.     begin
  2963.       biSize := SizeOf(BI);
  2964.       biWidth := bmWidth;
  2965.       biHeight := bmHeight;
  2966.     end;
  2967.   end;
  2968.   if Colors <> 0 then
  2969.     case Colors of
  2970.       2: BI.biBitCount := 1;
  2971.       16: BI.biBitCount := 4;
  2972.       256: BI.biBitCount := 8;
  2973.     end
  2974.   else BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  2975.   BI.biPlanes := 1;
  2976.   if BI.biSizeImage = 0 then
  2977.     BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
  2978. end;
  2979.  
  2980. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2981.   var ImageSize: DWORD; Colors: Integer);
  2982. var
  2983.   BI: TBitmapInfoHeader;
  2984. begin
  2985.   InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  2986.   if BI.biBitCount > 8 then
  2987.   begin
  2988.     InfoHeaderSize := SizeOf(TBitmapInfoHeader);
  2989.     if (BI.biCompression and BI_BITFIELDS) <> 0 then
  2990.       Inc(InfoHeaderSize, 12);
  2991.   end
  2992.   else
  2993.     InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
  2994.       (1 shl BI.biBitCount);
  2995.   ImageSize := BI.biSizeImage;
  2996. end;
  2997.  
  2998. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  2999.   var ImageSize: DWORD);
  3000. begin
  3001.   InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
  3002. end;
  3003.  
  3004. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  3005.   var BitmapInfo; var Bits; Colors: Integer): Boolean;
  3006. var
  3007.   OldPal: HPALETTE;
  3008.   DC: HDC;
  3009. begin
  3010.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  3011.   OldPal := 0;
  3012.   DC := CreateCompatibleDC(0);
  3013.   try
  3014.     if Palette <> 0 then
  3015.     begin
  3016.       OldPal := SelectPalette(DC, Palette, False);
  3017.       RealizePalette(DC);
  3018.     end;
  3019.     Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
  3020.       TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  3021.   finally
  3022.     if OldPal <> 0 then SelectPalette(DC, OldPal, False);
  3023.     DeleteDC(DC);
  3024.   end;
  3025. end;
  3026.  
  3027. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  3028. begin
  3029.   Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
  3030. end;
  3031.  
  3032. procedure WinError;
  3033. begin
  3034. end;
  3035.  
  3036. procedure CheckBool(Result: Bool);
  3037. begin
  3038.   if not Result then WinError;
  3039. end;
  3040.  
  3041. procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
  3042. var
  3043.   IconInfo: TIconInfo;
  3044.   MonoInfoSize, ColorInfoSize: Integer;
  3045.   MonoBitsSize, ColorBitsSize: DWORD;
  3046.   MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  3047.   CI: TCursorOrIcon;
  3048.   List: TIconRec;
  3049.   Length: Longint;
  3050. begin
  3051.   FillChar(CI, SizeOf(CI), 0);
  3052.   FillChar(List, SizeOf(List), 0);
  3053.   CheckBool(GetIconInfo(Icon, IconInfo));
  3054.   try
  3055.     InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
  3056.     InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
  3057.     MonoInfo := nil;
  3058.     MonoBits := nil;
  3059.     ColorInfo := nil;
  3060.     ColorBits := nil;
  3061.     try
  3062.       MonoInfo := AllocMem(MonoInfoSize);
  3063.       MonoBits := AllocMem(MonoBitsSize);
  3064.       ColorInfo := AllocMem(ColorInfoSize);
  3065.       ColorBits := AllocMem(ColorBitsSize);
  3066.       InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
  3067.       InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
  3068.       if WriteLength then
  3069.       begin
  3070.         Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
  3071.           ColorBitsSize + MonoBitsSize;
  3072.         Stream.Write(Length, SizeOf(Length));
  3073.       end;
  3074.       with CI do
  3075.       begin
  3076.         CI.wType := RC3_ICON;
  3077.         CI.Count := 1;
  3078.       end;
  3079.       Stream.Write(CI, SizeOf(CI));
  3080.       with List, PBitmapInfoHeader(ColorInfo)^ do
  3081.       begin
  3082.         Width := biWidth;
  3083.         Height := biHeight;
  3084.         Colors := biPlanes * biBitCount;
  3085.         DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
  3086.         DIBOffset := SizeOf(CI) + SizeOf(List);
  3087.       end;
  3088.       Stream.Write(List, SizeOf(List));
  3089.       with PBitmapInfoHeader(ColorInfo)^ do
  3090.         Inc(biHeight, biHeight); { color height includes mono bits }
  3091.       Stream.Write(ColorInfo^, ColorInfoSize);
  3092.       Stream.Write(ColorBits^, ColorBitsSize);
  3093.       Stream.Write(MonoBits^, MonoBitsSize);
  3094.     finally
  3095.       FreeMem(ColorInfo, ColorInfoSize);
  3096.       FreeMem(ColorBits, ColorBitsSize);
  3097.       FreeMem(MonoInfo, MonoInfoSize);
  3098.       FreeMem(MonoBits, MonoBitsSize);
  3099.     end;
  3100.   finally
  3101.     DeleteObject(IconInfo.hbmColor);
  3102.     DeleteObject(IconInfo.hbmMask);
  3103.   end;
  3104. end;
  3105.  
  3106. { TGraphic }
  3107.  
  3108. constructor TGraphic.Create;
  3109. begin
  3110.   inherited Create;
  3111. end;
  3112.  
  3113. procedure TGraphic.Changed(Sender: TObject);
  3114. begin
  3115.   FModified := True;
  3116.   if Assigned(FOnChange) then FOnChange(Self);
  3117. end;
  3118.  
  3119. procedure TGraphic.DefineProperties(Filer: TFiler);
  3120.  
  3121.   function DoWrite: Boolean;
  3122.   begin
  3123.     if Filer.Ancestor <> nil then
  3124.       Result := not (Filer.Ancestor is TGraphic) or
  3125.         not Equals(TGraphic(Filer.Ancestor))
  3126.     else
  3127.       Result := not Empty;
  3128.   end;
  3129.  
  3130. begin
  3131.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3132. end;
  3133.  
  3134. function TGraphic.Equals(Graphic: TGraphic): Boolean;
  3135. var
  3136.   MyImage, GraphicsImage: TMemoryStream;
  3137. begin
  3138.   Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
  3139.   if Empty or Graphic.Empty then
  3140.   begin
  3141.     Result := Empty and Graphic.Empty;
  3142.     Exit;
  3143.   end;
  3144.   if Result then
  3145.   begin
  3146.     MyImage := TMemoryStream.Create;
  3147.     try
  3148.       WriteData(MyImage);
  3149.       GraphicsImage := TMemoryStream.Create;
  3150.       try
  3151.         Graphic.WriteData(GraphicsImage);
  3152.         Result := (MyImage.Size = GraphicsImage.Size) and
  3153.           CompareMem(MyImage.Memory, GraphicsImage.Memory, MyImage.Size);
  3154.       finally
  3155.         GraphicsImage.Free;
  3156.       end;
  3157.     finally
  3158.       MyImage.Free;
  3159.     end;
  3160.   end;
  3161. end;
  3162.  
  3163. function TGraphic.GetPalette: HPALETTE;
  3164. begin
  3165.   Result := 0;
  3166. end;
  3167.  
  3168. function TGraphic.GetTransparent: Boolean;
  3169. begin
  3170.   Result := FTransparent;
  3171. end;
  3172.  
  3173. procedure TGraphic.LoadFromFile(const Filename: string);
  3174. var
  3175.   Stream: TStream;
  3176. begin
  3177.   Stream := TFileStream.Create(Filename, fmOpenRead);
  3178.   try
  3179.     LoadFromStream(Stream);
  3180.   finally
  3181.     Stream.Free;
  3182.   end;
  3183. end;
  3184.  
  3185. procedure TGraphic.Progress(Sender: TObject; Stage: TProgressStage;
  3186.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3187. begin
  3188.   if Assigned(FOnProgress) then
  3189.     FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3190. end;
  3191.  
  3192. procedure TGraphic.ReadData(Stream: TStream);
  3193. begin
  3194.   LoadFromStream(Stream);
  3195. end;
  3196.  
  3197. procedure TGraphic.SaveToFile(const Filename: string);
  3198. var
  3199.   Stream: TStream;
  3200. begin
  3201.   Stream := TFileStream.Create(Filename, fmCreate);
  3202.   try
  3203.     SaveToStream(Stream);
  3204.   finally
  3205.     Stream.Free;
  3206.   end;
  3207. end;
  3208.  
  3209. procedure TGraphic.SetPalette(Value: HPalette);
  3210. begin
  3211. end;
  3212.  
  3213. procedure TGraphic.SetModified(Value: Boolean);
  3214. begin
  3215.   if Value then
  3216.     Changed(Self) else
  3217.     FModified := False;
  3218. end;
  3219.  
  3220. procedure TGraphic.SetTransparent(Value: Boolean);
  3221. begin
  3222.   if Value <> FTransparent then
  3223.   begin
  3224.     FTransparent := Value;
  3225.     Changed(Self);
  3226.   end;
  3227. end;
  3228.  
  3229. procedure TGraphic.WriteData(Stream: TStream);
  3230. begin
  3231.   SaveToStream(Stream);
  3232. end;
  3233.  
  3234. { TPicture }
  3235.  
  3236. type
  3237.   PFileFormat = ^TFileFormat;
  3238.   TFileFormat = record
  3239.     GraphicClass: TGraphicClass;
  3240.     Extension: string;
  3241.     Description: string;
  3242.     DescResID: Integer;
  3243.   end;
  3244.  
  3245.   TFileFormatsList = class(TList)
  3246.   public
  3247.     constructor Create;
  3248.     destructor Destroy; override;
  3249.     procedure Add(const Ext, Desc: String; DescID: Integer; AClass: TGraphicClass);
  3250.     function FindExt(Ext: string): TGraphicClass;
  3251.     function FindClassName(const Classname: string): TGraphicClass;
  3252.     procedure Remove(AClass: TGraphicClass);
  3253.     procedure BuildFilterStrings(GraphicClass: TGraphicClass;
  3254.       var Descriptions, Filters: string);
  3255.   end;
  3256.  
  3257. constructor TFileFormatsList.Create;
  3258. begin
  3259.   inherited Create;
  3260.   Add('wmf', SVMetafiles, 0, TMetafile);
  3261.   Add('emf', SVEnhMetafiles, 0, TMetafile);
  3262.   Add('ico', SVIcons, 0, TIcon);
  3263.   Add('bmp', SVBitmaps, 0, TBitmap);
  3264. end;
  3265.  
  3266. destructor TFileFormatsList.Destroy;
  3267. var
  3268.   I: Integer;
  3269. begin
  3270.   for I := 0 to Count-1 do
  3271.     Dispose(PFileFormat(Items[I]));
  3272.   inherited Destroy;
  3273. end;
  3274.  
  3275. procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
  3276.   AClass: TGraphicClass);
  3277. var
  3278.   NewRec: PFileFormat;
  3279. begin
  3280.   New(NewRec);
  3281.   with NewRec^ do
  3282.   begin
  3283.     Extension := AnsiLowerCase(Ext);
  3284.     GraphicClass := AClass;
  3285.     Description := Desc;
  3286.     DescResID := DescID;
  3287.   end;
  3288.   inherited Add(NewRec);
  3289. end;
  3290.  
  3291. function TFileFormatsList.FindExt(Ext: string): TGraphicClass;
  3292. var
  3293.   I: Integer;
  3294. begin
  3295.   Ext := AnsiLowerCase(Ext);
  3296.   for I := Count-1 downto 0 do
  3297.     with PFileFormat(Items[I])^ do
  3298.       if Extension = Ext then
  3299.       begin
  3300.         Result := GraphicClass;
  3301.         Exit;
  3302.       end;
  3303.   Result := nil;
  3304. end;
  3305.  
  3306. function TFileFormatsList.FindClassName(const ClassName: string): TGraphicClass;
  3307. var
  3308.   I: Integer;
  3309. begin
  3310.   for I := Count-1 downto 0 do
  3311.   begin
  3312.     Result := PFileFormat(Items[I])^.GraphicClass;
  3313.     if Result.ClassName = Classname then Exit;
  3314.   end;
  3315.   Result := nil;
  3316. end;
  3317.  
  3318. procedure TFileFormatsList.Remove(AClass: TGraphicClass);
  3319. var
  3320.   I: Integer;
  3321.   P: PFileFormat;
  3322. begin
  3323.   for I := Count-1 downto 0 do
  3324.   begin
  3325.     P := PFileFormat(Items[I]);
  3326.     if P^.GraphicClass.InheritsFrom(AClass) then
  3327.     begin
  3328.       Dispose(P);
  3329.       Delete(I);
  3330.     end;
  3331.   end;
  3332. end;
  3333.  
  3334. procedure TFileFormatsList.BuildFilterStrings(GraphicClass: TGraphicClass;
  3335.   var Descriptions, Filters: string);
  3336. var
  3337.   C, I: Integer;
  3338.   P: PFileFormat;
  3339. begin
  3340.   Descriptions := '';
  3341.   Filters := '';
  3342.   C := 0;
  3343.   for I := Count-1 downto 0 do
  3344.   begin
  3345.     P := PFileFormat(Items[I]);
  3346.     if P^.GraphicClass.InheritsFrom(GraphicClass) and (P^.Extension <> '') then
  3347.       with P^ do
  3348.       begin
  3349.         if C <> 0 then
  3350.         begin
  3351.           Descriptions := Descriptions + '|';
  3352.           Filters := Filters + ';';
  3353.         end;
  3354.         if (Description = '') and (DescResID <> 0) then
  3355.           Description := LoadStr(DescResID);
  3356.         FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
  3357.         FmtStr(Filters, '%s*.%s', [Filters, Extension]);
  3358.         Inc(C);
  3359.       end;
  3360.   end;
  3361.   if C > 1 then
  3362.     FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
  3363. end;
  3364.  
  3365. type
  3366.   TClipboardFormats = class
  3367.   private
  3368.     FClasses: TList;
  3369.     FFormats: TList;
  3370.   public
  3371.     constructor Create;
  3372.     destructor Destroy; override;
  3373.     procedure Add(Fmt: Word; AClass: TGraphicClass);
  3374.     function FindFormat(Fmt: Word): TGraphicClass;
  3375.     procedure Remove(AClass: TGraphicClass);
  3376.   end;
  3377.  
  3378. constructor TClipboardFormats.Create;
  3379. begin
  3380.   FClasses := TList.Create;
  3381.   FFormats := TList.Create;
  3382.   Add(CF_METAFILEPICT, TMetafile);
  3383.   Add(CF_ENHMETAFILE, TMetafile);
  3384.   Add(CF_BITMAP, TBitmap);
  3385. end;
  3386.  
  3387. destructor TClipboardFormats.Destroy;
  3388. begin
  3389.   FClasses.Free;
  3390.   FFormats.Free;
  3391. end;
  3392.  
  3393. procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
  3394. var
  3395.   I: Integer;
  3396. begin
  3397.   I := FClasses.Add(AClass);
  3398.   try
  3399.     FFormats.Add(Pointer(Integer(Fmt)));
  3400.   except
  3401.     FClasses.Delete(I);
  3402.     raise;
  3403.   end;
  3404. end;
  3405.  
  3406. function TClipboardFormats.FindFormat(Fmt: Word): TGraphicClass;
  3407. var
  3408.   I: Integer;
  3409. begin
  3410.   for I := FFormats.Count-1 downto 0 do
  3411.     if Word(FFormats[I]) = Fmt then
  3412.     begin
  3413.       Result := FClasses[I];
  3414.       Exit;
  3415.     end;
  3416.   Result := nil;
  3417. end;
  3418.  
  3419. procedure TClipboardFormats.Remove(AClass: TGraphicClass);
  3420. var
  3421.   I: Integer;
  3422. begin
  3423.   for I := FClasses.Count-1 downto 0 do
  3424.     if TGraphicClass(FClasses[I]).InheritsFrom(AClass) then
  3425.     begin
  3426.       FClasses.Delete(I);
  3427.       FFormats.Delete(I);
  3428.     end;
  3429. end;
  3430.  
  3431. var
  3432.   ClipboardFormats: TClipboardFormats = nil;
  3433.   FileFormats: TFileFormatsList = nil;
  3434.  
  3435. function GetFileFormats: TFileFormatsList;
  3436. begin
  3437.   if FileFormats = nil then FileFormats := TFileFormatsList.Create;
  3438.   Result := FileFormats;
  3439. end;
  3440.  
  3441. function GetClipboardFormats: TClipboardFormats;
  3442. begin
  3443.   if ClipboardFormats = nil then ClipboardFormats := TClipboardFormats.Create;
  3444.   Result := ClipboardFormats;
  3445. end;
  3446.  
  3447. constructor TPicture.Create;
  3448. begin
  3449.   inherited Create;
  3450.   GetFileFormats;
  3451.   GetClipboardFormats;
  3452. end;
  3453.  
  3454. destructor TPicture.Destroy;
  3455. begin
  3456.   FGraphic.Free;
  3457.   inherited Destroy;
  3458. end;
  3459.  
  3460. procedure TPicture.AssignTo(Dest: TPersistent);
  3461. begin
  3462.   if Graphic is Dest.ClassType then
  3463.     Dest.Assign(Graphic)
  3464.   else
  3465.     inherited AssignTo(Dest);
  3466. end;
  3467.  
  3468. procedure TPicture.ForceType(GraphicType: TGraphicClass);
  3469. begin
  3470.   if not (Graphic is GraphicType) then
  3471.   begin
  3472.     FGraphic.Free;
  3473.     FGraphic := nil;
  3474.     FGraphic := GraphicType.Create;
  3475.     FGraphic.OnChange := Changed;
  3476.     FGraphic.OnProgress := Progress;
  3477.     Changed(Self);
  3478.   end;
  3479. end;
  3480.  
  3481. function TPicture.GetBitmap: TBitmap;
  3482. begin
  3483.   ForceType(TBitmap);
  3484.   Result := TBitmap(Graphic);
  3485. end;
  3486.  
  3487. function TPicture.GetIcon: TIcon;
  3488. begin
  3489.   ForceType(TIcon);
  3490.   Result := TIcon(Graphic);
  3491. end;
  3492.  
  3493. function TPicture.GetMetafile: TMetafile;
  3494. begin
  3495.   ForceType(TMetafile);
  3496.   Result := TMetafile(Graphic);
  3497. end;
  3498.  
  3499. procedure TPicture.SetBitmap(Value: TBitmap);
  3500. begin
  3501.   SetGraphic(Value);
  3502. end;
  3503.  
  3504. procedure TPicture.SetIcon(Value: TIcon);
  3505. begin
  3506.   SetGraphic(Value);
  3507. end;
  3508.  
  3509. procedure TPicture.SetMetafile(Value: TMetafile);
  3510. begin
  3511.   SetGraphic(Value);
  3512. end;
  3513.  
  3514. procedure TPicture.SetGraphic(Value: TGraphic);
  3515. var
  3516.   NewGraphic: TGraphic;
  3517. begin
  3518.   NewGraphic := nil;
  3519.   if Value <> nil then
  3520.   begin
  3521.     NewGraphic := TGraphicClass(Value.ClassType).Create;
  3522.     NewGraphic.Assign(Value);
  3523.     NewGraphic.OnChange := Changed;
  3524.     NewGraphic.OnProgress := Progress;
  3525.   end;
  3526.   try
  3527.     FGraphic.Free;
  3528.     FGraphic := NewGraphic;
  3529.     Changed(Self);
  3530.   except
  3531.     NewGraphic.Free;
  3532.     raise;
  3533.   end;
  3534. end;
  3535.  
  3536. { Based on the extension of Filename, create the cooresponding TGraphic class
  3537.   and call its LoadFromFile method. }
  3538.  
  3539. procedure TPicture.LoadFromFile(const Filename: string);
  3540. var
  3541.   Ext: string;
  3542.   NewGraphic: TGraphic;
  3543.   GraphicClass: TGraphicClass;
  3544. begin
  3545.   Ext := ExtractFileExt(Filename);
  3546.   Delete(Ext, 1, 1);
  3547.   GraphicClass := FileFormats.FindExt(Ext);
  3548.   if GraphicClass = nil then
  3549.     raise EInvalidGraphic.CreateFmt(SUnknownExtension, [Ext]);
  3550.  
  3551.   NewGraphic := GraphicClass.Create;
  3552.   try
  3553.     NewGraphic.OnProgress := Progress;
  3554.     NewGraphic.LoadFromFile(Filename);
  3555.   except
  3556.     NewGraphic.Free;
  3557.     raise;
  3558.   end;
  3559.   FGraphic.Free;
  3560.   FGraphic := NewGraphic;
  3561.   FGraphic.OnChange := Changed;
  3562.   Changed(Self);
  3563. end;
  3564.  
  3565. procedure TPicture.SaveToFile(const Filename: string);
  3566. begin
  3567.   if FGraphic <> nil then FGraphic.SaveToFile(Filename);
  3568. end;
  3569.  
  3570. procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3571.   APalette: HPALETTE);
  3572. var
  3573.   NewGraphic: TGraphic;
  3574.   GraphicClass: TGraphicClass;
  3575. begin
  3576.   GraphicClass := ClipboardFormats.FindFormat(AFormat);
  3577.   if GraphicClass = nil then
  3578.     InvalidGraphic(SUnknownClipboardFormat);
  3579.  
  3580.   NewGraphic := GraphicClass.Create;
  3581.   try
  3582.     NewGraphic.OnProgress := Progress;
  3583.     NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
  3584.   except
  3585.     NewGraphic.Free;
  3586.     raise;
  3587.   end;
  3588.   FGraphic.Free;
  3589.   FGraphic := NewGraphic;
  3590.   FGraphic.OnChange := Changed;
  3591.   Changed(Self);
  3592. end;
  3593.  
  3594. procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  3595.   var APalette: HPALETTE);
  3596. begin
  3597.   if FGraphic <> nil then
  3598.     FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
  3599. end;
  3600.  
  3601. class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
  3602. begin
  3603.   Result := GetClipboardFormats.FindFormat(AFormat) <> nil;
  3604. end;
  3605.  
  3606. procedure TPicture.Assign(Source: TPersistent);
  3607. begin
  3608.   if Source = nil then
  3609.     SetGraphic(nil)
  3610.   else if Source is TPicture then
  3611.     SetGraphic(TPicture(Source).Graphic)
  3612.   else if Source is TGraphic then
  3613.     SetGraphic(TGraphic(Source))
  3614.   else
  3615.     inherited Assign(Source);
  3616. end;
  3617.  
  3618. class procedure TPicture.RegisterFileFormat(const AExtension,
  3619.   ADescription: string; AGraphicClass: TGraphicClass);
  3620. begin
  3621.   GetFileFormats.Add(AExtension, ADescription, 0, AGraphicClass);
  3622. end;
  3623.  
  3624. class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  3625.   ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  3626. begin
  3627.   GetFileFormats.Add(AExtension, '', ADescriptionResID, AGraphicClass);
  3628. end;
  3629.  
  3630. class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  3631.   AGraphicClass: TGraphicClass);
  3632. begin
  3633.   GetClipboardFormats.Add(AFormat, AGraphicClass);
  3634. end;
  3635.  
  3636. class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
  3637. begin
  3638.   if FileFormats <> nil then FileFormats.Remove(AClass);
  3639.   if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
  3640. end;
  3641.  
  3642. procedure TPicture.Changed(Sender: TObject);
  3643. begin
  3644.   if Assigned(FOnChange) then FOnChange(Self);
  3645.   if FNotify <> nil then FNotify.Changed;
  3646. end;
  3647.  
  3648. procedure TPicture.Progress(Sender: TObject; Stage: TProgressStage;
  3649.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3650. begin
  3651.   if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3652. end;
  3653.  
  3654. procedure TPicture.ReadData(Stream: TStream);
  3655. var
  3656.   CName: string[63];
  3657.   NewGraphic: TGraphic;
  3658.   GraphicClass: TGraphicClass;
  3659. begin
  3660.   Stream.Read(CName[0], 1);
  3661.   Stream.Read(CName[1], Integer(CName[0]));
  3662.   GraphicClass := FileFormats.FindClassName(CName);
  3663.   if GraphicClass <> nil then
  3664.   begin
  3665.     NewGraphic := GraphicClass.Create;
  3666.     try
  3667.       NewGraphic.ReadData(Stream);
  3668.     except
  3669.       NewGraphic.Free;
  3670.       raise;
  3671.     end;
  3672.     FGraphic.Free;
  3673.     FGraphic := NewGraphic;
  3674.     FGraphic.OnChange := Changed;
  3675.     FGraphic.OnProgress := Progress;
  3676.     Changed(Self);
  3677.   end;
  3678. end;
  3679.  
  3680. procedure TPicture.WriteData(Stream: TStream);
  3681. var
  3682.   CName: string[63];
  3683. begin
  3684.   with Stream do
  3685.   begin
  3686.     CName := Graphic.ClassName;
  3687.     Write(CName, Length(CName) + 1);
  3688.     Graphic.WriteData(Stream);
  3689.   end;
  3690. end;
  3691.  
  3692. procedure TPicture.DefineProperties(Filer: TFiler);
  3693.  
  3694.   function DoWrite: Boolean;
  3695.   var
  3696.     Ancestor: TPicture;
  3697.   begin
  3698.     if Filer.Ancestor <> nil then
  3699.     begin
  3700.       Result := True;
  3701.       if Filer.Ancestor is TPicture then
  3702.       begin
  3703.         Ancestor := TPicture(Filer.Ancestor);
  3704.         Result := not ((Graphic = Ancestor.Graphic) or
  3705.           ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
  3706.           Graphic.Equals(Ancestor.Graphic)));
  3707.       end;
  3708.     end
  3709.     else Result := Graphic <> nil;
  3710.   end;
  3711.  
  3712. begin
  3713.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3714. end;
  3715.  
  3716. function TPicture.GetWidth: Integer;
  3717. begin
  3718.   Result := 0;
  3719.   if FGraphic <> nil then Result := FGraphic.Width;
  3720. end;
  3721.  
  3722. function TPicture.GetHeight: Integer;
  3723. begin
  3724.   Result := 0;
  3725.   if FGraphic <> nil then Result := FGraphic.Height;
  3726. end;
  3727.  
  3728. { TMetafileImage }
  3729.  
  3730. destructor TMetafileImage.Destroy;
  3731. begin
  3732.   if FHandle <> 0 then DeleteEnhMetafile(FHandle);
  3733.   InternalDeletePalette(FPalette);
  3734.   inherited Destroy;
  3735. end;
  3736.  
  3737. procedure TMetafileImage.FreeHandle;
  3738. begin
  3739. end;
  3740.  
  3741.  
  3742. { TMetafileCanvas }
  3743.  
  3744. constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  3745. begin
  3746.   CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
  3747.     AMetafile.Description);
  3748. end;
  3749.  
  3750. constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
  3751.   ReferenceDevice: HDC; const CreatedBy, Description: String);
  3752. var
  3753.   RefDC: HDC;
  3754.   R: TRect;
  3755.   Temp: HDC;
  3756.   P: PChar;
  3757. begin
  3758.   inherited Create;
  3759.   FMetafile := AMetafile;
  3760.   RefDC := ReferenceDevice;
  3761.   if ReferenceDevice = 0 then RefDC := GetDC(0);
  3762.   try
  3763.     if FMetafile.MMWidth = 0 then
  3764.       if FMetafile.Width = 0 then
  3765.         FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
  3766.       else
  3767.         FMetafile.MMWidth := MulDiv(FMetafile.Width,
  3768.           GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
  3769.     if FMetafile.MMHeight = 0 then
  3770.       if FMetafile.Height = 0 then
  3771.         FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
  3772.       else
  3773.         FMetafile.MMHeight := MulDiv(FMetafile.Height,
  3774.           GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
  3775.     R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
  3776.     if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
  3777.       P := PChar(CreatedBy+#0+Description+#0#0)
  3778.     else
  3779.       P := nil;
  3780.     Temp := CreateEnhMetafile(RefDC, nil, @R, P);
  3781.     if Temp = 0 then GDIError;
  3782.     Handle := Temp;
  3783.   finally
  3784.     if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  3785.   end;
  3786. end;
  3787.  
  3788. destructor TMetafileCanvas.Destroy;
  3789. var
  3790.   Temp: HDC;
  3791. begin
  3792.   Temp := Handle;
  3793.   Handle := 0;
  3794.   FMetafile.Handle := CloseEnhMetafile(Temp);
  3795.   inherited Destroy;
  3796. end;
  3797.  
  3798. { TMetafile }
  3799.  
  3800. constructor TMetafile.Create;
  3801. begin
  3802.   inherited Create;
  3803.   FEnhanced := True;
  3804.   FTransparent := True;
  3805.   Assign(nil);
  3806. end;
  3807.  
  3808. destructor TMetafile.Destroy;
  3809. begin
  3810.   FImage.Release;
  3811.   inherited Destroy;
  3812. end;
  3813.  
  3814. procedure TMetafile.Assign(Source: TPersistent);
  3815. var
  3816.   Pal: HPalette;
  3817. begin
  3818.   if (Source = nil) or (Source is TMetafile) then
  3819.   begin
  3820.     Pal := 0;
  3821.     if FImage <> nil then
  3822.     begin
  3823.       Pal := FImage.FPalette;
  3824.       FImage.Release;
  3825.     end;
  3826.     if Assigned(Source) then
  3827.     begin
  3828.       FImage := TMetafile(Source).FImage;
  3829.       FEnhanced := TMetafile(Source).Enhanced;
  3830.     end
  3831.     else
  3832.     begin
  3833.       FImage := TMetafileImage.Create;
  3834.       FEnhanced := True;
  3835.     end;
  3836.     FImage.Reference;
  3837.     PaletteModified := (Pal <> Palette) and (Palette <> 0);
  3838.     Changed(Self);
  3839.   end
  3840.   else
  3841.     inherited Assign(Source);
  3842. end;
  3843.  
  3844. procedure TMetafile.Clear;
  3845. begin
  3846.   NewImage;
  3847. end;
  3848.  
  3849. procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
  3850. var
  3851.   MetaPal, OldPal: HPALETTE;
  3852.   R: TRect;
  3853. begin
  3854.   if FImage = nil then Exit;
  3855.   MetaPal := Palette;
  3856.   OldPal := 0;
  3857.   if MetaPal <> 0 then
  3858.   begin
  3859.     OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
  3860.     RealizePalette(ACanvas.Handle);
  3861.   end;
  3862.   R := Rect;
  3863.   Dec(R.Right);  // Metafile rect includes right and bottom coords
  3864.   Dec(R.Bottom);
  3865.   PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
  3866.   if MetaPal <> 0 then
  3867.     SelectPalette(ACanvas.Handle, OldPal, True);
  3868. end;
  3869.  
  3870. function TMetafile.GetAuthor: String;
  3871. var
  3872.   Temp: Integer;
  3873. begin
  3874.   Result := '';
  3875.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3876.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3877.   if Temp <= 0 then Exit;
  3878.   SetLength(Result, Temp);
  3879.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3880.   SetLength(Result, StrLen(PChar(Result)));
  3881. end;
  3882.  
  3883. function TMetafile.GetDesc: String;
  3884. var
  3885.   Temp: Integer;
  3886. begin
  3887.   Result := '';
  3888.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3889.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  3890.   if Temp <= 0 then Exit;
  3891.   SetLength(Result, Temp);
  3892.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  3893.   Delete(Result, 1, StrLen(PChar(Result))+1);
  3894.   SetLength(Result, StrLen(PChar(Result)));
  3895. end;
  3896.  
  3897. function TMetafile.GetEmpty;
  3898. begin
  3899.   Result := FImage = nil;
  3900. end;
  3901.  
  3902. function TMetafile.GetHandle: HENHMETAFILE;
  3903. begin
  3904.   if Assigned(FImage) then
  3905.     Result := FImage.FHandle
  3906.   else
  3907.     Result := 0;
  3908. end;
  3909.  
  3910. function TMetafile.GetHeight: Integer;
  3911. var
  3912.   EMFHeader: TEnhMetaHeader;
  3913. begin
  3914.   if FImage = nil then NewImage;
  3915.   with FImage do
  3916.    if FInch = 0 then
  3917.      if FHandle = 0 then
  3918.        Result := FTempHeight
  3919.      else
  3920.      begin               { convert 0.01mm units to referenceDC device pixels }
  3921.        GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3922.        Result := MulDiv(FHeight,                     { metafile height in 0.01mm }
  3923.          EMFHeader.szlDevice.cy,                      { device height in pixels }
  3924.          EMFHeader.szlMillimeters.cy*100);            { device height in mm }
  3925.      end
  3926.    else          { for WMF files, convert to font dpi based device pixels }
  3927.      Result := MulDiv(FHeight, ScreenLogPixels, 25400);
  3928. end;
  3929.  
  3930. function TMetafile.GetInch: Word;
  3931. begin
  3932.   Result := 0;
  3933.   if FImage <> nil then Result := FImage.FInch;
  3934. end;
  3935.  
  3936. function TMetafile.GetMMHeight: Integer;
  3937. begin
  3938.   if FImage = nil then NewImage;
  3939.   Result := FImage.FHeight;
  3940. end;
  3941.  
  3942. function TMetafile.GetMMWidth: Integer;
  3943. begin
  3944.   if FImage = nil then NewImage;
  3945.   Result := FImage.FWidth;
  3946. end;
  3947.  
  3948. function TMetafile.GetPalette: HPALETTE;
  3949. var
  3950.   LogPal: TMaxLogPalette;
  3951.   Count: Integer;
  3952. begin
  3953.   Result := 0;
  3954.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  3955.   if FImage.FPalette = 0 then
  3956.   begin
  3957.     Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
  3958.     if Count = 0 then
  3959.       Exit
  3960.     else if Count > 256 then
  3961.       Count := Count and $FF;
  3962.     InternalDeletePalette(FImage.FPalette);
  3963.     LogPal.palVersion := $300;
  3964.     LogPal.palNumEntries := Count;
  3965.     GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, @LogPal.palPalEntry);
  3966.     FImage.FPalette := CreatePalette(PLogPalette(@LogPal)^);
  3967.   end;
  3968.   Result := FImage.FPalette;
  3969. end;
  3970.  
  3971. function TMetafile.GetWidth: Integer;
  3972. var
  3973.   EMFHeader: TEnhMetaHeader;
  3974. begin
  3975.   if FImage = nil then NewImage;
  3976.   with FImage do
  3977.     if FInch = 0 then
  3978.       if FHandle = 0 then
  3979.         Result := FTempWidth
  3980.       else
  3981.       begin     { convert 0.01mm units to referenceDC device pixels }
  3982.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  3983.         Result := MulDiv(FWidth,                      { metafile width in 0.01mm }
  3984.           EMFHeader.szlDevice.cx,                      { device width in pixels }
  3985.           EMFHeader.szlMillimeters.cx*100);            { device width in 0.01mm }
  3986.       end
  3987.     else      { for WMF files, convert to font dpi based device pixels }
  3988.       Result := MulDiv(FWidth, ScreenLogPixels, 25400);
  3989. end;
  3990.  
  3991. procedure TMetafile.LoadFromStream(Stream: TStream);
  3992. begin
  3993.   if TestEMF(Stream) then
  3994.     ReadEMFStream(Stream)
  3995.   else
  3996.     ReadWMFStream(Stream, Stream.Size - Stream.Position);
  3997.   PaletteModified := Palette <> 0;
  3998.   Changed(Self);
  3999. end;
  4000.  
  4001. procedure TMetafile.NewImage;
  4002. begin
  4003.   FImage.Release;
  4004.   FImage := TMetafileImage.Create;
  4005.   FImage.Reference;
  4006. end;
  4007.  
  4008. procedure TMetafile.ReadData(Stream: TStream);
  4009. var
  4010.   Length: Longint;
  4011. begin
  4012.   Stream.Read(Length, SizeOf(Longint));
  4013.   if TestEMF(Stream) then
  4014.     ReadEMFStream(Stream)
  4015.   else
  4016.     ReadWMFStream(Stream, Length - Sizeof(Length));
  4017.   PaletteModified := Palette <> 0;
  4018.   Changed(Self);
  4019. end;
  4020.  
  4021. procedure TMetafile.ReadEMFStream(Stream: TStream);
  4022. var
  4023.   EnhHeader: TEnhMetaheader;
  4024.   Buf: PChar;
  4025. begin
  4026.   NewImage;
  4027.   Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
  4028.   if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  4029.   GetMem(Buf, EnhHeader.nBytes);
  4030.   with FImage do
  4031.   try
  4032.     Move(EnhHeader, Buf^, Sizeof(EnhHeader));
  4033.     Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
  4034.       EnhHeader.nBytes - Sizeof(EnhHeader));
  4035.     FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
  4036.     if FHandle = 0 then InvalidMetafile;
  4037.     FInch := 0;
  4038.     with EnhHeader.rclFrame do
  4039.     begin
  4040.       FWidth := Right - Left;    { in 0.01 mm units }
  4041.       FHeight := Bottom - Top;
  4042.     end;
  4043.     Enhanced := True;
  4044.   finally
  4045.     FreeMem(Buf, EnhHeader.nBytes);
  4046.   end;
  4047. end;
  4048.  
  4049. procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
  4050. var
  4051.   WMF: TMetafileHeader;
  4052.   BitMem: Pointer;
  4053.   MFP: TMetaFilePict;
  4054. begin
  4055.   NewImage;
  4056.   Stream.Read(WMF, SizeOf(WMF));
  4057.   if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
  4058.     InvalidMetafile;
  4059.   Dec(Length, SizeOf(WMF));
  4060.   GetMem(Bitmem, Length);
  4061.   with FImage do
  4062.   try
  4063.     Stream.Read(BitMem^, Length);
  4064.     FImage.FInch := WMF.Inch;
  4065.     if WMF.Inch = 0 then WMF.Inch := 96;
  4066.     FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left,25400,WMF.Inch);
  4067.     FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top,25400,WMF.Inch);
  4068.     with MFP do
  4069.     begin
  4070.       MM := MM_ANISOTROPIC;
  4071.       xExt := 0;
  4072.       yExt := 0;
  4073.       hmf := 0;
  4074.     end;
  4075.     FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
  4076.     if FHandle = 0 then InvalidMetafile;
  4077.     Enhanced := False;
  4078.   finally
  4079.     Freemem(BitMem, Length);
  4080.   end;
  4081. end;
  4082.  
  4083. procedure TMetafile.SaveToFile(const Filename: String);
  4084. var
  4085.   SaveEnh: Boolean;
  4086. begin
  4087.   SaveEnh := Enhanced;
  4088.   if AnsiLowerCaseFileName(ExtractFileExt(Filename)) = '.wmf' then
  4089.     Enhanced := False;              { For 16 bit compatibility }
  4090.   inherited SaveToFile(Filename);
  4091.   Enhanced := SaveEnh;
  4092. end;
  4093.  
  4094. procedure TMetafile.SaveToStream(Stream: TStream);
  4095. begin
  4096.   if FImage <> nil then
  4097.     if Enhanced then
  4098.       WriteEMFStream(Stream)
  4099.     else
  4100.       WriteWMFStream(Stream);
  4101. end;
  4102.  
  4103. procedure TMetafile.SetHandle(Value: HENHMETAFILE);
  4104. var
  4105.   EnhHeader: TEnhMetaHeader;
  4106. begin
  4107.   if (Value <> 0) and
  4108.     (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
  4109.     InvalidMetafile;
  4110.   UniqueImage;
  4111.   if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
  4112.   InternalDeletePalette(FImage.FPalette);
  4113.   FImage.FPalette := 0;
  4114.   FImage.FHandle := Value;
  4115.   FImage.FTempWidth := 0;
  4116.   FImage.FTempHeight := 0;
  4117.   if Value <> 0 then
  4118.     with EnhHeader.rclFrame do
  4119.     begin
  4120.       FImage.FWidth := Right - Left;
  4121.       FImage.FHeight := Bottom - Top;
  4122.     end;
  4123.   PaletteModified := Palette <> 0;
  4124.   Changed(Self);
  4125. end;
  4126.  
  4127. procedure TMetafile.SetHeight(Value: Integer);
  4128. var
  4129.   EMFHeader: TEnhMetaHeader;
  4130. begin
  4131.   if FImage = nil then NewImage;
  4132.   with FImage do
  4133.     if FInch = 0 then
  4134.       if FHandle = 0 then
  4135.         FTempHeight := Value
  4136.       else
  4137.       begin                 { convert device pixels to 0.01mm units }
  4138.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4139.         MMHeight := MulDiv(Value,                      { metafile height in pixels }
  4140.           EMFHeader.szlMillimeters.cy*100,             { device height in 0.01mm }
  4141.           EMFHeader.szlDevice.cy);                     { device height in pixels }
  4142.       end
  4143.     else
  4144.       MMHeight := MulDiv(Value, 25400, ScreenLogPixels);
  4145. end;
  4146.  
  4147. procedure TMetafile.SetInch(Value: Word);
  4148. begin
  4149.   if FImage = nil then NewImage;
  4150.   if FImage.FInch <> Value then
  4151.   begin
  4152.     UniqueImage;
  4153.     FImage.FInch := Value;
  4154.     Changed(Self);
  4155.   end;
  4156. end;
  4157.  
  4158. procedure TMetafile.SetMMHeight(Value: Integer);
  4159. begin
  4160.   if FImage = nil then NewImage;
  4161.   FImage.FTempHeight := 0;
  4162.   if FImage.FHeight <> Value then
  4163.   begin
  4164.     UniqueImage;
  4165.     FImage.FHeight := Value;
  4166.     Changed(Self);
  4167.   end;
  4168. end;
  4169.  
  4170. procedure TMetafile.SetMMWidth(Value: Integer);
  4171. begin
  4172.   if FImage = nil then NewImage;
  4173.   FImage.FTempWidth := 0;
  4174.   if FImage.FWidth <> Value then
  4175.   begin
  4176.     UniqueImage;
  4177.     FImage.FWidth := Value;
  4178.     Changed(Self);
  4179.   end;
  4180. end;
  4181.  
  4182. procedure TMetafile.SetWidth(Value: Integer);
  4183. var
  4184.   EMFHeader: TEnhMetaHeader;
  4185. begin
  4186.   if FImage = nil then NewImage;
  4187.   with FImage do
  4188.     if FInch = 0 then
  4189.       if FHandle = 0 then
  4190.         FTempWidth := Value
  4191.       else
  4192.       begin                 { convert device pixels to 0.01mm units }
  4193.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4194.         MMWidth := MulDiv(Value,                      { metafile width in pixels }
  4195.           EMFHeader.szlMillimeters.cx*100,            { device width in mm }
  4196.           EMFHeader.szlDevice.cx);                    { device width in pixels }
  4197.       end
  4198.     else
  4199.       MMWidth := MulDiv(Value, 25400, ScreenLogPixels);
  4200. end;
  4201.  
  4202. function TMetafile.TestEMF(Stream: TStream): Boolean;
  4203. var
  4204.   Size: Longint;
  4205.   Header: TEnhMetaHeader;
  4206. begin
  4207.   Size := Stream.Size - Stream.Position;
  4208.   if Size > Sizeof(Header) then
  4209.   begin
  4210.     Stream.Read(Header, Sizeof(Header));
  4211.     Stream.Seek(-Sizeof(Header), soFromCurrent);
  4212.   end;
  4213.   Result := (Size > Sizeof(Header)) and
  4214.     (Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
  4215. end;
  4216.  
  4217. procedure TMetafile.UniqueImage;
  4218. var
  4219.   NewImage: TMetafileImage;
  4220. begin
  4221.   if FImage = nil then
  4222.     Self.NewImage
  4223.   else
  4224.     if FImage.FRefCount > 1 then
  4225.     begin
  4226.       NewImage:= TMetafileImage.Create;
  4227.       if FImage.FHandle <> 0 then
  4228.         NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
  4229.       NewImage.FHeight := FImage.FHeight;
  4230.       NewImage.FWidth := FImage.FWidth;
  4231.       NewImage.FInch := FImage.FInch;
  4232.       NewImage.FTempWidth := FImage.FTempWidth;
  4233.       NewImage.FTempHeight := FImage.FTempHeight;
  4234.       FImage.Release;
  4235.       FImage := NewImage;
  4236.       FImage.Reference;
  4237.     end;
  4238. end;
  4239.  
  4240. procedure TMetafile.WriteData(Stream: TStream);
  4241. var
  4242.   SavePos: Longint;
  4243. begin
  4244.   if FImage <> nil then
  4245.   begin
  4246.     SavePos := 0;
  4247.     Stream.Write(SavePos, Sizeof(SavePos));
  4248.     SavePos := Stream.Position - Sizeof(SavePos);
  4249.     if Enhanced then
  4250.       WriteEMFStream(Stream)
  4251.     else
  4252.       WriteWMFStream(Stream);
  4253.     Stream.Seek(SavePos, soFromBeginning);
  4254.     SavePos := Stream.Size - SavePos;
  4255.     Stream.Write(SavePos, Sizeof(SavePos));
  4256.     Stream.Seek(0, soFromEnd);
  4257.   end;
  4258. end;
  4259.  
  4260. procedure TMetafile.WriteEMFStream(Stream: TStream);
  4261. var
  4262.   Buf: Pointer;
  4263.   Length: Longint;
  4264. begin
  4265.   if FImage = nil then Exit;
  4266.   Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  4267.   GetMem(Buf, Length);
  4268.   try
  4269.     GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
  4270.     Stream.WriteBuffer(Buf^, Length);
  4271.   finally
  4272.     FreeMem(Buf, Length);
  4273.   end;
  4274. end;
  4275.  
  4276. procedure TMetafile.WriteWMFStream(Stream: TStream);
  4277. var
  4278.   WMF: TMetafileHeader;
  4279.   Bits: Pointer;
  4280.   Length: Longint;
  4281.   RefDC: HDC;
  4282. begin
  4283.   if FImage = nil then Exit;
  4284.   FillChar(WMF, SizeOf(WMF), 0);
  4285.   with FImage do
  4286.   begin
  4287.     with WMF do
  4288.     begin
  4289.       Key := WMFKEY;
  4290.       if FInch = 0 then
  4291.         Inch := 96          { WMF defaults to 96 units per inch }
  4292.       else
  4293.         Inch := FInch;
  4294.       with Box do
  4295.       begin
  4296.         Right := MulDiv(FWidth, WMF.Inch, 25400);
  4297.         Bottom := MulDiv(FHeight, WMF.Inch, 25400);
  4298.       end;
  4299.       CheckSum := ComputeAldusChecksum(WMF);
  4300.     end;
  4301.     RefDC := GetDC(0);
  4302.     try
  4303.       Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
  4304.       GetMem(Bits, Length);
  4305.       try
  4306.         if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
  4307.           RefDC) < Length then GDIError;
  4308.         Stream.WriteBuffer(WMF, SizeOf(WMF));
  4309.         Stream.WriteBuffer(Bits^, Length);
  4310.       finally
  4311.         FreeMem(Bits, Length);
  4312.       end;
  4313.     finally
  4314.       ReleaseDC(0, RefDC);
  4315.     end;
  4316.   end;
  4317. end;
  4318.  
  4319. procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  4320.   APalette: HPALETTE);
  4321. var
  4322.   EnhHeader: TEnhMetaHeader;
  4323. begin
  4324.   AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
  4325.   if AData = 0 then  InvalidGraphic(SUnknownClipboardFormat);
  4326.   NewImage;
  4327.   with FImage do
  4328.   begin
  4329.     FHandle := CopyEnhMetafile(AData, nil);
  4330.     GetEnhMetaFileHeader(FHandle, sizeof(EnhHeader), @EnhHeader);
  4331.     with EnhHeader.rclFrame do
  4332.     begin
  4333.       FWidth := Right - Left;
  4334.       FHeight := Bottom - Top;
  4335.     end;
  4336.     FInch := 0;
  4337.   end;
  4338.   Enhanced := True;
  4339.   PaletteModified := Palette <> 0;
  4340.   Changed(Self);
  4341. end;
  4342.  
  4343. procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  4344.   var APalette: HPALETTE);
  4345. begin
  4346.   if FImage = nil then Exit;
  4347.   AFormat := CF_ENHMETAFILE;
  4348.   APalette := 0;
  4349.   AData := CopyEnhMetaFile(FImage.FHandle, nil);
  4350. end;
  4351.  
  4352. function TMetafile.ReleaseHandle: HENHMETAFILE;
  4353. begin
  4354.   UniqueImage;
  4355.   Result := FImage.FHandle;
  4356.   FImage.FHandle := 0;
  4357. end;
  4358.  
  4359. var
  4360.   BitmapCanvasList: TThreadList = nil;
  4361.  
  4362. { TBitmapCanvas }
  4363. { Create a canvas that gets its DC from the memory DC cache }
  4364. type
  4365.   TBitmapCanvas = class(TCanvas)
  4366.   private
  4367.     FBitmap: TBitmap;
  4368.     FOldBitmap: HBITMAP;
  4369.     FOldPalette: HPALETTE;
  4370.     procedure FreeContext;
  4371.   protected
  4372.     procedure CreateHandle; override;
  4373.   public
  4374.     constructor Create(ABitmap: TBitmap);
  4375.     destructor Destroy; override;
  4376.   end;
  4377.  
  4378. { FreeMemoryContexts is called by the VCL main winproc to release
  4379.   memory DCs after every message is processed (garbage collection).
  4380.   Only memory DCs not locked by other threads will be freed.
  4381. }
  4382. procedure FreeMemoryContexts;
  4383. var
  4384.   I: Integer;
  4385. begin
  4386.   with BitmapCanvasList.LockList do
  4387.   try
  4388.     for I := Count-1 downto 0 do
  4389.     with TBitmapCanvas(Items[I]) do
  4390.       if TryLock then
  4391.       try
  4392.         FreeContext;
  4393.       finally
  4394.         Unlock;
  4395.       end;
  4396.   finally
  4397.     BitmapCanvasList.UnlockList;
  4398.   end;
  4399. end;
  4400.  
  4401. { DeselectBitmap is called to ensure that a bitmap handle is not
  4402.   selected into any memory DC anywhere in the system.  If the bitmap
  4403.   handle is in use by a locked canvas, DeselectBitmap must wait for
  4404.   the canvas to unlock. }
  4405.  
  4406. procedure DeselectBitmap(AHandle: HBITMAP);
  4407. var
  4408.   I: Integer;
  4409. begin
  4410.   if AHandle = 0 then Exit;
  4411.   with BitmapCanvasList.LockList do
  4412.   try
  4413.     for I := Count - 1 downto 0 do
  4414.       with TBitmapCanvas(Items[I]) do
  4415.         if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
  4416.           FreeContext;
  4417.   finally
  4418.     BitmapCanvasList.UnlockList;
  4419.   end;
  4420. end;
  4421.  
  4422. constructor TBitmapCanvas.Create(ABitmap: TBitmap);
  4423. begin
  4424.   inherited Create;
  4425.   FBitmap := ABitmap;
  4426. end;
  4427.  
  4428. destructor TBitmapCanvas.Destroy;
  4429. begin
  4430.   FreeContext;
  4431.   inherited Destroy;
  4432. end;
  4433.  
  4434. procedure TBitmapCanvas.FreeContext;
  4435. var
  4436.   H: HBITMAP;
  4437. begin
  4438.   if FHandle <> 0 then
  4439.   begin
  4440.     Lock;
  4441.     try
  4442.       if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
  4443.       if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
  4444.       H := FHandle;
  4445.       Handle := 0;
  4446.       DeleteDC(H);
  4447.       BitmapCanvasList.Remove(Self);
  4448.     finally
  4449.       Unlock;
  4450.     end;
  4451.   end;
  4452. end;
  4453.  
  4454. procedure TBitmapCanvas.CreateHandle;
  4455. var
  4456.   H: HBITMAP;
  4457. begin
  4458.   if FBitmap <> nil then
  4459.   begin
  4460.     Lock;
  4461.     try
  4462.       FBitmap.HandleNeeded;
  4463.       DeselectBitmap(FBitmap.FImage.FHandle);
  4464. //!!      DeselectBitmap(FBitmap.FImage.FMaskHandle);
  4465.       FBitmap.PaletteNeeded;
  4466.       H := CreateCompatibleDC(0);
  4467.       if FBitmap.FImage.FHandle <> 0 then
  4468.         FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
  4469.         FOldBitmap := 0;
  4470.       if FBitmap.FImage.FPalette <> 0 then
  4471.       begin
  4472.         FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
  4473.         RealizePalette(H);
  4474.       end
  4475.       else
  4476.         FOldPalette := 0;
  4477.       Handle := H;
  4478.       BitmapCanvasList.Add(Self);
  4479.     finally
  4480.       Unlock;
  4481.     end;
  4482.   end;
  4483. end;
  4484.  
  4485. { TSharedImage }
  4486.  
  4487. procedure TSharedImage.Reference;
  4488. begin
  4489.   Inc(FRefCount);
  4490. end;
  4491.  
  4492. procedure TSharedImage.Release;
  4493. begin
  4494.   if Pointer(Self) <> nil then
  4495.   begin
  4496.     Dec(FRefCount);
  4497.     if FRefCount = 0 then
  4498.     begin
  4499.       FreeHandle;
  4500.       Free;
  4501.     end;
  4502.   end;
  4503. end;
  4504.  
  4505. { TBitmapImage }
  4506.  
  4507. destructor TBitmapImage.Destroy;
  4508. begin
  4509.   if FDIBHandle <> 0 then
  4510.   begin
  4511.     DeselectBitmap(FDIBHandle);
  4512.     DeleteObject(FDIBHandle);
  4513.     FDIBHandle := 0;
  4514.   end;
  4515.   FreeHandle;
  4516.   if FDIB.dshSection <> 0 then CloseHandle(FDIB.dshSection);
  4517.   inherited Destroy;
  4518. end;
  4519.  
  4520. procedure TBitmapImage.FreeHandle;
  4521. begin
  4522.   if (FHandle <> 0) and (FHandle <> FDIBHandle) then
  4523.   begin
  4524.     DeselectBitmap(FHandle);
  4525.     DeleteObject(FHandle);
  4526.   end;
  4527.   if FMaskHandle <> 0 then
  4528.   begin
  4529.     DeselectBitmap(FMaskHandle);
  4530.     DeleteObject(FMaskHandle);
  4531.     FMaskHandle := 0;
  4532.   end;
  4533.   InternalDeletePalette(FPalette);
  4534.   FHandle := 0;
  4535.   FPalette := 0;
  4536. end;
  4537.  
  4538. { TBitmap }
  4539.  
  4540. const
  4541.   { Mapping from color in DIB to system color }
  4542.   Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);
  4543.   SysGrays: array[0..3] of TColor = (clBtnHighlight, clBtnFace, clBtnShadow,
  4544.     clBtnText);
  4545.  
  4546. { This function will replace OldColors in Handle's colortable with NewColors and
  4547.   return a new DDB which uses that color table.  For bitmap's with more than
  4548.   256 colors (8bpp) this function returns the original bitmap. }
  4549. function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
  4550. var
  4551.   Bitmap: PBitmapInfoHeader;
  4552.   ColorCount: Integer;
  4553.   BitmapInfoSize: Integer;
  4554.   BitmapBitsSize: Integer;
  4555.   Bits: Pointer;
  4556.   Colors: PRGBQuadArray;
  4557.   I, J: Integer;
  4558.   OldColor, NewColor: Integer;
  4559.   ScreenDC, DC: HDC;
  4560.   Save: HBITMAP;
  4561. begin
  4562.   Result := Handle;
  4563.   if Handle = 0 then Exit;
  4564.   InternalGetDIBSizes(Handle, BitmapInfoSize, BitmapBitsSize, 0);
  4565.   Bitmap := AllocMem(BitmapInfoSize + BitmapBitsSize);
  4566.   try
  4567.     Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  4568.     InternalGetDIB(Handle, 0, Bitmap^, Bits^, 0);
  4569.     if Bitmap^.biBitCount <= 8 then
  4570.     begin
  4571.       ColorCount := 1 shl (Bitmap^.biBitCount);
  4572.       Colors := Pointer(Integer(Bitmap) + Bitmap^.biSize);
  4573.       ByteSwapColors(Colors^, ColorCount);
  4574.       for I := 0 to ColorCount - 1 do
  4575.         for J := Low(OldColors) to High(OldColors) do
  4576.         begin
  4577.           OldColor := ColorToRGB(OldColors[J]);
  4578.           if Integer(Colors[I]) = OldColor then
  4579.           begin
  4580.             NewColor := ColorToRGB(NewColors[J]);
  4581.             Integer(Colors[I]) := NewColor;
  4582.           end;
  4583.         end;
  4584.       ByteSwapColors(Colors^, ColorCount);
  4585.       ScreenDC := GetDC(0);
  4586.       try
  4587.         DC := CreateCompatibleDC(ScreenDC);
  4588.         if DC <> 0 then
  4589.           with Bitmap^ do
  4590.           begin
  4591.             Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4592.             if Result <> 0 then
  4593.             begin
  4594.               Save := SelectObject(DC, Result);
  4595.               StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4596.                 Bits, PBitmapInfo(Bitmap)^, DIB_RGB_COLORS, SrcCopy);
  4597.               SelectObject(DC, Save);
  4598.             end;
  4599.           end;
  4600.           DeleteObject(DC);
  4601.       finally
  4602.         ReleaseDC(0, ScreenDC);
  4603.       end;
  4604.     end;
  4605.   finally
  4606.     FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  4607.   end;
  4608. end;
  4609.  
  4610. { This function will create a new DDB from the bitmap resource, replacing
  4611.   OldColors in the colortable with NewColors.  If the bitmap resource has more
  4612.   than 256 colors (8bpp) this function returns the new DDB without color
  4613.   modifications. }
  4614. function CreateMappedRes(Instance: THandle; ResName: PChar;
  4615.   const OldColors, NewColors: array of TColor): HBITMAP;
  4616. var
  4617.   Rsrc: HRSRC;
  4618.   Res: THandle;
  4619.   ColorCount: Integer;
  4620.   BitmapInfoSize: Integer;
  4621.   Bitmap: PBitmapInfoHeader;
  4622.   BitmapInfo: PBitmapInfoHeader;
  4623.   Colors: PRGBQuadArray;
  4624.   I, J: Integer;
  4625.   OldColor, NewColor: Integer;
  4626.   Bits: Pointer;
  4627.   ScreenDC, DC: HDC;
  4628.   Save: HBITMAP;
  4629.   Temp: TBitmap;
  4630. begin
  4631.   Result := 0;
  4632.   Rsrc := FindResource(Instance, ResName, RT_BITMAP);
  4633.   if Rsrc = 0 then Exit;
  4634.   Res := LoadResource(Instance, Rsrc);
  4635.   try
  4636.     { Lock the bitmap and get a pointer to the color table. }
  4637.     Bitmap := LockResource(Res);
  4638.     if Bitmap <> nil then
  4639.     try
  4640.       if (Bitmap^.biBitCount * Bitmap^.biPlanes) <= 8 then
  4641.       begin
  4642.         ColorCount := 1 shl (Bitmap^.biBitCount);
  4643.         BitmapInfoSize := Bitmap^.biSize + ColorCount * SizeOf(TRGBQuad);
  4644.         GetMem(BitmapInfo, BitmapInfoSize);
  4645.         try
  4646.           Move(Bitmap^, BitmapInfo^, BitmapInfoSize);
  4647.           if Bitmap^.biBitCount <= 8 then
  4648.           begin
  4649.             Colors := Pointer(Integer(BitmapInfo) + BitmapInfo^.biSize);
  4650.             ByteSwapColors(Colors^, ColorCount);
  4651.             for I := 0 to ColorCount - 1 do
  4652.               for J := Low(OldColors) to High(OldColors) do
  4653.               begin
  4654.                 OldColor := ColorToRGB(OldColors[J]);
  4655.                 if Integer(Colors[I]) = OldColor then
  4656.                 begin
  4657.                   NewColor := ColorToRGB(NewColors[J]);
  4658.                   Integer(Colors[I]) := NewColor;
  4659.                 end;
  4660.               end;
  4661.             ByteSwapColors(Colors^, ColorCount);
  4662.           end;
  4663.           { First skip over the header structure and color table entries, if any. }
  4664.           Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  4665.           { Create a color bitmap compatible with the display device. }
  4666.           ScreenDC := GetDC(0);
  4667.           try
  4668.             DC := CreateCompatibleDC(ScreenDC);
  4669.             if DC <> 0 then
  4670.               with BitmapInfo^ do
  4671.               begin
  4672.                 Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4673.                 if Result <> 0 then
  4674.                 begin
  4675.                   Save := SelectObject(DC, Result);
  4676.                   StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4677.                     Bits, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS, SrcCopy);
  4678.                   SelectObject(DC, Save);
  4679.                 end;
  4680.               end;
  4681.               DeleteObject(DC);
  4682.           finally
  4683.             ReleaseDC(0, ScreenDC);
  4684.           end;
  4685.         finally
  4686.           FreeMem(BitmapInfo, BitmapInfoSize);
  4687.         end;
  4688.       end
  4689.       else
  4690.       begin
  4691.         Temp := TBitmap.Create;
  4692.         try
  4693.           Temp.LoadFromResourceID(Instance, Integer(ResName));
  4694.           Result := Temp.ReleaseHandle;
  4695.         finally
  4696.           Temp.Free;
  4697.         end;
  4698.       end;
  4699.     finally
  4700.       UnlockResource(Res);
  4701.     end;
  4702.   finally
  4703.     FreeResource(Res);
  4704.   end;
  4705. end;
  4706.  
  4707. { This function replaces the standard gray colors in a bitmap with the system
  4708.   grays (Grays, SysGrays). }
  4709. function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
  4710. begin
  4711.   Result := CreateMappedBmp(Handle, Grays, SysGrays);
  4712. end;
  4713.  
  4714. { This function replaces the standard gray colors in a bitmap resource with the
  4715.   system grays (Grays, SysGrays). }
  4716. function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  4717. begin
  4718.   Result := CreateMappedRes(Instance, ResName, Grays, SysGrays);
  4719. end;
  4720.  
  4721. procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
  4722.   const DIB: TDIBSection);
  4723. var
  4724.   ScreenDC, DC: HDC;
  4725.   OldBM: HBitmap;
  4726.   ColorCount: Integer;
  4727.   Colors: array [Byte] of TRGBQuad;
  4728. begin
  4729.   if (DIBHandle <> 0) and (DIB.dsbmih.biBitCount <= 8) then
  4730.   begin
  4731.     ColorCount := PaletteToDIBColorTable(Pal, Colors);
  4732.     if ColorCount = 0 then Exit;
  4733.     ScreenDC := GetDC(0);
  4734.     DC := CreateCompatibleDC(ScreenDC);
  4735.     OldBM := SelectObject(DC, DIBHandle);
  4736.     try
  4737.       SetDIBColorTable(DC, 0, ColorCount, Colors);
  4738.     finally
  4739.       SelectObject(DC, OldBM);
  4740.       DeleteDC(DC);
  4741.       ReleaseDC(0, ScreenDC);
  4742.     end;
  4743.   end;
  4744. end;
  4745.  
  4746. procedure FixupBitFields(var DIB: TDIBSection);
  4747. begin
  4748.   if (DIB.dsbmih.biCompression and BI_BITFIELDS <> 0) and
  4749.     (DIB.dsBitFields[0] = 0) then
  4750.     if DIB.dsbmih.biBitCount = 16 then
  4751.     begin
  4752.       // fix buggy 16 bit color drivers
  4753.       DIB.dsBitFields[0] := $F800;
  4754.       DIB.dsBitFields[1] := $07E0;
  4755.       DIB.dsBitFields[2] := $001F;
  4756.     end else if DIB.dsbmih.biBitCount = 32 then
  4757.     begin
  4758.       // fix buggy 32 bit color drivers
  4759.       DIB.dsBitFields[0] := $00FF0000;
  4760.       DIB.dsBitFields[1] := $0000FF00;
  4761.       DIB.dsBitFields[2] := $000000FF;
  4762.     end;
  4763. end;
  4764.  
  4765. function CopyBitmap(Handle: HBITMAP; OldPalette, NewPalette: HPALETTE;
  4766.   var DIB: TDIBSection; Canvas: TCanvas): HBITMAP;
  4767. var
  4768.   OldScr, NewScr: HBITMAP;
  4769.   ScreenDC, NewImageDC, OldImageDC: HDC;
  4770.   BI: PBitmapInfo;
  4771.   BitsMem: Pointer;
  4772.   SrcDIB: TDIBSection;
  4773.   MonoColors: array [0..1] of Integer;
  4774.   Pal1, Pal2: HPalette;
  4775. begin
  4776.   Result := 0;
  4777.   if Handle = 0 then
  4778.     with DIB, dsbm, dsbmih do
  4779.     begin
  4780.       if (biSize <> 0) and ((biWidth = 0) or (biHeight = 0)) then Exit;
  4781.       if (biSize = 0) and ((bmWidth = 0) or (bmHeight = 0)) then Exit;
  4782.     end;
  4783.  
  4784.   DeselectBitmap(Handle);
  4785.  
  4786.   SrcDIB.dsbmih.biSize := 0;
  4787.   if Handle <> 0 then
  4788.     if GetObject(Handle, sizeof(SrcDIB), @SrcDIB) < sizeof(SrcDIB.dsbm) then
  4789.       InvalidBitmap;
  4790.  
  4791.   ScreenDC := GDICheck(GetDC(0));
  4792.   NewImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4793.   with DIB.dsbm do
  4794.   try
  4795.     if DIB.dsbmih.biSize < sizeof(DIB.dsbmih) then
  4796.       if (bmPlanes or bmBitsPixel) = 1 then // monochrome
  4797.         Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
  4798.       else  // Create DDB
  4799.         Result := GDICheck(CreateCompatibleBitmap(ScreenDC, bmWidth, bmHeight))
  4800.     else  // Create DIB
  4801.     begin
  4802.       GetMem(BI, sizeof(TBitmapInfo) + 256 * sizeof(TRGBQuad));
  4803.       with DIB.dsbmih do
  4804.       try
  4805.         biSize := sizeof(BI.bmiHeader);
  4806.         biPlanes := 1;
  4807.         BI.bmiHeader := DIB.dsbmih;
  4808.         bmWidth := biWidth;
  4809.         bmHeight := biHeight;
  4810.  
  4811.         if (biBitCount <= 8) then
  4812.         begin
  4813.           if (biBitCount = 1) and (SrcDIB.dsbm.bmBits = nil) then
  4814.           begin  // set mono DIB to white/black when converting from DDB.
  4815.             Integer(BI^.bmiColors[0]) := 0;
  4816.             PInteger(Integer(@BI^.bmiColors) + sizeof(Integer))^ := $FFFFFF;
  4817.           end
  4818.           else if (NewPalette <> 0) then
  4819.             PaletteToDIBColorTable(NewPalette, PRGBQuadArray(@BI.bmiColors)^)
  4820.           else if Handle <> 0 then
  4821.           begin
  4822.             NewScr := SelectObject(NewImageDC, Handle);
  4823.             if (SrcDIB.dsbmih.biSize > 0) and (SrcDIB.dsbm.bmBits <> nil) then
  4824.               biClrUsed := GetDIBColorTable(NewImageDC, 0, 256, BI^.bmiColors)
  4825.             else
  4826.               GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), nil, BI^, DIB_RGB_COLORS);
  4827.             SelectObject(NewImageDC, NewScr);
  4828.           end;
  4829.         end
  4830.         else if ((biBitCount = 16) or (biBitCount = 32)) and
  4831.           ((biCompression and BI_BITFIELDS) <> 0) then
  4832.         begin
  4833.           FixupBitFields(DIB);
  4834.           Move(DIB.dsBitFields, BI.bmiColors, sizeof(DIB.dsBitFields));
  4835.         end;
  4836.  
  4837.         Result := GDICheck(CreateDIBSection(ScreenDC, BI^, DIB_RGB_COLORS, BitsMem, 0, 0));
  4838.         if (BitsMem = nil) then GDIError;
  4839.  
  4840.         if (Handle <> 0) and (SrcDIB.dsbm.bmWidth = biWidth) and
  4841.           (SrcDIB.dsbm.bmHeight = biHeight) and (biBitCount > 8) then
  4842.         begin    // shortcut bitblt steps
  4843.           GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), BitsMem, BI^, DIB_RGB_COLORS);
  4844.           Exit;
  4845.         end;
  4846.       finally
  4847.         FreeMem(BI);
  4848.       end;
  4849.     end;
  4850.  
  4851.     GDICheck(Result);
  4852.     NewScr := GDICheck(SelectObject(NewImageDC, Result));
  4853.     try
  4854.       try
  4855.         Pal1 := 0;
  4856.         Pal2 := 0;
  4857.         if NewPalette <> 0 then
  4858.         begin
  4859.           Pal1 := SelectPalette(NewImageDC, NewPalette, False);
  4860.           RealizePalette(NewImageDC);
  4861.         end;
  4862.         try
  4863.           if Canvas <> nil then
  4864.           begin
  4865.             FillRect(NewImageDC, Rect(0, 0, bmWidth, bmHeight),
  4866.               Canvas.Brush.Handle);
  4867.             SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
  4868.             SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
  4869.             if (DIB.dsbmih.biBitCount = 1) and (DIB.dsbm.bmBits <> nil) then
  4870.             begin
  4871.               MonoColors[0] := ColorToRGB(Canvas.Font.Color);
  4872.               MonoColors[1] := ColorToRGB(Canvas.Brush.Color);
  4873.               SetDIBColorTable(NewImageDC, 0, 2, MonoColors);
  4874.             end;
  4875.           end
  4876.           else
  4877.             PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);
  4878.           if Handle <> 0 then
  4879.           begin
  4880.             OldImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4881.             try
  4882.               OldScr := GDICheck(SelectObject(OldImageDC, Handle));
  4883.               if OldPalette <> 0 then
  4884.               begin
  4885.                 Pal2 := SelectPalette(OldImageDC, OldPalette, False);
  4886.                 RealizePalette(OldImageDC);
  4887.               end;
  4888.               if Canvas <> nil then
  4889.               begin
  4890.                 SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
  4891.                 SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
  4892.               end;
  4893.               BitBlt(NewImageDC, 0, 0, bmWidth, bmHeight, OldImageDC, 0, 0, SRCCOPY);
  4894.               if OldPalette <> 0 then
  4895.                 SelectPalette(OldImageDC, Pal2, True);
  4896.               GDICheck(SelectObject(OldImageDC, OldScr));
  4897.             finally
  4898.               DeleteDC(OldImageDC);
  4899.             end;
  4900.           end;
  4901.         finally
  4902.           if NewPalette <> 0 then
  4903.             SelectPalette(NewImageDC, Pal1, True);
  4904.         end;
  4905.       finally
  4906.         SelectObject(NewImageDC, NewScr);
  4907.       end;
  4908.     except
  4909.       DeleteObject(Result);
  4910.       raise;
  4911.     end;
  4912.   finally
  4913.     DeleteDC(NewImageDC);
  4914.     ReleaseDC(0, ScreenDC);
  4915.     if (Result <> 0) then GetObject(Result, sizeof(DIB), @DIB);
  4916.   end;
  4917. end;
  4918.  
  4919. function CopyPalette(Palette: HPALETTE): HPALETTE;
  4920. var
  4921.   PaletteSize: Integer;
  4922.   LogPal: TMaxLogPalette;
  4923. begin
  4924.   Result := 0;
  4925.   if Palette = 0 then Exit;
  4926.   PaletteSize := 0;
  4927.   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  4928.   if PaletteSize = 0 then Exit;
  4929.   with LogPal do
  4930.   begin
  4931.     palVersion := $0300;
  4932.     palNumEntries := PaletteSize;
  4933.     GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  4934.   end;
  4935.   Result := CreatePalette(PLogPalette(@LogPal)^);
  4936. end;
  4937.  
  4938. function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
  4939.   TransparentColor: TColorRef): HBITMAP;
  4940. var
  4941.   DIB: TDIBSection;
  4942.   ScreenDC, BitmapDC, MonoDC: HDC;
  4943.   BkColor: TColorRef;
  4944.   Remove: Boolean;
  4945.   SaveBitmap, SaveMono: HBITMAP;
  4946. begin
  4947.   Result := 0;
  4948.   if (Handle <> 0) and (GetObject(Handle, SizeOf(DIB), @DIB) <> 0) then
  4949.   begin
  4950.     DeselectBitmap(Handle);
  4951.     ScreenDC := 0;
  4952.     MonoDC := 0;
  4953.     try
  4954.       ScreenDC := GDICheck(GetDC(0));
  4955.       MonoDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4956.       with DIB, dsBm do
  4957.       begin
  4958.         Result := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
  4959.         if Result <> 0 then
  4960.         begin
  4961.           SaveMono := SelectObject(MonoDC, Result);
  4962.           if TransparentColor = clNone then
  4963.             PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
  4964.           else
  4965.           begin
  4966.             BitmapDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4967.             try
  4968.               { Convert DIB to DDB }
  4969.               if bmBits <> nil then
  4970.               begin
  4971.                 Remove := True;
  4972.                 DIB.dsbmih.biSize := 0;
  4973.                 Handle := CopyBitmap(Handle, Palette, Palette, DIB, nil);
  4974.               end
  4975.               else Remove := False;
  4976.               SaveBitmap := SelectObject(BitmapDC, Handle);
  4977.               if Palette <> 0 then
  4978.               begin
  4979.                 SelectPalette(BitmapDC, Palette, False);
  4980.                 RealizePalette(BitmapDC);
  4981.                 SelectPalette(MonoDC, Palette, False);
  4982.                 RealizePalette(MonoDC);
  4983.               end;
  4984.               BkColor := SetBkColor(BitmapDC, TransparentColor);
  4985.               BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
  4986.               SetBkColor(BitmapDC, BkColor);
  4987.               if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
  4988.               if Remove then DeleteObject(Handle);
  4989.             finally
  4990.               DeleteDC(BitmapDC);
  4991.             end;
  4992.           end;
  4993.           if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
  4994.         end;
  4995.       end;
  4996.     finally
  4997.       if MonoDC <> 0 then DeleteDC(MonoDC);
  4998.       if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
  4999.     end;
  5000.   end;
  5001. end;
  5002.  
  5003. constructor TBitmap.Create;
  5004. begin
  5005.   inherited Create;
  5006.   FTransparentColor := clDefault;
  5007.   FImage := TBitmapImage.Create;
  5008.   FImage.Reference;
  5009.   if DDBsOnly then HandleType := bmDDB;
  5010. end;
  5011.  
  5012. destructor TBitmap.Destroy;
  5013. begin
  5014.   FreeContext;
  5015.   FImage.Release;
  5016.   FCanvas.Free;
  5017.   inherited Destroy;
  5018. end;
  5019.  
  5020. procedure TBitmap.Assign(Source: TPersistent);
  5021. var
  5022.   DIB: TDIBSection;
  5023. begin
  5024.   if (Source = nil) or (Source is TBitmap) then
  5025.   begin
  5026.     EnterCriticalSection(BitmapImageLock);
  5027.     try
  5028.       if Source <> nil then
  5029.       begin
  5030.         TBitmap(Source).FImage.Reference;
  5031.         FImage.Release;
  5032.         FImage := TBitmap(Source).FImage;
  5033.         FTransparent := TBitmap(Source).FTransparent; 
  5034.         FTransparentColor := TBitmap(Source).FTransparentColor;
  5035.         FTransparentMode := TBitmap(Source).FTransparentMode;
  5036.       end
  5037.       else
  5038.       begin
  5039.         FillChar(DIB, Sizeof(DIB), 0);
  5040.         NewImage(0, 0, DIB, False);
  5041.       end;
  5042.     finally
  5043.       LeaveCriticalSection(BitmapImageLock);
  5044.     end;
  5045.     PaletteModified := Palette <> 0;
  5046.     Changed(Self);
  5047.   end
  5048.   else inherited Assign(Source);
  5049. end;
  5050.  
  5051. procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  5052. var
  5053.   NewHandle, NewPalette: THandle;
  5054. begin
  5055.   FreeContext;
  5056.   NewHandle := 0;
  5057.   NewPalette := 0;
  5058.   try
  5059.     if APalette = SystemPalette16 then
  5060.       NewPalette := APalette
  5061.     else
  5062.       NewPalette := CopyPalette(APalette);
  5063.     NewHandle := CopyBitmap(AHandle, APalette, NewPalette, DIB, FCanvas);
  5064.     NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  5065.   except
  5066.     InternalDeletePalette(NewPalette);
  5067.     if NewHandle <> 0 then DeleteObject(NewHandle);
  5068.     raise;
  5069.   end;
  5070. end;
  5071.  
  5072. { Called by the FCanvas whenever an operation is going to be performed on the
  5073.   bitmap that would modify it.  Since modifications should only affect this
  5074.   TBitmap, the handle needs to be 'cloned' if it is being refered to by more
  5075.   than one TBitmap }
  5076. procedure TBitmap.Changing(Sender: TObject);
  5077. begin
  5078.   FreeImage;
  5079. end;
  5080.  
  5081. procedure TBitmap.Changed(Sender: TObject);
  5082. begin
  5083.   FMaskBitsValid := False;
  5084.   inherited Changed(Sender);
  5085. end;
  5086.  
  5087. procedure TBitmap.Dormant;
  5088. begin
  5089.   FreeContext; // !! InternalDeletePalette fails without this
  5090.   DIBNeeded;
  5091.   FImage.FreeHandle;
  5092. end;
  5093.  
  5094. procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
  5095. var
  5096.   OldPalette: HPalette;
  5097.   RestorePalette: Boolean;
  5098.   DoHalftone: Boolean;
  5099.   Pt: TPoint;
  5100.   BPP: Integer;
  5101.   MaskDC: HDC;
  5102.   Save: THandle;
  5103. begin
  5104.   with Rect, FImage do
  5105.   begin
  5106.     ACanvas.RequiredState(csAllValid);
  5107.     PaletteNeeded;
  5108.     OldPalette := 0;
  5109.     RestorePalette := False;
  5110.  
  5111.     if FPalette <> 0 then
  5112.     begin
  5113.       OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
  5114.       RealizePalette(ACanvas.FHandle);
  5115.       RestorePalette := True;
  5116.     end;
  5117.     BPP := GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
  5118.       GetDeviceCaps(ACanvas.FHandle, PLANES);
  5119.     DoHalftone := (BPP <= 8) and (BPP < (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  5120.     if DoHalftone then
  5121.     begin
  5122.       GetBrushOrgEx(ACanvas.FHandle, pt);
  5123.       SetStretchBltMode(ACanvas.FHandle, HALFTONE);
  5124.       SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, @pt);
  5125.     end else if not Monochrome then
  5126.       SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
  5127.     try
  5128.       { Call MaskHandleNeeded prior to creating the canvas handle since
  5129.         it causes FreeContext to be called. }
  5130.       if Transparent then MaskHandleNeeded;
  5131.       Canvas.RequiredState(csAllValid);
  5132.       if Transparent then
  5133.       begin
  5134.         Save := 0;
  5135.         MaskDC := 0;
  5136.         try
  5137.           MaskDC := GDICheck(CreateCompatibleDC(0));
  5138.           Save := SelectObject(MaskDC, FMaskHandle);
  5139.           TransparentStretchBlt(ACanvas.FHandle, Left, Top, Right - Left,
  5140.             Bottom - Top, Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
  5141.             FDIB.dsbm.bmHeight, MaskDC, 0, 0);
  5142.         finally
  5143.           if Save <> 0 then SelectObject(MaskDC, Save);
  5144.           if MaskDC <> 0 then DeleteDC(MaskDC);
  5145.         end;
  5146.       end
  5147.       else
  5148.         StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
  5149.           Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
  5150.           FDIB.dsbm.bmHeight, ACanvas.CopyMode);
  5151.     finally
  5152.       if RestorePalette then
  5153.         SelectPalette(ACanvas.FHandle, OldPalette, True);
  5154.     end;
  5155.   end;
  5156. end;
  5157.  
  5158. { FreeImage:
  5159.   If there are multiple references to the image, create a unique copy of the image.
  5160.   If FHandle = FDIBHandle, the DIB memory will be updated when the drawing
  5161.   handle is drawn upon, so no changes are needed to maintain image integrity.
  5162.   If FHandle <> FDIBHandle, the DIB will not track with changes made to
  5163.   the DDB, so destroy the DIB handle (but keep the DIB pixel format info).  }
  5164. procedure TBitmap.FreeImage;
  5165. begin
  5166.   with FImage do
  5167.     if FRefCount > 1 then
  5168.     begin
  5169.       HandleNeeded;
  5170.       CopyImage(FHandle, FPalette, FDIB)
  5171.     end
  5172.     else if FHandle <> FDIBHandle then
  5173.     begin
  5174.       if FDIBHandle <> 0 then
  5175.         if not DeleteObject(FDIBHandle) then GDIError;
  5176.       FDIBHandle := 0;
  5177.       FDIB.dsbm.bmBits := nil;
  5178.     end;
  5179. end;
  5180.  
  5181. function TBitmap.GetEmpty;
  5182. begin
  5183.   with FImage do
  5184.     Result := (FHandle = 0) and (FDIBHandle = 0);
  5185. end;
  5186.  
  5187. function TBitmap.GetCanvas: TCanvas;
  5188. begin
  5189.   if FCanvas = nil then
  5190.   begin
  5191.     HandleNeeded;
  5192.     FCanvas := TBitmapCanvas.Create(Self);
  5193.     FCanvas.OnChange := Changed;
  5194.     FCanvas.OnChanging := Changing;
  5195.   end;
  5196.   Result := FCanvas;
  5197. end;
  5198.  
  5199. { Since the user might modify the contents of the HBITMAP it must not be
  5200.   shared by another TBitmap when given to the user nor should it be selected
  5201.   into a DC. }
  5202. function TBitmap.GetHandle: HBITMAP;
  5203. begin
  5204.   FreeContext;
  5205.   HandleNeeded;
  5206.   Changing(Self);
  5207.   Result := FImage.FHandle;
  5208. end;
  5209.  
  5210. function TBitmap.GetHandleType: TBitmapHandleType;
  5211. begin
  5212.   with FImage do
  5213.   begin
  5214.     if (FHandle = 0) or (FHandle = FDIBHandle) then
  5215.       if FDIBHandle = 0 then
  5216.         if FDIB.dsbmih.biSize = 0 then
  5217.           Result := bmDDB
  5218.         else
  5219.           Result := bmDIB
  5220.       else
  5221.         Result := bmDIB
  5222.     else
  5223.       Result := bmDDB;
  5224.   end;
  5225. end;
  5226.  
  5227. function TBitmap.GetHeight: Integer;
  5228. begin
  5229.   Result := Abs(FImage.FDIB.dsbm.bmHeight);
  5230. end;
  5231.  
  5232. function TBitmap.GetMaskHandle: HBITMAP;
  5233. begin
  5234.   MaskHandleNeeded;
  5235.   Result := FImage.FMaskHandle;
  5236. end;
  5237.  
  5238. function TBitmap.GetMonochrome: Boolean;
  5239. begin
  5240.   with FImage.FDIB.dsbm do
  5241.     Result := (bmPlanes = 1) and (bmBitsPixel = 1);
  5242. end;
  5243.  
  5244. function TBitmap.GetPalette: HPALETTE;
  5245. begin
  5246.   PaletteNeeded;
  5247.   Result := FImage.FPalette;
  5248. end;
  5249.  
  5250. function TBitmap.GetPixelFormat: TPixelFormat;
  5251. begin
  5252.   Result := pfCustom;
  5253.   if HandleType = bmDDB then
  5254.     Result := pfDevice
  5255.   else
  5256.     with FImage.FDIB, dsbmih do
  5257.       case biBitCount of
  5258.         1: Result := pf1Bit;
  5259.         4: Result := pf4Bit;
  5260.         8: Result := pf8Bit;
  5261.        16: case biCompression of
  5262.              BI_RGB : Result := pf15Bit;
  5263.              BI_BITFIELDS: if dsBitFields[1] = $7E0 then Result := pf16Bit;
  5264.            end;
  5265.        24: Result := pf24Bit;
  5266.        32: if biCompression = BI_RGB then Result := pf32Bit;
  5267.       end;
  5268. end;
  5269.  
  5270. function TBitmap.GetScanLine(Row: Integer): Pointer;
  5271. begin
  5272.   with FImage.FDIB, dsbm, dsbmih do
  5273.   begin
  5274.     if (Row < 0) or (Row > bmHeight) then
  5275.       InvalidOperation(SScanLine);
  5276.     DIBNeeded;
  5277.     GDIFlush;
  5278.     if biHeight > 0 then  // bottom-up DIB
  5279.       Row := biHeight - Row - 1;
  5280.     Integer(Result) := Integer(bmBits) +
  5281.       Row * BytesPerScanline(biWidth, biBitCount, 32);
  5282.   end;
  5283. end;
  5284.  
  5285. function TBitmap.GetTransparentColor: TColor;
  5286. begin
  5287.   if FTransparentColor = clDefault then
  5288.   begin
  5289.     if Monochrome then
  5290.       Result := clWhite
  5291.     else
  5292.       Result := Canvas.Pixels[0, Height - 1];
  5293.   end
  5294.   else Result := ColorToRGB(FTransparentColor);
  5295.   Result := Result or $02000000;
  5296. end;
  5297.  
  5298. function TBitmap.GetWidth: Integer;
  5299. begin
  5300.   Result := FImage.FDIB.dsbm.bmWidth;
  5301. end;
  5302.  
  5303. procedure TBitmap.DIBNeeded;
  5304. begin
  5305.   with FImage do
  5306.   begin
  5307.     if (FHandle = 0) or (FDIBHandle <> 0) then Exit;
  5308.     PaletteNeeded;
  5309.     if FDIB.dsbmih.biSize = 0 then
  5310.     begin
  5311.       GetObject(FHandle, sizeof(FDIB), @FDIB);
  5312.       with FDIB, dsbm, dsbmih do
  5313.       begin
  5314.         biSize := sizeof(dsbmih);
  5315.         biWidth := bmWidth;
  5316.         biHeight := bmHeight;
  5317.         biPlanes := 1;
  5318.         biBitCount := bmPlanes * bmBitsPixel;
  5319.       end;
  5320.     end;
  5321.     FDIBHandle := CopyBitmap(FHandle, FPalette, FPalette, FDIB, nil);
  5322.   end;
  5323. end;
  5324.  
  5325. procedure TBitmap.FreeContext;
  5326. begin
  5327.   if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
  5328. end;
  5329.  
  5330. procedure TBitmap.HandleNeeded;
  5331. begin
  5332.   with FImage do
  5333.     if FHandle = 0 then
  5334.       FHandle := FDIBHandle;
  5335. end;
  5336.  
  5337. procedure TBitmap.Mask(TransparentColor: TColor);
  5338. var
  5339.   NewHandle, NewPalette: THandle;
  5340.   DIB: TDIBSection;
  5341. begin
  5342.   NewHandle := 0;
  5343.   NewPalette := 0;
  5344.   try
  5345.     FreeContext;
  5346.     HandleNeeded;
  5347.     NewHandle := CopyBitmapAsMask(FImage.FHandle, FImage.FPalette,
  5348.       ColorToRGB(TransparentColor));
  5349.     FillChar(DIB, SizeOf(DIB), 0);
  5350.     GetObject(NewHandle, SizeOf(DIB), @DIB);
  5351.     if FImage.FPalette = SystemPalette16 then
  5352.       NewPalette := FImage.FPalette
  5353.     else
  5354.       NewPalette := CopyPalette(FImage.FPalette);
  5355.     NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  5356.   except
  5357.     InternalDeletePalette(NewPalette);
  5358.     if NewHandle <> 0 then DeleteObject(NewHandle);
  5359.     raise;
  5360.   end;
  5361.   Changed(Self);
  5362. end;
  5363.  
  5364. procedure TBitmap.MaskHandleNeeded;
  5365. begin
  5366.   if FMaskValid and FMaskBitsValid then Exit;
  5367.   with FImage do
  5368.   begin
  5369.     { Delete existing mask if any }
  5370.     if FMaskHandle <> 0 then
  5371.     begin
  5372.       DeselectBitmap(FMaskHandle);
  5373.       DeleteObject(FMaskHandle);
  5374.       FMaskHandle := 0;
  5375.     end;
  5376.     FreeContext;
  5377.     HandleNeeded;
  5378.     FMaskHandle := CopyBitmapAsMask(FHandle, FPalette, GetTransparentColor);
  5379.     FMaskValid := True;
  5380.     FMaskBitsValid := True;
  5381.   end;
  5382. end;
  5383.  
  5384. procedure TBitmap.PaletteNeeded;
  5385. var
  5386.   DC: HDC;
  5387. begin
  5388.   with FImage do
  5389.   begin
  5390.     if FIgnorePalette or (FPalette <> 0) or (FDIBHandle = 0) then Exit;
  5391.     if FHandle = FDIBHandle then DeselectBitmap(FDIBHandle);
  5392.     FPalette := PaletteFromDIBColorTable(FDIBHandle, nil, 1 shl FDIB.dsbmih.biBitCount);
  5393.     if FPalette <> 0 then Exit;
  5394.     DC := GDICheck(GetDC(0));
  5395.     FHalftone := FHalftone or
  5396.       ((GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <
  5397.       (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  5398.     if FHalftone then FPalette := CreateHalftonePalette(DC);
  5399.     ReleaseDC(0, DC);
  5400.     if FPalette = 0 then IgnorePalette := True;
  5401.   end;
  5402. end;
  5403.  
  5404. procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  5405.   APalette: HPALETTE);
  5406. var
  5407.   DIB: TDIBSection;
  5408. begin
  5409.   if (AFormat <> CF_BITMAP) or (AData = 0) then
  5410.     InvalidGraphic(SUnknownClipboardFormat);
  5411.   FreeContext;
  5412.   FillChar(DIB, sizeof(DIB), 0);
  5413.   GetObject(AData, sizeof(DIB), @DIB);
  5414.   if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
  5415.   CopyImage(AData, APalette, DIB);
  5416.   FImage.FOS2Format := False;
  5417.   PaletteModified := Palette <> 0;
  5418.   Changed(Self);
  5419. end;
  5420.  
  5421. procedure TBitmap.LoadFromStream(Stream: TStream);
  5422. begin
  5423.   ReadStream(Stream, Stream.Size - Stream.Position);
  5424. end;
  5425.  
  5426. procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
  5427. var
  5428.   Stream: TCustomMemoryStream;
  5429. begin
  5430.   Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  5431.   try
  5432.     ReadDIB(Stream, Stream.Size);
  5433.   finally
  5434.     Stream.Free;
  5435.   end;
  5436. end;
  5437.  
  5438. procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
  5439. var
  5440.   Stream: TCustomMemoryStream;
  5441. begin
  5442.   Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  5443.   try
  5444.     ReadDIB(Stream, Stream.Size);
  5445.   finally
  5446.     Stream.Free;
  5447.   end;
  5448. end;
  5449.  
  5450. procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  5451.   const NewDIB: TDIBSection; OS2Format: Boolean);
  5452. var
  5453.   Image: TBitmapImage;
  5454. begin
  5455.   Image := TBitmapImage.Create;
  5456.   with Image do
  5457.   try
  5458.     FHandle := NewHandle;
  5459.     FPalette := NewPalette;
  5460.     FDIB := NewDIB;
  5461.     FOS2Format := OS2Format;
  5462.     if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
  5463.   except
  5464.     Image.Free;
  5465.     raise;
  5466.   end;
  5467.   EnterCriticalSection(BitmapImageLock);
  5468.   try
  5469.     FImage.Release;
  5470.     FImage := Image;
  5471.     FImage.Reference;
  5472.   finally
  5473.     LeaveCriticalSection(BitmapImageLock);
  5474.   end;
  5475.   FMaskValid := False;
  5476. end;
  5477.  
  5478. procedure TBitmap.ReadData(Stream: TStream);
  5479. var
  5480.   Size: Longint;
  5481. begin
  5482.   Stream.Read(Size, SizeOf(Size));
  5483.   ReadStream(Stream, Size);
  5484. end;
  5485.  
  5486. procedure TBitmap.ReadDIB(Stream: TStream; ImageSize: Longint);
  5487. const
  5488.   DIBPalSizes: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  5489. var
  5490.   DC, MemDC: HDC;
  5491.   BitsMem: Pointer;
  5492.   OS2Header: TBitmapCoreHeader;
  5493.   BitmapInfo: PBitmapInfo;
  5494.   ColorTable: Pointer;
  5495.   HeaderSize: Integer;
  5496.   SectionHandle: THandle;
  5497.   SectionOffset: Integer;
  5498.   OS2Format: Boolean;
  5499.   BMHandle: HBITMAP;
  5500.   DIB: TDIBSection;
  5501.   Pal, OldPal: HPalette;
  5502. begin
  5503.   Pal := 0;
  5504.   Stream.Read(HeaderSize, sizeof(HeaderSize));
  5505.   OS2Format := HeaderSize = sizeof(OS2Header);
  5506.   if OS2Format then HeaderSize := sizeof(TBitmapInfoHeader);
  5507.   GetMem(BitmapInfo, HeaderSize + 256 * sizeof(TRGBQuad));
  5508.   with BitmapInfo^ do
  5509.   try
  5510.     if OS2Format then  // convert OS2 DIB to Win DIB
  5511.     begin
  5512.       Stream.Read(Pointer(Longint(@OS2Header) + sizeof(HeaderSize))^,
  5513.         sizeof(OS2Header) - sizeof(HeaderSize));
  5514.       FillChar(bmiHeader, sizeof(bmiHeader), 0);
  5515.       with bmiHeader, OS2Header do
  5516.       begin
  5517.         biWidth := bcWidth;
  5518.         biHeight := bcHeight;
  5519.         biPlanes := bcPlanes;
  5520.         biBitCount := bcBitCount;
  5521.       end;
  5522.       Dec(ImageSize, sizeof(OS2Header));
  5523.     end
  5524.     else
  5525.     begin // support bitmap headers larger than TBitmapInfoHeader
  5526.       Stream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
  5527.         HeaderSize - sizeof(HeaderSize));
  5528.       Dec(ImageSize, HeaderSize);
  5529.     end;
  5530.  
  5531.     with bmiHeader do
  5532.     begin
  5533.       biSize := HeaderSize;
  5534.       ColorTable := Pointer(Longint(BitmapInfo) + HeaderSize);
  5535.  
  5536.       { check number of planes. DIBs must be 1 color plane (packed pixels) }
  5537.       if biPlanes <> 1 then InvalidBitmap;
  5538.  
  5539.       // 3 DWORD color element bit masks (ie 888 or 565) can precede colors
  5540.       if (HeaderSize = sizeof(TBitmapInfoHeader)) and
  5541.         ((biBitCount = 16) or (biBitCount = 32)) and
  5542.         (biCompression = BI_BITFIELDS) then
  5543.       begin
  5544.         Stream.ReadBuffer(ColorTable^, 3 * sizeof(DWORD));
  5545.         Inc(Longint(ColorTable), 3 * sizeof(DWORD));
  5546.         Dec(ImageSize, 3 * sizeof(DWORD));
  5547.       end;
  5548.  
  5549.       // Read the color palette
  5550.       if biClrUsed = 0 then
  5551.         biClrUsed := GetDInColors(biBitCount);
  5552.       Stream.ReadBuffer(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
  5553.       Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);
  5554.  
  5555.       // biSizeImage can be zero. If zero, compute the size.
  5556.       if biSizeImage = 0 then            // top-down DIBs have negative height
  5557.         biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
  5558.  
  5559.       if biSizeImage < ImageSize then ImageSize := biSizeImage;
  5560.     end;
  5561.  
  5562.     { convert OS2 color table to DIB color table }
  5563.     if OS2Format then RGBTripleToQuad(ColorTable^);
  5564.  
  5565. {!!    if (Stream is TMemoryMappedStream) then
  5566.     begin
  5567.       SectionHandle := Stream.Handle;
  5568.       SectionOffset := Stream.Position;
  5569.     end
  5570.     else
  5571. }   begin
  5572.       SectionHandle := 0;
  5573.       SectionOffset := 0;
  5574.     end;
  5575.  
  5576.     DC := GDICheck(GetDC(0));
  5577.     try
  5578.       if (bmiHeader.biCompression = BI_RLE8)
  5579.         or (bmiHeader.biCompression = BI_RLE4) or DDBsOnly then
  5580.       begin
  5581.         MemDC := 0;
  5582.         GetMem(BitsMem, ImageSize);
  5583.         try
  5584.           Stream.ReadBuffer(BitsMem^, ImageSize);
  5585.           MemDC := GDICheck(CreateCompatibleDC(DC));
  5586.           DeleteObject(SelectObject(MemDC, CreateCompatibleBitmap(DC, 1, 1)));
  5587.           OldPal := 0;
  5588.           if bmiHeader.biClrUsed > 0 then
  5589.           begin
  5590.             Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
  5591.             OldPal := SelectPalette(MemDC, Pal, False);
  5592.             RealizePalette(MemDC);
  5593.           end;
  5594.  
  5595.           try
  5596.             BMHandle := CreateDIBitmap(MemDC, BitmapInfo^.bmiHeader, CBM_INIT, BitsMem,
  5597.               BitmapInfo^, DIB_RGB_COLORS);
  5598.             if (BMHandle = 0) then
  5599.               if GetLastError = 0 then InvalidBitmap else RaiseLastWin32Error;
  5600.           finally
  5601.             if OldPal <> 0 then
  5602.               SelectPalette(MemDC, OldPal, True);
  5603.           end;
  5604.         finally
  5605.           if MemDC <> 0 then DeleteDC(MemDC);
  5606.           FreeMem(BitsMem);
  5607.         end;
  5608.       end
  5609.       else
  5610.       begin
  5611.         BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem,
  5612.           SectionHandle, SectionOffset);
  5613.         if (BMHandle = 0) or (BitsMem = nil) then
  5614.           if GetLastError = 0 then InvalidBitmap else RaiseLastWin32Error;
  5615.  
  5616.         try
  5617.           if SectionHandle = 0 then
  5618.             Stream.ReadBuffer(BitsMem^, ImageSize);
  5619.         except
  5620.           DeleteObject(BMHandle);
  5621.           raise;
  5622.         end;
  5623.       end;
  5624.     finally
  5625.       ReleaseDC(0, DC);
  5626.     end;
  5627.     // Hi-color DIBs don't preserve color table, so create palette now
  5628.     if (bmiHeader.biBitCount > 8) and (bmiHeader.biClrUsed > 0) and (Pal = 0)then
  5629.       Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
  5630.   finally
  5631.     FreeMem(BitmapInfo);
  5632.   end;
  5633.   FillChar(DIB, sizeof(DIB), 0);
  5634.   GetObject(BMHandle, Sizeof(DIB), @DIB);
  5635.   NewImage(BMHandle, Pal, DIB, OS2Format);
  5636.   PaletteModified := Palette <> 0;
  5637.   Changed(Self);
  5638. end;
  5639.  
  5640. procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
  5641. var
  5642.   Bmf: TBitmapFileHeader;
  5643.   DIB: TDIBSection;
  5644. begin
  5645.   FreeContext;
  5646.   if Size = 0 then
  5647.   begin
  5648.     FillChar(DIB, sizeof(DIB), 0);
  5649.     NewImage(0, 0, DIB, False);
  5650.   end
  5651.   else
  5652.   begin
  5653.     Stream.ReadBuffer(Bmf, sizeof(Bmf));
  5654.     if Bmf.bfType <> $4D42 then InvalidBitmap;
  5655.     ReadDIB(Stream, Size - sizeof(Bmf));
  5656.   end;
  5657. end;
  5658.  
  5659. procedure TBitmap.SetHandle(Value: HBITMAP);
  5660. var
  5661.   DIB: TDIBSection;
  5662.   APalette: HPALETTE;
  5663. begin
  5664.   with FImage do
  5665.     if FHandle <> Value then
  5666.     begin
  5667.       FreeContext;
  5668.       FillChar(DIB, sizeof(DIB), 0);
  5669.       if Value <> 0 then
  5670.         GetObject(Value, SizeOf(DIB), @DIB);
  5671.       if FRefCount = 1 then
  5672.       begin
  5673.         APalette := FPalette;
  5674.         FPalette := 0;
  5675.       end
  5676.       else
  5677.         if FPalette = SystemPalette16 then
  5678.           APalette := SystemPalette16
  5679.         else
  5680.           APalette := CopyPalette(FPalette);
  5681.       try
  5682.         NewImage(Value, APalette, DIB, False);
  5683.       except
  5684.         InternalDeletePalette(APalette);
  5685.         raise;
  5686.       end;
  5687.       Changed(Self);
  5688.     end;
  5689. end;
  5690.  
  5691. procedure TBitmap.SetHandleType(Value: TBitmapHandleType);
  5692. var
  5693.   DIB: TDIBSection;
  5694.   AHandle: HBITMAP;
  5695.   NewPalette: HPALETTE;
  5696.   DoCopy: Boolean;
  5697. begin
  5698.   if Value = GetHandleType then Exit;
  5699.   with FImage do
  5700.   begin
  5701.     if (FHandle = 0) and (FDIBHandle = 0) then
  5702.       if Value = bmDDB then
  5703.         FDIB.dsbmih.biSize := 0
  5704.       else
  5705.         FDIB.dsbmih.biSize := sizeof(FDIB.dsbmih)
  5706.     else
  5707.     begin
  5708.       if Value = bmDIB then
  5709.       begin
  5710.         if (FDIBHandle <> 0) and (FDIBHandle = FHandle) then Exit;
  5711.         FreeContext;
  5712.         PaletteNeeded;
  5713.         DIBNeeded;
  5714.         if FRefCount = 1 then
  5715.         begin
  5716.           AHandle := FDIBHandle;
  5717.           FDIBHandle := 0;
  5718.           NewPalette := FPalette;
  5719.           FPalette := 0;
  5720.           NewImage(AHandle, NewPalette, FDIB, FOS2Format);
  5721.         end
  5722.         else
  5723.           CopyImage(FDIBHandle, FPalette, FDIB);
  5724.       end
  5725.       else
  5726.       begin
  5727.         if (FHandle <> 0) and (FHandle <> FDIBHandle) then Exit;
  5728.         FreeContext;
  5729.         PaletteNeeded;
  5730.         DIB := FDIB;
  5731.         DIB.dsbmih.biSize := 0;   // flag to tell CopyBitmap to create a DDB
  5732.         DoCopy := FRefCount = 1;
  5733.         if DoCopy then
  5734.           NewPalette := FPalette
  5735.         else
  5736.           NewPalette := CopyPalette(FPalette);
  5737.         AHandle := CopyBitmap(FDIBHandle, FPalette, NewPalette, DIB, nil);
  5738.         if DoCopy then
  5739.           FHandle := AHandle
  5740.         else
  5741.           NewImage(AHandle, NewPalette, DIB, FOS2Format);
  5742.       end;
  5743.       Changed(Self);
  5744.     end;
  5745.   end;
  5746. end;
  5747.  
  5748. procedure TBitmap.SetHeight(Value: Integer);
  5749. var
  5750.   DIB: TDIBSection;
  5751. begin
  5752.   with FImage do
  5753.     if FDIB.dsbm.bmHeight <> Value then
  5754.     begin
  5755.       HandleNeeded;
  5756.       DIB := FDIB;
  5757.       DIB.dsbm.bmHeight := Value;
  5758.       DIB.dsbmih.biHeight := Value;
  5759.       CopyImage(FHandle, FPalette, DIB);
  5760.       Changed(Self);
  5761.     end;
  5762. end;
  5763.  
  5764. procedure TBitmap.SetMonochrome(Value: Boolean);
  5765. var
  5766.   DIB: TDIBSection;
  5767. begin
  5768.   with FImage, FDIB.dsbmih do
  5769.     if Value <> ((biPlanes = 1) and (biBitCount = 1)) then
  5770.     begin
  5771.       HandleNeeded;
  5772.       DIB := FDIB;
  5773.       with DIB.dsbmih, DIB.dsbm do
  5774.       begin
  5775.         biSize := 0;   // request DDB handle
  5776.         biPlanes := Byte(Value);  // 0 = request screen BMP format
  5777.         biBitCount := Byte(Value);
  5778.         bmPlanes := Byte(Value);
  5779.         bmBitsPixel := Byte(Value);
  5780.       end;
  5781.       CopyImage(FHandle, FPalette, DIB);
  5782.       Changed(Self);
  5783.     end;
  5784. end;
  5785.  
  5786. procedure TBitmap.SetPalette(Value: HPALETTE);
  5787. var
  5788.   AHandle: HBITMAP;
  5789.   DIB: TDIBSection;
  5790. begin
  5791.   if FImage.FPalette <> Value then
  5792.   begin
  5793.     with FImage do
  5794.       if (Value = 0) and (FRefCount = 1) then
  5795.       begin
  5796.         InternalDeletePalette(FPalette);
  5797.         FPalette := 0;
  5798.       end
  5799.       else
  5800.       begin
  5801.         FreeContext;
  5802.         HandleNeeded;
  5803.         DIB := FDIB;
  5804.         AHandle := CopyBitmap(FHandle, FPalette, Value, DIB, nil);
  5805.         try
  5806.           NewImage(AHandle, Value, DIB, FOS2Format);
  5807.         except
  5808.           DeleteObject(AHandle);
  5809.           raise;
  5810.         end;
  5811.       end;
  5812.     UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
  5813.     PaletteModified := True;
  5814.     Changed(Self);
  5815.   end;
  5816. end;
  5817.  
  5818. procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
  5819. const
  5820.   BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
  5821. var
  5822.   DIB: TDIBSection;
  5823.   Pal: HPalette;
  5824.   DC: HDC;
  5825. begin
  5826.   if Value = GetPixelFormat then Exit;
  5827.   case Value of
  5828.     pfDevice:
  5829.       begin
  5830.         HandleType := bmDDB;
  5831.         Exit;
  5832.       end;
  5833.     pfCustom: InvalidGraphic(SInvalidPixelFormat);
  5834.   else
  5835.     FillChar(DIB, sizeof(DIB), 0);
  5836.     DIB.dsbm := FImage.FDIB.dsbm;
  5837.     with DIB, dsbm, dsbmih do
  5838.     begin
  5839.       bmBits := nil;
  5840.       biSize := sizeof(DIB.dsbmih);
  5841.       biWidth := bmWidth;
  5842.       biHeight := bmHeight;
  5843.       biPlanes := 1;
  5844.       biBitCount := BitCounts[Value];
  5845.       Pal := FImage.FPalette;
  5846.       case Value of
  5847.         pf4Bit: Pal := SystemPalette16;
  5848.         pf8Bit:
  5849.           begin
  5850.             DC := GDICheck(GetDC(0));
  5851.             Pal := CreateHalftonePalette(DC);
  5852.             ReleaseDC(0, DC);
  5853.           end;
  5854.         pf16Bit:
  5855.           begin
  5856.             biCompression := BI_BITFIELDS;
  5857.             dsBitFields[0] := $F800;
  5858.             dsBitFields[1] := $07E0;
  5859.             dsBitFields[2] := $001F;
  5860.           end;
  5861.       end;
  5862.       CopyImage(Handle, Pal, DIB);
  5863.       PaletteModified := Pal <> 0;
  5864.       Changed(Self);
  5865.     end;
  5866.   end;
  5867. end;
  5868.  
  5869. procedure TBitmap.SetTransparentColor(Value: TColor);
  5870. begin
  5871.   if Value <> FTransparentColor then
  5872.   begin
  5873.     if Value = clDefault then
  5874.       FTransparentMode := tmAuto else
  5875.       FTransparentMode := tmFixed;
  5876.     FTransparentColor := Value;
  5877.     if FImage.FRefCount > 1 then
  5878.     with FImage do
  5879.     begin
  5880.       HandleNeeded;
  5881.       CopyImage(FHandle, FPalette, FDIB);
  5882.     end;
  5883.     Changed(Self);
  5884.   end;
  5885. end;
  5886.  
  5887. procedure TBitmap.SetTransparentMode(Value: TTransparentMode);
  5888. begin
  5889.   if Value <> FTransparentMode then
  5890.   begin
  5891.     if Value = tmAuto then
  5892.       SetTransparentColor(clDefault) else
  5893.       SetTransparentColor(GetTransparentColor);
  5894.   end;
  5895. end;
  5896.  
  5897. procedure TBitmap.SetWidth(Value: Integer);
  5898. var
  5899.   DIB: TDIBSection;
  5900. begin
  5901.   with FImage do
  5902.     if FDIB.dsbm.bmWidth <> Value then
  5903.     begin
  5904.       HandleNeeded;
  5905.       DIB := FDIB;
  5906.       DIB.dsbm.bmWidth := Value;
  5907.       DIB.dsbmih.biWidth := Value;
  5908.       CopyImage(FHandle, FPalette, DIB);
  5909.       Changed(Self);
  5910.     end;
  5911. end;
  5912.  
  5913. procedure TBitmap.WriteData(Stream: TStream);
  5914. begin
  5915.   WriteStream(Stream, True);
  5916. end;
  5917.  
  5918. procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
  5919. const
  5920.   PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  5921. var
  5922.   Size: Integer;
  5923.   HeaderSize: Integer;
  5924.   BMF: TBitmapFileHeader;
  5925.   Save: THandle;
  5926.   BC: TBitmapCoreHeader;
  5927.   ColorCount: Integer;
  5928.   Colors: array [Byte] of TRGBQuad;
  5929. begin
  5930.   DIBNeeded;
  5931.   with FImage do
  5932.   begin
  5933.     Size := 0;
  5934.     if FDIBHandle <> 0 then
  5935.     begin
  5936.       InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, 0);
  5937.       if FOS2Format then
  5938.       begin
  5939.         HeaderSize := sizeof(BC);
  5940.         if FDIB.dsbmih.biBitCount <= 8 then
  5941.           Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
  5942.       end;
  5943.       Inc(Size, HeaderSize + sizeof(BMF));
  5944.     end;
  5945.     if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
  5946.     if Size <> 0 then
  5947.     begin
  5948.       FillChar(BMF, sizeof(BMF), 0);
  5949.       BMF.bfType := $4D42;
  5950.       BMF.bfSize := Size;
  5951.       BMF.bfOffBits := sizeof(BMF) + HeaderSize;
  5952.  
  5953.       Canvas.RequiredState([csHandleValid]);
  5954.       Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
  5955.       ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
  5956.       SelectObject(FCanvas.FHandle, Save);
  5957.       if (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
  5958.         ColorCount := PaletteToDIBColorTable(FPalette, Colors);
  5959.  
  5960.       FixupBitFields(FDIB);
  5961.       if (ColorCount <> 0) then
  5962.       begin
  5963.         if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
  5964.           FDIB.dsbmih.biClrUsed := ColorCount;
  5965.         if FOS2Format then RGBQuadToTriple(Colors, ColorCount);
  5966.       end;
  5967.       if FOS2Format then
  5968.       begin
  5969.         with BC, FDIB.dsbmih do
  5970.         begin
  5971.           bcSize := sizeof(BC);
  5972.           bcWidth := biWidth;
  5973.           bcHeight := biHeight;
  5974.           bcPlanes := 1;
  5975.           bcBitCount := biBitCount;
  5976.         end;
  5977.         Stream.WriteBuffer(BMF, sizeof(BMF));
  5978.         Stream.WriteBuffer(BC, sizeof(BC));
  5979.       end
  5980.       else
  5981.       begin
  5982.         Stream.WriteBuffer(BMF, Sizeof(BMF));
  5983.         Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
  5984.         if (FDIB.dsbmih.biBitCount > 8) and
  5985.           ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
  5986.           Stream.WriteBuffer(FDIB.dsBitfields, 12);
  5987.       end;
  5988.       Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
  5989.       Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
  5990.     end;
  5991.   end;
  5992. end;
  5993.  
  5994. { ReleaseHandle gives up ownership of the bitmap handle the TBitmap contains. }
  5995. function TBitmap.ReleaseHandle: HBITMAP;
  5996. begin
  5997.   HandleNeeded;
  5998.   Changing(Self);
  5999.   with FImage do
  6000.   begin
  6001.     Result := FHandle;
  6002.     if FHandle = FDIBHandle then
  6003.     begin
  6004.       FDIBHandle := 0;
  6005.       FDIB.dsbm.bmBits := nil;
  6006.     end;
  6007.     FHandle := 0;
  6008.   end;
  6009. end;
  6010.  
  6011. function TBitmap.ReleaseMaskHandle: HBITMAP;
  6012. begin
  6013.   Result := GetMaskHandle;
  6014.   FImage.FMaskHandle := 0;
  6015. end;
  6016.  
  6017. function TBitmap.ReleasePalette: HPALETTE;
  6018. begin
  6019.   HandleNeeded;
  6020.   Changing(Self);
  6021.   Result := FImage.FPalette;
  6022.   FImage.FPalette := 0;
  6023. end;
  6024.  
  6025. procedure TBitmap.SaveToStream(Stream: TStream);
  6026. begin
  6027.   WriteStream(Stream, False);
  6028. end;
  6029.  
  6030. procedure TBitmap.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  6031.   var APalette: HPALETTE);
  6032. var
  6033.   DIB: TDIBSection;
  6034. begin
  6035.   Format := CF_BITMAP;
  6036.   HandleNeeded;
  6037.   with FImage do
  6038.   begin
  6039.     DIB := FDIB;
  6040.     DIB.dsbmih.biSize := 0;   // copy to device bitmap
  6041.     DIB.dsbm.bmBits := nil;
  6042.     Data := CopyBitmap(FHandle, FPalette, FPalette, DIB, FCanvas);
  6043.   end;
  6044.   try
  6045.     APalette := CopyPalette(FImage.FPalette);
  6046.   except
  6047.     DeleteObject(Data);
  6048.     raise;
  6049.   end;
  6050. end;
  6051.  
  6052. function TBitmap.TransparentColorStored: Boolean;
  6053. begin
  6054.   Result := FTransparentMode = tmFixed;
  6055. end;
  6056.  
  6057. { TIconImage }
  6058.  
  6059. destructor TIconImage.Destroy;
  6060. begin
  6061.   FMemoryImage.Free;
  6062.   inherited Destroy;
  6063. end;
  6064.  
  6065. procedure TIconImage.FreeHandle;
  6066. begin
  6067.   if FHandle <> 0 then DestroyIcon(FHandle);
  6068.   FHandle := 0;
  6069. end;
  6070.  
  6071. { TIcon }
  6072.  
  6073. constructor TIcon.Create;
  6074. begin
  6075.   inherited Create;
  6076.   Transparent := True;
  6077.   FImage := TIconImage.Create;
  6078.   FImage.Reference;
  6079. end;
  6080.  
  6081. destructor TIcon.Destroy;
  6082. begin
  6083.   FImage.Release;
  6084.   inherited Destroy;
  6085. end;
  6086.  
  6087. procedure TIcon.Assign(Source: TPersistent);
  6088. begin
  6089.   if (Source = nil) or (Source is TIcon) then
  6090.   begin
  6091.     if Source <> nil then
  6092.     begin
  6093.       TIcon(Source).FImage.Reference;
  6094.       FImage.Release;
  6095.       FImage := TIcon(Source).FImage;
  6096.     end else
  6097.       NewImage(0, nil);
  6098.     Changed(Self);
  6099.     Exit;
  6100.   end;
  6101.   inherited Assign(Source);
  6102. end;
  6103.  
  6104. procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
  6105. begin
  6106.   with Rect.TopLeft do
  6107.   begin
  6108.     ACanvas.RequiredState([csHandleValid]);
  6109.     DrawIcon(ACanvas.FHandle, X, Y, Handle);
  6110.   end;
  6111. end;
  6112.  
  6113. function TIcon.GetEmpty: Boolean;
  6114. begin
  6115.   with FImage do
  6116.     Result := (FHandle = 0) and (FMemoryImage = nil);
  6117. end;
  6118.  
  6119. function TIcon.GetHandle: HICON;
  6120. begin
  6121.   HandleNeeded;
  6122.   Result := FImage.FHandle;
  6123. end;
  6124.  
  6125. function TIcon.GetHeight: Integer;
  6126. begin
  6127.   Result := GetSystemMetrics(SM_CYICON);
  6128. end;
  6129.  
  6130. function TIcon.GetWidth: Integer;
  6131. begin
  6132.   Result := GetSystemMetrics(SM_CXICON);
  6133. end;
  6134.  
  6135. procedure TIcon.HandleNeeded;
  6136. var
  6137.   CI: TCursorOrIcon;
  6138.   NewHandle: HICON;
  6139. begin
  6140.   with FImage do
  6141.   begin
  6142.     if FHandle <> 0 then Exit;
  6143.     if FMemoryImage = nil then Exit;
  6144.     FMemoryImage.Position := 0;
  6145.     FMemoryImage.ReadBuffer(CI, SizeOf(CI));
  6146.     case CI.wType of
  6147.       RC3_STOCKICON: NewHandle := StockIcon;
  6148.       RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI));
  6149.     else
  6150.       InvalidIcon;
  6151.     end;
  6152.     FHandle := NewHandle;
  6153.   end;
  6154. end;
  6155.  
  6156. procedure TIcon.ImageNeeded;
  6157. var
  6158.   Image: TMemoryStream;
  6159.   CI: TCursorOrIcon;
  6160. begin
  6161.   with FImage do
  6162.   begin
  6163.     if FMemoryImage <> nil then Exit;
  6164.     if FHandle = 0 then InvalidIcon;
  6165.     Image := TMemoryStream.Create;
  6166.     try
  6167.       if GetHandle = StockIcon then
  6168.       begin
  6169.         FillChar(CI, SizeOf(CI), 0);
  6170.         Image.WriteBuffer(CI, SizeOf(CI));
  6171.       end
  6172.       else
  6173.         WriteIcon(Image, Handle, False);
  6174.     except
  6175.       Image.Free;
  6176.       raise;
  6177.     end;
  6178.     FMemoryImage := Image;
  6179.   end;
  6180. end;
  6181.  
  6182. procedure TIcon.LoadFromStream(Stream: TStream);
  6183. var
  6184.   Image: TMemoryStream;
  6185.   CI: TCursorOrIcon;
  6186. begin
  6187.   Image := TMemoryStream.Create;
  6188.   try
  6189.     Image.SetSize(Stream.Size - Stream.Position);
  6190.     Stream.ReadBuffer(Image.Memory^, Image.Size);
  6191.     Image.ReadBuffer(CI, SizeOf(CI));
  6192.     if not (CI.wType in [RC3_STOCKICON, RC3_ICON]) then InvalidIcon;
  6193.     NewImage(0, Image);
  6194.   except
  6195.     Image.Free;
  6196.     raise;
  6197.   end;
  6198.   Changed(Self);
  6199. end;
  6200.  
  6201. procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  6202. var
  6203.   Image: TIconImage;
  6204. begin
  6205.   Image := TIconImage.Create;
  6206.   try
  6207.     Image.FHandle := NewHandle;
  6208.     Image.FMemoryImage := NewImage;
  6209.   except
  6210.     Image.Free;
  6211.     raise;
  6212.   end;
  6213.   Image.Reference;
  6214.   FImage.Release;
  6215.   FImage := Image;
  6216. end;
  6217.  
  6218. function TIcon.ReleaseHandle: HICON;
  6219. begin
  6220.   with FImage do
  6221.   begin
  6222.     if FRefCount > 1 then NewImage(CopyIcon(FHandle), nil);
  6223.     Result := FHandle;
  6224.     FHandle := 0;
  6225.   end;
  6226.   Changed(Self);
  6227. end;
  6228.  
  6229. procedure TIcon.SetHandle(Value: HICON);
  6230. begin
  6231.   NewImage(Value, nil);
  6232.   Changed(Self);
  6233. end;
  6234.  
  6235. procedure TIcon.SetHeight(Value: Integer);
  6236. begin
  6237.   InvalidOperation(SChangeIconSize);
  6238. end;
  6239.  
  6240. procedure TIcon.SetWidth(Value: Integer);
  6241. begin
  6242.   InvalidOperation(SChangeIconSize);
  6243. end;
  6244.  
  6245. procedure TIcon.SaveToStream(Stream: TStream);
  6246. begin
  6247.   ImageNeeded;
  6248.   with FImage.FMemoryImage do Stream.WriteBuffer(Memory^, Size);
  6249. end;
  6250.  
  6251. procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  6252.   APalette: HPALETTE);
  6253. begin
  6254.   InvalidOperation(SIconToClipboard);
  6255. end;
  6256.  
  6257.  
  6258. procedure TIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  6259.   var APalette: HPALETTE);
  6260. begin
  6261.   InvalidOperation(SIconToClipboard);
  6262. end;
  6263.  
  6264.  
  6265. function GraphicFilter(GraphicClass: TGraphicClass): string;
  6266. var
  6267.   Filters: string;
  6268. begin
  6269.   GetFileFormats.BuildFilterStrings(GraphicClass, Result, Filters);
  6270. end;
  6271.  
  6272. function GraphicExtension(GraphicClass: TGraphicClass): string;
  6273. var
  6274.   I: Integer;
  6275. begin
  6276.   for I := GetFileFormats.Count-1 downto 0 do
  6277.     if PFileFormat(FileFormats[I])^.GraphicClass.ClassName = GraphicClass.ClassName then
  6278.     begin
  6279.       Result := PFileFormat(FileFormats[I])^.Extension;
  6280.       Exit;
  6281.     end;
  6282.   Result := '';
  6283. end;
  6284.  
  6285. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  6286. var
  6287.   Descriptions: string;
  6288. begin
  6289.   GetFileFormats.BuildFilterStrings(GraphicClass, Descriptions, Result);
  6290. end;
  6291.  
  6292. procedure InitScreenLogPixels;
  6293. const
  6294.   Pal16: array [0..15] of TColor =
  6295.     (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clDkGray,
  6296.      clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
  6297. var
  6298.   DC: HDC;
  6299. begin
  6300.   DC := GetDC(0);
  6301.   ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  6302.   ReleaseDC(0,DC);
  6303. //!!  SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
  6304.   SystemPalette16 := CreateSystemPalette(Pal16);
  6305. end;
  6306.  
  6307. function GetDefFontCharSet: TFontCharSet;
  6308. var
  6309.   DisplayDC: HDC;
  6310.   TxtMetric: TTEXTMETRIC;
  6311. begin
  6312.   Result := DEFAULT_CHARSET;
  6313.   DisplayDC := GetDC(0);
  6314.   if (DisplayDC <> 0) then
  6315.   begin
  6316.     if (SelectObject(DisplayDC, StockFont) <> 0) then
  6317.       if (GetTextMetrics(DisplayDC, TxtMetric)) then
  6318.         Result := TxtMetric.tmCharSet;
  6319.     ReleaseDC(0, DisplayDC);
  6320.   end;
  6321. end;
  6322.  
  6323. procedure InitDefFontData;
  6324. var
  6325.   Charset: TFontCharset;
  6326. begin
  6327.   DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  6328.   if not SysLocale.FarEast then Exit;
  6329.   Charset := GetDefFontCharset;
  6330.   case Charset of
  6331.     SHIFTJIS_CHARSET:
  6332.       begin
  6333.         DefFontData.Name := 'élér éoâSâVâbâN';
  6334.         DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
  6335.         DefFontData.CharSet := CharSet;
  6336.       end;
  6337.     CHINESEBIG5_CHARSET:
  6338.       begin
  6339.         DefFontData.Name := 'Times New Roman';
  6340.         DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
  6341.         DefFontData.CharSet := CharSet;
  6342.       end;
  6343.   end;
  6344. end;
  6345.  
  6346. initialization
  6347.   InitScreenLogPixels;
  6348.   InitializeCriticalSection(BitmapImageLock);
  6349.   InitializeCriticalSection(CounterLock);
  6350.   StockPen := GetStockObject(BLACK_PEN);
  6351.   StockBrush := GetStockObject(HOLLOW_BRUSH);
  6352.   StockFont := GetStockObject(SYSTEM_FONT);
  6353.   StockIcon := LoadIcon(0, IDI_APPLICATION);
  6354.   InitDefFontData;
  6355.   FontManager := TResourceManager.Create(SizeOf(TFontData));
  6356.   PenManager := TResourceManager.Create(SizeOf(TPenData));
  6357.   BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  6358.   BitmapCanvasList := TThreadList.Create;
  6359.   CanvasList := TThreadList.Create;
  6360.   RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
  6361.   RegisterIntegerConsts(TypeInfo(TFontCharset), IdentToCharset, CharsetToIdent);
  6362. finalization
  6363.   FileFormats.Free;
  6364.   ClipboardFormats.Free;
  6365.   FreeMemoryContexts;
  6366.   BitmapCanvasList.Free;
  6367.   CanvasList.Free;
  6368.   FontManager.Free;
  6369.   PenManager.Free;
  6370.   BrushManager.Free;
  6371.   DeleteObject(SystemPalette16);
  6372.   DeleteCriticalSection(BitmapImageLock);
  6373.   DeleteCriticalSection(CounterLock);
  6374. end.
  6375.