{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.Graphics platform;

{$P+,S-,W-,R-,T-,X+,H+,B-}

interface

uses
  Windows, SysUtils, Classes,
  System.Drawing, System.Drawing.Imaging, System.Reflection, System.GLobalization;

{ Graphics Objects }

type
  TColor = -$7FFFFFFF-1..$7FFFFFFF;

const
  clSystemColor = $FF000000;

  clScrollBar = TColor(clSystemColor or COLOR_SCROLLBAR);
  clBackground = TColor(clSystemColor or COLOR_BACKGROUND);
  clActiveCaption = TColor(clSystemColor or COLOR_ACTIVECAPTION);
  clInactiveCaption = TColor(clSystemColor or COLOR_INACTIVECAPTION);
  clMenu = TColor(clSystemColor or COLOR_MENU);
  clWindow = TColor(clSystemColor or COLOR_WINDOW);
  clWindowFrame = TColor(clSystemColor or COLOR_WINDOWFRAME);
  clMenuText = TColor(clSystemColor or COLOR_MENUTEXT);
  clWindowText = TColor(clSystemColor or COLOR_WINDOWTEXT);
  clCaptionText = TColor(clSystemColor or COLOR_CAPTIONTEXT);
  clActiveBorder = TColor(clSystemColor or COLOR_ACTIVEBORDER);
  clInactiveBorder = TColor(clSystemColor or COLOR_INACTIVEBORDER);
  clAppWorkSpace = TColor(clSystemColor or COLOR_APPWORKSPACE);
  clHighlight = TColor(clSystemColor or COLOR_HIGHLIGHT);
  clHighlightText = TColor(clSystemColor or COLOR_HIGHLIGHTTEXT);
  clBtnFace = TColor(clSystemColor or COLOR_BTNFACE);
  clBtnShadow = TColor(clSystemColor or COLOR_BTNSHADOW);
  clGrayText = TColor(clSystemColor or COLOR_GRAYTEXT);
  clBtnText = TColor(clSystemColor or COLOR_BTNTEXT);
  clInactiveCaptionText = TColor(clSystemColor or COLOR_INACTIVECAPTIONTEXT);
  clBtnHighlight = TColor(clSystemColor or COLOR_BTNHIGHLIGHT);
  cl3DDkShadow = TColor(clSystemColor or COLOR_3DDKSHADOW);
  cl3DLight = TColor(clSystemColor or COLOR_3DLIGHT);
  clInfoText = TColor(clSystemColor or COLOR_INFOTEXT);
  clInfoBk = TColor(clSystemColor or COLOR_INFOBK);
  clHotLight = TColor(clSystemColor or COLOR_HOTLIGHT);
  clGradientActiveCaption = TColor(clSystemColor or COLOR_GRADIENTACTIVECAPTION);
  clGradientInactiveCaption = TColor(clSystemColor or COLOR_GRADIENTINACTIVECAPTION);
  clMenuHighlight = TColor(clSystemColor or COLOR_MENUHILIGHT);
  clMenuBar = TColor(clSystemColor or COLOR_MENUBAR);

  clBlack = TColor($000000);
  clMaroon = TColor($000080);
  clGreen = TColor($008000);
  clOlive = TColor($008080);
  clNavy = TColor($800000);
  clPurple = TColor($800080);
  clTeal = TColor($808000);
  clGray = TColor($808080);
  clSilver = TColor($C0C0C0);
  clRed = TColor($0000FF);
  clLime = TColor($00FF00);
  clYellow = TColor($00FFFF);
  clBlue = TColor($FF0000);
  clFuchsia = TColor($FF00FF);
  clAqua = TColor($FFFF00);
  clLtGray = TColor($C0C0C0);
  clDkGray = TColor($808080);
  clWhite = TColor($FFFFFF);
  StandardColorsCount = 16;

  clMoneyGreen = TColor($C0DCC0);
  clSkyBlue = TColor($F0CAA6);
  clCream = TColor($F0FBFF);
  clMedGray = TColor($A4A0A0);
  ExtendedColorsCount = 4;

  clNone = TColor($1FFFFFFF);
  clDefault = TColor($20000000);

  { The following "cl" values come from the Web Named Color palette and
    are stored in the Windows COLORREF byte order x00bbggrr }
  clWebSnow = $FAFAFF;
  clWebFloralWhite = $F0FAFF;
  clWebLavenderBlush = $F5F0FF;
  clWebOldLace = $E6F5FD;
  clWebIvory = $F0FFFF;
  clWebCornSilk = $DCF8FF;
  clWebBeige = $DCF5F5;
  clWebAntiqueWhite = $D7EBFA;
  clWebWheat = $B3DEF5;
  clWebAliceBlue = $FFF8F0;
  clWebGhostWhite = $FFF8F8;
  clWebLavender = $FAE6E6;
  clWebSeashell = $EEF5FF;
  clWebLightYellow = $E0FFFF;
  clWebPapayaWhip = $D5EFFF;
  clWebNavajoWhite = $ADDEFF;
  clWebMoccasin = $B5E4FF;
  clWebBurlywood = $87B8DE;
  clWebAzure = $FFFFF0;
  clWebMintcream = $FAFFF5;
  clWebHoneydew = $F0FFF0;
  clWebLinen = $E6F0FA;
  clWebLemonChiffon = $CDFAFF;
  clWebBlanchedAlmond = $CDEBFF;
  clWebBisque = $C4E4FF;
  clWebPeachPuff = $B9DAFF;
  clWebTan = $8CB4D2;
  // yellows/reds yellow -> rosybrown
  clWebYellow = $00FFFF;
  clWebDarkOrange = $008CFF;
  clWebRed = $0000FF;
  clWebDarkRed = $00008B;
  clWebMaroon = $000080;
  clWebIndianRed = $5C5CCD;
  clWebSalmon = $7280FA;
  clWebCoral = $507FFF;
  clWebGold = $00D7FF;
  clWebTomato = $4763FF;
  clWebCrimson = $3C14DC;
  clWebBrown = $2A2AA5;
  clWebChocolate = $1E69D2;
  clWebSandyBrown = $60A4F4;
  clWebLightSalmon = $7AA0FF;
  clWebLightCoral = $8080F0;
  clWebOrange = $00A5FF;
  clWebOrangeRed = $0045FF;
  clWebFirebrick = $2222B2;
  clWebSaddleBrown = $13458B;
  clWebSienna = $2D52A0;
  clWebPeru = $3F85CD;
  clWebDarkSalmon = $7A96E9;
  clWebRosyBrown = $8F8FBC;
  // greens palegoldenrod -> darkseagreen
  clWebPaleGoldenrod = $AAE8EE;
  clWebLightGoldenrodYellow = $D2FAFA;
  clWebOlive = $008080;
  clWebForestGreen = $228B22;
  clWebGreenYellow = $2FFFAD;
  clWebChartreuse = $00FF7F;
  clWebLightGreen = $90EE90;
  clWebAquamarine = $D4FF7F;
  clWebSeaGreen = $578B2E;
  clWebGoldenRod = $20A5DA;
  clWebKhaki = $8CE6F0;
  clWebOliveDrab = $238E6B;
  clWebGreen = $008000;
  clWebYellowGreen = $32CD9A;
  clWebLawnGreen = $00FC7C;
  clWebPaleGreen = $98FB98;
  clWebMediumAquamarine = $AACD66;
  clWebMediumSeaGreen = $71B33C;
  clWebDarkGoldenRod = $0B86B8;
  clWebDarkKhaki = $6BB7BD;
  clWebDarkOliveGreen = $2F6B55;
  clWebDarkgreen = $006400;
  clWebLimeGreen = $32CD32;
  clWebLime = $00FF00;
  clWebSpringGreen = $7FFF00;
  clWebMediumSpringGreen = $9AFA00;
  clWebDarkSeaGreen = $8FBC8F;
  // greens/blues lightseagreen -> navy
  clWebLightSeaGreen = $AAB220;
  clWebPaleTurquoise = $EEEEAF;
  clWebLightCyan = $FFFFE0;
  clWebLightBlue = $E6D8AD;
  clWebLightSkyBlue = $FACE87;
  clWebCornFlowerBlue = $ED9564;
  clWebDarkBlue = $8B0000;
  clWebIndigo = $82004B;
  clWebMediumTurquoise = $CCD148;
  clWebTurquoise = $D0E040;
  clWebCyan = $FFFF00; //   clWebAqua
  clWebAqua = $FFFF00;
  clWebPowderBlue = $E6E0B0;
  clWebSkyBlue = $EBCE87;
  clWebRoyalBlue = $E16941;
  clWebMediumBlue = $CD0000;
  clWebMidnightBlue = $701919;
  clWebDarkTurquoise = $D1CE00;
  clWebCadetBlue = $A09E5F;
  clWebDarkCyan = $8B8B00;
  clWebTeal = $808000;
  clWebDeepskyBlue = $FFBF00;
  clWebDodgerBlue = $FF901E;
  clWebBlue = $FF0000;
  clWebNavy = $800000;
  // violets/pinks darkviolet -> pink
  clWebDarkViolet = $D30094;
  clWebDarkOrchid = $CC3299;
  clWebMagenta = $FF00FF; //   clWebFuchsia
  clWebFuchsia = $FF00FF;
  clWebDarkMagenta = $8B008B;
  clWebMediumVioletRed = $8515C7;
  clWebPaleVioletRed = $9370DB;
  clWebBlueViolet = $E22B8A;
  clWebMediumOrchid = $D355BA;
  clWebMediumPurple = $DB7093;
  clWebPurple = $800080;
  clWebDeepPink = $9314FF;
  clWebLightPink = $C1B6FF;
  clWebViolet = $EE82EE;
  clWebOrchid = $D670DA;
  clWebPlum = $DDA0DD;
  clWebThistle = $D8BFD8;
  clWebHotPink = $B469FF;
  clWebPink = $CBC0FF;
  // blue/gray/black lightsteelblue -> black
  clWebLightSteelBlue = $DEC4B0;
  clWebMediumSlateBlue = $EE687B;
  clWebLightSlateGray = $998877;
  clWebWhite = $FFFFFF;
  clWebLightgrey = $D3D3D3;
  clWebGray = $808080;
  clWebSteelBlue = $B48246;
  clWebSlateBlue = $CD5A6A;
  clWebSlateGray = $908070;
  clWebWhiteSmoke = $F5F5F5;
  clWebSilver = $C0C0C0;
  clWebDimGray = $696969;
  clWebMistyRose = $E1E4FF;
  clWebDarkSlateBlue = $8B3D48;
  clWebDarkSlategray = $4F4F2F;
  clWebGainsboro = $DCDCDC;
  clWebDarkGray = $A9A9A9;
  clWebBlack = $000000;
  WebColorsCount = 140;  { Two of which are duplicates Aqua/Cyan Fuchsia/Magenta }

const
  cmBlackness = BLACKNESS;
  cmDstInvert = DSTINVERT;
  cmMergeCopy = MERGECOPY;
  cmMergePaint = MERGEPAINT;
  cmNotSrcCopy = NOTSRCCOPY;
  cmNotSrcErase = NOTSRCERASE;
  cmPatCopy = PATCOPY;
  cmPatInvert = PATINVERT;
  cmPatPaint = PATPAINT;
  cmSrcAnd = SRCAND;
  cmSrcCopy = SRCCOPY;
  cmSrcErase = SRCERASE;
  cmSrcInvert = SRCINVERT;
  cmSrcPaint = SRCPAINT;
  cmWhiteness = WHITENESS;

  { Icon and cursor types }
  rc3_StockIcon = 0;
  rc3_Icon = 1;
  rc3_Cursor = 2;

type
//  PCursorOrIcon = ^TCursorOrIcon;
  TCursorOrIcon = packed record
    Reserved: Word;
    wType: Word;
    Count: Word;
  end;

//  PIconRec = ^TIconRec;
  TIconRec = packed record
    Width: Byte;
    Height: Byte;
    Colors: Word;
    Reserved1: Word;
    Reserved2: Word;
    DIBSize: Longint;
    DIBOffset: Longint;
  end;

  HMETAFILE = THandle;
  HENHMETAFILE = THandle;

  EInvalidGraphic = class(Exception);
  EInvalidGraphicOperation = class(Exception);

  TGraphic = class;
  TBitmap = class;
  TIcon = class;
  TMetafile = class;

  TResData = class
  protected
    function GetHandle: THandle; virtual; abstract;
    procedure ClearHandle; virtual; abstract;
  strict protected
    procedure Finalize; override;
  public
    destructor Destroy; override;
    function Clone: TResData;
    property Handle: THandle read GetHandle;
  end;

  TFontPitch = (fpDefault, fpVariable, fpFixed);
  TFontName = type string;
  TFontCharset = 0..255;

  { Changes to the following types should be reflected in the $HPPEMIT directives. }

  TFontDataName = string;
  TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  TFontStyles = set of TFontStyle;

  TFontData = class(TResData)
  protected
    procedure ClearHandle; override;
    function GetHandle: THandle; override;
  public
    FontHandle: HFont;
    Height: Integer;
    Orientation: Integer;
    Pitch: TFontPitch;
    Style: TFontStyles;
    Charset: TFontCharset;
    Name: TFontDataName;
    function Clone: TFontData;
    function GetHashCode: Integer; override;
    function Equals(Value: TObject): Boolean; override;
  end;

  TPaletteColoredData = class(TResData)
  protected
    function GetColor: TColor; virtual; abstract;
  public
    property Color: TColor read GetColor;
  end;

  TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
    psInsideFrame);
  TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
    pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
    pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);

  TPenData = class(TPaletteColoredData)
  protected
    function GetColor: TColor; override;
    procedure ClearHandle; override;
  public
    PenHandle: HPen;
    Color: TColor;
    Width: Integer;
    Style: TPenStyle;
    function Clone: TPenData;
    function GetHandle: THandle; override;
    function GetHashCode: Integer; override;
    function Equals(Value: TObject): Boolean; override;
  end;

  TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
    bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);

  TBrushData = class(TPaletteColoredData)
  protected
    function GetColor: TColor; override;
    procedure ClearHandle; override;
  public
    BrushHandle: HBrush;
    Color: TColor;
    Bitmap: TBitmap;
    Style: TBrushStyle;
    function Clone: TBrushData;
    function GetHandle: THandle; override;
    function GetHashCode: Integer; override;
    function Equals(Value: TObject): Boolean; override;
  end;

  TGraphicsObject = class(TPersistent)
  private
    FOnChange: TNotifyEvent;
    FResource: TResData;
    FOwnerLock: TObject;
  protected
    procedure Changed; dynamic;
    procedure Lock;
    procedure Unlock;
  public
    function HandleAllocated: Boolean;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OwnerLock: TObject read FOwnerLock write FOwnerLock;
  end;

  IChangeNotifier = interface
    ['{1FB62321-44A7-11D0-9E93-0020AF3D82DA}']
    procedure Changed;
  end;

  TFont = class(TGraphicsObject)
  private
    FColor: TColor;
    FPixelsPerInch: Integer;
    FNotify: IChangeNotifier;
    function GetFontData: TFontData;
    procedure SetFontData(FontData: TFontData);
  protected
    procedure Changed; override;
    function GetHandle: HFont;
    function GetHeight: Integer;
    function GetName: TFontName;
    function GetOrientation: Integer;
    function GetPitch: TFontPitch;
    function GetSize: Integer;
    function GetStyle: TFontStyles;
    function GetCharset: TFontCharset;
    procedure SetColor(const Value: TColor);
    procedure SetHandle(const Value: HFont);
    procedure SetHeight(const Value: Integer);
    procedure SetOrientation(const Value: Integer);
    procedure SetName(const Value: TFontName);
    procedure SetPitch(const Value: TFontPitch);
    procedure SetSize(const Value: Integer);
    procedure SetStyle(const Value: TFontStyles);
    procedure SetCharset(const Value: TFontCharset);
  public
    constructor Create; 
    procedure Assign(Source: TPersistent); override;
    property FontAdapter: IChangeNotifier read FNotify write FNotify;
    property Handle: HFont read GetHandle write SetHandle;
    property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  published
    property Charset: TFontCharset read GetCharset write SetCharset;
    property Color: TColor read FColor write SetColor;
    property Height: Integer read GetHeight write SetHeight;
    property Name: TFontName read GetName write SetName;
    property Orientation: Integer read GetOrientation write SetOrientation default 0;
    property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
    property Size: Integer read GetSize write SetSize stored False;
    property Style: TFontStyles read GetStyle write SetStyle;
  end;

  TPen = class(TGraphicsObject)
  private
    FMode: TPenMode;
    function GetPenData: TPenData;
    procedure SetPenData(PenData: TPenData);
  protected
    function GetColor: TColor;
    procedure SetColor(Value: TColor);
    function GetHandle: HPen;
    procedure SetHandle(Value: HPen);
    procedure SetMode(Value: TPenMode);
    function GetStyle: TPenStyle;
    procedure SetStyle(Value: TPenStyle);
    function GetWidth: Integer;
    procedure SetWidth(Value: Integer);
  public
    constructor Create; 
    procedure Assign(Source: TPersistent); override;
    property Handle: HPen read GetHandle write SetHandle;
  published
    property Color: TColor read GetColor write SetColor default clBlack;
    property Mode: TPenMode read FMode write SetMode default pmCopy;
    property Style: TPenStyle read GetStyle write SetStyle default psSolid;
    property Width: Integer read GetWidth write SetWidth default 1;
  end;

  TBrush = class(TGraphicsObject)
  private
    function GetBrushData: TBrushData;
    procedure SetBrushData(BrushData: TBrushData);
  protected
    function GetBitmap: TBitmap;
    procedure SetBitmap(Value: TBitmap);
    function GetColor: TColor;
    procedure SetColor(Value: TColor);
    function GetHandle: HBrush;
    procedure SetHandle(Value: HBrush);
    function GetStyle: TBrushStyle;
    procedure SetStyle(Value: TBrushStyle);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    property Bitmap: TBitmap read GetBitmap write SetBitmap;
    property Handle: HBrush read GetHandle write SetHandle;
  published
    property Color: TColor read GetColor write SetColor default clWhite;
    property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  end;

  TFontRecall = class(TRecall)
  public
    constructor Create(AFont: TFont);
  end;

  TPenRecall = class(TRecall)
  public
    constructor Create(APen: TPen);
  end;

  TBrushRecall = class(TRecall)
  public
    constructor Create(ABrush: TBrush);
  end;

  TResHandleWrapper = class
  private
    FHandle: THandle;
  strict protected
    procedure Finalize; override;
  public
    destructor Destroy; override;
    property Handle: THandle read FHandle write FHandle;
  end;

  TFillStyle = (fsSurface, fsBorder);
  TFillMode = (fmAlternate, fmWinding);

  TCopyMode = Longint;

  TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  TCanvasState = set of TCanvasStates;
  TCanvasOrientation = (coLeftToRight, coRightToLeft);
  TTextFormats = (tfBottom, tfCalcRect, tfCenter, tfEditControl, tfEndEllipsis,
    tfPathEllipsis, tfExpandTabs, tfExternalLeading, tfLeft, tfModifyString,
    tfNoClip, tfNoPrefix, tfRight, tfRtlReading, tfSingleLine, tfTop,
    tfVerticalCenter, tfWordBreak);
  TTextFormat = set of TTextFormats;

  TCanvas = class(TPersistent)
  private
    FHandle: HDC;
    State: TCanvasState;
    FFont: TFont;
    FPen: TPen;
    FBrush: TBrush;
    FPenPos: TPoint;
    FCopyMode: TCopyMode;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    FTextFlags: Longint;
    procedure CreateBrush;
    procedure CreateFont;
    procedure CreatePen;
    procedure BrushChanged(ABrush: TObject);
    procedure DeselectHandles;
    function GetCanvasOrientation: TCanvasOrientation;
    function GetClipRect: TRect;
    function GetHandle: HDC;
    function GetPenPos: TPoint;
    function GetPixel(X, Y: Integer): TColor;
    procedure FontChanged(AFont: TObject);
    procedure PenChanged(APen: TObject);
    procedure SetBrush(Value: TBrush);
    procedure SetFont(Value: TFont);
    procedure SetHandle(Value: HDC);
    procedure SetPen(Value: TPen);
    procedure SetPenPos(Value: TPoint);
    procedure SetPixel(X, Y: Integer; Value: TColor);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    procedure CreateHandle; virtual;
    procedure RequiredState(ReqState: TCanvasState);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
      const Source: TRect; Color: TColor);
    procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
      const Source: TRect);
    procedure Draw(X, Y: Integer; Graphic: TGraphic);
    procedure DrawFocusRect(const Rect: TRect);
    procedure Ellipse(X1, Y1, X2, Y2: Integer); overload;
    procedure Ellipse(const Rect: TRect); overload;
    procedure FillRect(const Rect: TRect);
    procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
    procedure FrameRect(const Rect: TRect);
    function HandleAllocated: Boolean;
    procedure LineTo(X, Y: Integer);
    procedure Lock;
    procedure MoveTo(X, Y: Integer);
    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
    procedure Polygon(const Points: array of TPoint);
    procedure Polyline(const Points: array of TPoint);
    procedure PolyBezier(const Points: array of TPoint);
    procedure PolyBezierTo(const Points: array of TPoint);
    procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
    procedure Rectangle(const Rect: TRect); overload;
    procedure Refresh;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
    procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
    function TextExtent(const Text: string): TSize;
    function TextHeight(const Text: string): Integer;
    procedure TextOut(X, Y: Integer; const Text: string);
    procedure TextRect(var Rect: TRect; var Text: string; TextFormat: TTextFormat = []); overload;
    procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string); overload;
    function TextWidth(const Text: string): Integer;
    function TryLock: Boolean;
    procedure Unlock;
    property ClipRect: TRect read GetClipRect;
    property Handle: HDC read GetHandle write SetHandle;
    property CanvasOrientation: TCanvasOrientation read GetCanvasOrientation;
    property PenPos: TPoint read GetPenPos write SetPenPos;
    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
    property TextFlags: Longint read FTextFlags write FTextFlags;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  published
    property Brush: TBrush read FBrush write SetBrush;
    property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
    property Font: TFont read FFont write SetFont;
    property Pen: TPen read FPen write SetPen;
  end;

  { TProgressEvent is a generic progress notification event which may be
        used by TGraphic classes with computationally intensive (slow)
        operations, such as loading, storing, or transforming image data.
    Event params:
      Stage - Indicates whether this call to the OnProgress event is to
        prepare for, process, or clean up after a graphic operation.  If
        OnProgress is called at all, the first call for a graphic operation
        will be with Stage = psStarting, to allow the OnProgress event handler
        to allocate whatever resources it needs to process subsequent progress
        notifications.  After Stage = psStarting, you are guaranteed that
        OnProgress will be called again with Stage = psEnding to allow you
        to free those resources, even if the graphic operation is aborted by
        an exception.  Zero or more calls to OnProgress with Stage = psRunning
        may occur between the psStarting and psEnding calls.
      PercentDone - The ratio of work done to work remaining, on a scale of
        0 to 100.  Values may repeat or even regress (get smaller) in
        successive calls.  PercentDone is usually only a guess, and the
        guess may be dramatically altered as new information is discovered
        in decoding the image.
      RedrawNow - Indicates whether the graphic can be/should be redrawn
        immediately.  Useful for showing successive approximations of
        an image as data is available instead of waiting for all the data
        to arrive before drawing anything.  Since there is no message loop
        activity during graphic operations, you should call Update to force
        a control to be redrawn immediately in the OnProgress event handler.
        Redrawing a graphic when RedrawNow = False could corrupt the image
        and/or cause exceptions.
      Rect - Area of image that has changed and needs to be redrawn.
      Msg - Optional text describing in one or two words what the graphic
        class is currently working on.  Ex:  "Loading" "Storing"
        "Reducing colors".  The Msg string can also be empty.
        Msg strings should be resourced for translation,  should not
        contain trailing periods, and should be used only for
        display purposes.  (do not: if Msg = 'Loading' then...)
  }

  TProgressStage = (psStarting, psRunning, psEnding);
  TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
    PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;

  { The TGraphic class is a abstract base class for dealing with graphic images
    such as metafile, bitmaps, icons, and other image formats.
      LoadFromFile - Read the graphic from the file system.  The old contents of
        the graphic are lost.  If the file is not of the right format, an
        exception will be generated.
      SaveToFile - Writes the graphic to disk in the file provided.
      LoadFromStream - Like LoadFromFile except source is a stream (e.g.
        TBlobStream).
      SaveToStream - stream analogue of SaveToFile.
      LoadFromClipboardFormat - Replaces the current image with the data
        provided.  If the TGraphic does not support that format it will generate
        an exception.
      SaveToClipboardFormats - Converts the image to a clipboard format.  If the
        image does not support being translated into a clipboard format it
        will generate an exception.
      Height - The native, unstretched, height of the graphic.
      Palette - Color palette of image.  Zero if graphic doesn't need/use palettes.
      Transparent - Image does not completely cover its rectangular area
      Width - The native, unstretched, width of the graphic.
      OnChange - Called whenever the graphic changes
      PaletteModified - Indicates in OnChange whether color palette has changed.
        Stays true until whoever's responsible for realizing this new palette
        (ex: TImage) sets it to False.
      OnProgress - Generic progress indicator event. Propagates out to TPicture
        and TImage OnProgress events.}

  TGraphic = class(TInterfacedPersistent, IStreamPersist)
  private
    FOnChange: TNotifyEvent;
    FOnProgress: TProgressEvent;
    FModified: Boolean;
    FTransparent: Boolean;
    FPaletteModified: Boolean;
    procedure SetModified(Value: Boolean);
  protected
    procedure Changed(Sender: TObject); virtual;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
    function Equals(Graphic: TGraphic): Boolean; virtual;
    function GetEmpty: Boolean; virtual; abstract;
    function GetHeight: Integer; virtual; abstract;
    function GetPalette: HPALETTE; virtual;
    function GetTransparent: Boolean; virtual;
    function GetWidth: Integer; virtual; abstract;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
    procedure ReadData(Stream: TStream); virtual;
    procedure SetHeight(Value: Integer); virtual; abstract;
    procedure SetPalette(Value: HPALETTE); virtual;
    procedure SetTransparent(Value: Boolean); virtual;
    procedure SetWidth(Value: Integer); virtual; abstract;
    procedure WriteData(Stream: TStream); virtual;
  public
    constructor Create; virtual;
    procedure LoadFromFile(const Filename: string); virtual;
    procedure SaveToFile(const Filename: string); virtual;
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); virtual; abstract;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); virtual; abstract;
    property Empty: Boolean read GetEmpty;
    property Height: Integer read GetHeight write SetHeight;
    property Modified: Boolean read FModified write SetModified;
    property Palette: HPALETTE read GetPalette write SetPalette; 
    property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
    property Transparent: Boolean read GetTransparent write SetTransparent;
    property Width: Integer read GetWidth write SetWidth;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  end;

  TGraphicClass = class of TGraphic;

  { TPicture }
  { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
    graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
    polymorphic. For example, if the TPicture is holding an Icon, you can
    LoadFromFile a bitmap file, where if the class was TIcon you could only read
    .ICO files.
      LoadFromFile - Reads a picture from disk.  The TGraphic class created
        determined by the file extension of the file.  If the file extension is
        not recognized an exception is generated.
      SaveToFile - Writes the picture to disk.
      LoadFromClipboardFormat - Reads the picture from the handle provided in
        the given clipboard format.  If the format is not supported, an
        exception is generated.
      SaveToClipboardFormats - Allocates a global handle and writes the picture
        in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE
        for metafiles, etc.).  Formats will contain the formats written.
        Returns the number of clipboard items written to the array pointed to
        by Formats and Datas or would be written if either Formats or Datas are
        nil.
      SupportsClipboardFormat - Returns true if the given clipboard format
        is supported by LoadFromClipboardFormat.
      Assign - Copys the contents of the given TPicture.  Used most often in
        the implementation of TPicture properties.
      RegisterFileFormat - Register a new TGraphic class for use in
        LoadFromFile.
      RegisterClipboardFormat - Registers a new TGraphic class for use in
        LoadFromClipboardFormat.
      UnRegisterGraphicClass - Removes all references to the specified TGraphic
        class and all its descendents from the file format and clipboard format
        internal lists.
      Height - The native, unstretched, height of the picture.
      Width - The native, unstretched, width of the picture.
      Graphic - The TGraphic object contained by the TPicture
      Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
        contents are thrown away and a blank bitmap is returned.
      Icon - Returns an icon.  If the contents is not already an icon, the
        contents are thrown away and a blank icon is returned.
      Metafile - Returns a metafile.  If the contents is not already a metafile,
        the contents are thrown away and a blank metafile is returned. }

  TPicture = class(TInterfacedPersistent, IStreamPersist)
  private
    FGraphic: TGraphic;
    FOnChange: TNotifyEvent;
    FNotify: IChangeNotifier;
    FOnProgress: TProgressEvent;
    procedure ForceType(GraphicType: TGraphicClass);
    function GetBitmap: TBitmap;
    function GetHeight: Integer;
    function GetIcon: TIcon;
    function GetMetafile: TMetafile;
    function GetWidth: Integer;
    procedure ReadData(Stream: TStream);
    procedure SetBitmap(Value: TBitmap);
    procedure SetGraphic(Value: TGraphic);
    procedure SetIcon(Value: TIcon);
    procedure SetMetafile(Value: TMetafile);
    procedure WriteData(Stream: TStream);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure Changed(Sender: TObject); dynamic;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromFile(const Filename: string);
    procedure SaveToFile(const Filename: string);
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE);
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE);
    class function SupportsClipboardFormat(AFormat: Word): Boolean;
    procedure Assign(Source: TPersistent); override;
    class procedure RegisterFileFormat(const AExtension, ADescription: string;
      AGraphicClass: TGraphicClass);
    class procedure RegisterFileFormatRes(const AExtension: String;
      ADescriptionResID: string; AGraphicClass: TGraphicClass);
    class procedure RegisterClipboardFormat(AFormat: Word;
      AGraphicClass: TGraphicClass);
    class procedure UnregisterGraphicClass(AClass: TGraphicClass);
    property Bitmap: TBitmap read GetBitmap write SetBitmap;
    property Graphic: TGraphic read FGraphic write SetGraphic;
    property PictureAdapter: IChangeNotifier read FNotify write FNotify;
    property Height: Integer read GetHeight;
    property Icon: TIcon read GetIcon write SetIcon;
    property Metafile: TMetafile read GetMetafile write SetMetafile;
    property Width: Integer read GetWidth;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  end;

  { TMetafile }
  { TMetafile is an encapsulation of the Win32 Enhanced metafile.
      Handle - The metafile handle.
      Enhanced - determines how the metafile will be stored on disk.
        Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
        Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
        The in-memory format is always EMF.  WMF has very limited capabilities;
        storing as WMF will lose information that would be retained by EMF.
        This property is set to match the metafile type when loaded from a
        stream or file.  This maintains form file compatibility with 16 bit
        Delphi (If loaded as WMF, then save as WMF).
      Inch - The units per inch assumed by a WMF metafile.  Used to alter
        scale when writing as WMF, but otherwise this property is obsolete.
        Enhanced metafiles maintain complete scale information internally.
      MMWidth,
      MMHeight: Width and Height in 0.01 millimeter units, the native
        scale used by enhanced metafiles.  The Width and Height properties
        are always in screen device pixel units; you can avoid loss of
        precision in converting between device pixels and mm by setting
        or reading the dimentions in mm with these two properties.
      CreatedBy - Optional name of the author or application used to create
        the metafile.
      Description - Optional text description of the metafile.
      You can set the CreatedBy and Description of a new metafile by calling
      TMetafileCanvas.CreateWithComment.

    TMetafileCanvas
      To create a metafile image from scratch, you must draw the image in
      a metafile canvas.  When the canvas is destroyed, it transfers the
      image into the metafile object provided to the canvas constructor.
      After the image is drawn on the canvas and the canvas is destroyed,
      the image is 'playable' in the metafile object.  Like this:

      MyMetafile := TMetafile.Create;
      MyMetafile.Width := 200;
      MyMetafile.Height := 200;
      with TMetafileCanvas.Create(MyMetafile, 0) do
      try
        Brush.Color := clRed;
        Ellipse(0,0,100,100);
        ...
      finally
        Free;
      end;
      Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle  *)

      To add to an existing metafile image, create a metafile canvas
      and play the source metafile into the metafile canvas.  Like this:

      (* continued from previous example, so MyMetafile contains an image *)
      with TMetafileCanvas.Create(MyMetafile, 0) do
      try
        Draw(0,0,MyMetafile);
        Brush.Color := clBlue;
        Ellipse(100,100,200,200);
        ...
      finally
        Free;
      end;
      Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle and 1 blue circle *)
  }

  TMetafileDC = class(TResHandleWrapper)
  strict protected
    procedure Finalize; override;
  end;

  TMetafileCanvas = class(TCanvas)
  private
    FMetafile: TMetafile;
    FMetafileDC: TMetafileDC;
  public
    constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
    constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
      const CreatedBy, Description: String);
    destructor Destroy; override;
  end;

  TSharedImage = class
  private
    FRefCount: Integer;
  strict protected
    procedure Finalize; override;
  protected
    procedure Reference;
    procedure Release;
    procedure FreeHandle; virtual; abstract;
    property RefCount: Integer read FRefCount;
  public
    destructor Destroy; override;
  end;

  TMetafileImage = class(TSharedImage)
  private
    FHandle: HENHMETAFILE;
    FWidth: Integer;      // FWidth and FHeight are in 0.01 mm logical pixels
    FHeight: Integer;     // These are converted to device pixels in TMetafile
    FPalette: HPALETTE;
    FInch: Word;          // Used only when writing WMF files.
    FTempWidth: Integer;  // FTempWidth and FTempHeight are in device pixels
    FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TMetafile = class(TGraphic)
  private
    FImage: TMetafileImage;
    FEnhanced: Boolean;
    function GetAuthor: String;
    function GetDesc: String;
    function GetHandle: HENHMETAFILE;
    function GetInch: Word;
    function GetMMHeight: Integer;
    function GetMMWidth: Integer;
    procedure NewImage;
    procedure SetHandle(Value: HENHMETAFILE);
    procedure SetInch(Value: Word);
    procedure SetMMHeight(Value: Integer);
    procedure SetMMWidth(Value: Integer);
    procedure UniqueImage;
  protected
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetPalette: HPALETTE; override;
    function GetWidth: Integer; override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure ReadData(Stream: TStream); override;
    procedure ReadEMFStream(Stream: TStream);
    procedure ReadWMFStream(Stream: TStream; Length: Longint);
    procedure SetHeight(Value: Integer); override;
    procedure SetTransparent(Value: Boolean); override;
    procedure SetWidth(Value: Integer); override;
    function  TestEMF(Stream: TStream): Boolean;
    procedure WriteData(Stream: TStream); override;
    procedure WriteEMFStream(Stream: TStream);
    procedure WriteWMFStream(Stream: TStream);
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear;
    function HandleAllocated: Boolean;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToFile(const Filename: String); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    procedure Assign(Source: TPersistent); override;
    function ReleaseHandle: HENHMETAFILE;
    property CreatedBy: String read GetAuthor;
    property Description: String read GetDesc;
    property Enhanced: Boolean read FEnhanced write FEnhanced default True;
    property Handle: HENHMETAFILE read GetHandle write SetHandle;
    property MMWidth: Integer read GetMMWidth write SetMMWidth;
    property MMHeight: Integer read GetMMHeight write SetMMHeight;
    property Inch: Word read GetInch write SetInch;
  end;

  { TBitmap }
  { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
    the palette realizing automatically as well as having a Canvas to allow
    modifications to the image.  Creating copies of a TBitmap is very fast
    since the handle is copied not the image.  If the image is modified, and
    the handle is shared by more than one TBitmap object, the image is copied
    before the modification is performed (i.e. copy on write).
      Canvas - Allows drawing on the bitmap.
      Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
        directly should be avoided since it causes the HBITMAP to be copied if
        more than one TBitmap share the handle.
      Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
        directly should be avoided since it causes the HPALETTE to be copied if
        more than one TBitmap share the handle.
      Monochrome - True if the bitmap is a monochrome bitmap }

  TImageFormat = System.Drawing.Imaging.ImageFormat;

  TBitmapImage = class(TSharedImage)
  private
    FHandle: HBITMAP;     // DDB or DIB handle, used for drawing
    FMaskHandle: HBITMAP; // DDB handle
    FPalette: HPALETTE;
    FDIBHandle: HBITMAP;  // DIB handle corresponding to TDIBSection
    FDIB: TDIBSection;
    FSaveStream: TMemoryStream; // Save original RLE stream until image is modified
    FHalftone: Boolean;   // FPalette is halftone; don't write to file
    FImageFormat: TImageFormat;
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TBitmapHandleType = (bmDIB, bmDDB);
  TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
  TTransparentMode = (tmAuto, tmFixed);

  TBitmap = class(TGraphic)
  private
    FImage: TBitmapImage;
    FCanvas: TCanvas;
    FIgnorePalette: Boolean;
    FMaskBitsValid: Boolean;
    FMaskValid: Boolean;
    FTransparentColor: TColor;
    FTransparentMode: TTransparentMode;
    procedure Changing(Sender: TObject);
    procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
    procedure DIBNeeded;
    procedure FreeContext;
    function GetCanvas: TCanvas;
    function GetHandle: HBITMAP; virtual;
    function GetHandleType: TBitmapHandleType;
    function GetImageFormat: TImageFormat;
    function GetMaskHandle: HBITMAP; virtual;
    function GetMonochrome: Boolean;
    function GetPixelFormat: TPixelFormat;
    function GetScanline(Row: Integer): IntPtr;
    function GetTransparentColor: TColor;
    procedure InternalLoadFromBitmap(Bitmap: System.Drawing.Bitmap;
      var BMHandle: HBITMAP; var APalette: HPALETTE; var DIB: TDIBSection);
    procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
      const NewDIB: TDIBSection; NewImageFormat: TImageFormat = nil;
      NewSaveStream: TMemoryStream = nil);
    procedure ReadStream(Stream: TStream; Size: Longint);
    procedure ReadDIB(Stream: TStream; ImageSize: LongWord);
    procedure SetHandle(Value: HBITMAP);
    procedure SetHandleType(Value: TBitmapHandleType); virtual;
    procedure SetImageFormat(Value: TImageFormat);
    procedure SetMaskHandle(Value: HBITMAP);
    procedure SetMonochrome(Value: Boolean);
    procedure SetPixelFormat(Value: TPixelFormat);
    procedure SetTransparentColor(Value: TColor);
    procedure SetTransparentMode(Value: TTransparentMode);
    function TransparentColorStored: Boolean;
    procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  protected
    procedure Changed(Sender: TObject); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetPalette: HPALETTE; override;
    function GetWidth: Integer; override;
    procedure HandleNeeded;
    procedure MaskHandleNeeded;
    procedure PaletteNeeded;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetPalette(Value: HPALETTE); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Dormant;
    procedure FreeImage;
    function HandleAllocated: Boolean;
    procedure LoadFromBitmap(Bitmap: System.Drawing.Bitmap);
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromResourceName(const ResName, BaseName: String;
      ResourceAssembly: Assembly; Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(const ResName, BaseName: String;
      ResourceAssembly: Assembly; ResourceSet: System.Type;
      Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(const ResName: String;
      AType: System.Type; Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(Instance: THandle;
      const ResName: String); overload; deprecated;
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer); deprecated;
    procedure LoadFromStream(Stream: TStream); override;
    procedure Mask(TransparentColor: TColor);
    function ReleaseHandle: HBITMAP;
    function ReleaseMaskHandle: HBITMAP;
    function ReleasePalette: HPALETTE;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    property Canvas: TCanvas read GetCanvas;
    property Handle: HBITMAP read GetHandle write SetHandle;
    property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
    property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
    property ImageFormat: TImageFormat read GetImageFormat write SetImageFormat;
    property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
    property Monochrome: Boolean read GetMonochrome write SetMonochrome;
    property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
    property ScanLine[Row: Integer]: IntPtr read GetScanLine;
    property TransparentColor: TColor read GetTransparentColor
      write SetTransparentColor stored TransparentColorStored;
    property TransparentMode: TTransparentMode read FTransparentMode
      write SetTransparentMode default tmAuto;
  end;
                                                                            
  { TIcon }
  { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
    so calling stretch draw is not meaningful.
      Handle - The HICON used by the TIcon. }

  TIconImage = class(TSharedImage)
  private
    FIcon: System.Drawing.Icon;
    FMemoryImage: TCustomMemoryStream;
    FSize: TPoint;
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TIcon = class(TGraphic)
  private
    FImage: TIconImage;
    FRequestedSize: TPoint;
    function GetHandle: HICON;
    procedure HandleNeeded;
    procedure ImageNeeded;
    procedure NewImage(NewIcon: System.Drawing.Icon; NewImage: TMemoryStream);
    procedure SetHandle(Value: HICON);
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetTransparent(Value: Boolean); override;
    procedure SetWidth(Value: Integer); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function HandleAllocated: Boolean;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromResourceName(const ResName, BaseName: String;
      ResourceAssembly: Assembly; Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(const ResName, BaseName: String;
      ResourceAssembly: Assembly; ResourceSet: System.Type;
      Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(const ResName: String;
      AType: System.Type; Culture: CultureInfo = nil); overload;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String); overload; deprecated;
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer); deprecated;
    procedure LoadFromStream(Stream: TStream); override;
    function ReleaseHandle: HICON;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    property Handle: HICON read GetHandle write SetHandle;
  end;

var
  DefFontData: TFontData;

var
  DDBsOnly: Boolean = False; // True = Load all BMPs as device bitmaps.
                             // Not recommended.

function GraphicFilter(GraphicClass: TGraphicClass): string;
function GraphicExtension(GraphicClass: TGraphicClass): string;
function GraphicFileMask(GraphicClass: TGraphicClass): string;

function ColorToRGB(Color: TColor): Longint;
function ColorToString(Color: TColor): string;
function StringToColor(const S: string): TColor;
procedure GetColorValues(Proc: TGetStrProc);
function ColorToIdent(Color: Longint; var Ident: string): Boolean;
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
procedure GetCharsetValues(Proc: TGetStrProc);
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;

procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  var ImageSize: DWORD);
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; BitmapInfo: IntPtr;
  var Bits: TBytes): Boolean;

function CopyPalette(Palette: HPALETTE): HPALETTE;

procedure PaletteChanged;
procedure FreeMemoryContexts;

function GetDefFontCharSet: TFontCharSet;

function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;

function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;

// Alignment must be a power of 2.  Color BMPs require DWORD alignment (32).
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;

implementation

{ Things left out
  ---------------
  Regions
  PatBlt
  Tabbed text
  Clipping regions
  Coordinate transformations
  Paths
  Beziers }

uses
  System.Text, System.Collections, System.Threading, System.Resources,
  System.IO, System.Runtime.InteropServices, System.Drawing.Drawing2D,
  WinUtils, Registry, StrUtils, Consts, Types;

const
  csAllValid = [csHandleValid..csBrushValid];

var
  ScreenLogPixels: Integer;
  StockPen: HPEN;
  StockBrush: HBRUSH;
  StockFont: HFONT;
  StockIcon: HICON;
  BitmapImageLock: TObject;
  SystemPalette16: TResHandleWrapper; // 16 color palette that maps to the system palette

procedure InternalDeletePalette(Pal: HPalette);
begin
  if (Pal <> 0) and Assigned(SystemPalette16) and (THandle(Pal) <> SystemPalette16.Handle) then
    DeleteObject(Pal);
end;

function CompareBuffer(P1, P2: TBytes; Size: Integer): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to Size - 1 do
  begin
    Result := P1[I] = P2[I];
    if not Result then Break;
  end;
end;

{ Resource managers }

type
  TResourceManager = class
  public
    Resources: TAtomicValues;
    constructor Create;
    function EnterResource(ResData: TResData): TResData;
    procedure Lock;
    procedure Unlock;
  end;

{ TResourceManager }

constructor TResourceManager.Create;
begin
  inherited Create;
  Resources := TAtomicValues.Create;
end;

procedure TResourceManager.Lock;
begin
  System.Threading.Monitor.Enter(Self);
end;

procedure TResourceManager.Unlock;
begin
  System.Threading.Monitor.Exit(Self);
end;

function TResourceManager.EnterResource(ResData: TResData): TResData;
begin
  Lock;
  try
    Result := Resources.GetAtomicValueOf(ResData) as TResData;
  finally
    Unlock;
  end;
end;

var
  FontManager: TResourceManager;
  PenManager: TResourceManager;
  BrushManager: TResourceManager;

{ TResData }

destructor TResData.Destroy;
begin
  DeleteObject(Handle);
  System.GC.SuppressFinalize(Self);
  inherited;
end;

function TResData.Clone: TResData;
begin
  Result := MemberwiseClone as TResData;
  Result.ClearHandle;
end;

procedure TResData.Finalize;
begin
  DeleteObject(Handle);
  inherited;
end;

{ TFontData }

procedure TFontData.ClearHandle;
begin
  FontHandle := 0;
end;

function TFontData.Clone: TFontData;
begin
  Result := inherited Clone as TFontData;
end;

function TFontData.Equals(Value: TObject): Boolean;
var
  V: TFontData;
begin
  if Value is TFontData then
  begin
    V := TFontData(Value);
    Result := (Height = V.Height) and (Style = V.Style) and
      (CharSet = V.CharSet) and (Name = V.Name) and
      (Orientation = V.Orientation);
  end
  else
    Result := False;
end;

function TFontData.GetHandle: THandle;
begin
  Result := THandle(FontHandle);
end;

function TFontData.GetHashCode: Integer;
begin
  Result :=
    Height xor
    (Ord(Pitch) shl 1) xor
    (Integer(Style) shl 2) xor
    (Ord(CharSet) shl 3) xor
    (Orientation shl 4) xor
    System.String(Name).GetHashCode;
end;

{ TPenData }

procedure TPenData.ClearHandle;
begin
  PenHandle := 0;
end;

function TPenData.Clone: TPenData;
begin
  Result := inherited Clone as TPenData;
end;

function TPenData.Equals(Value: TObject): Boolean;
var
  V: TPenData;
begin
  if Value is TPenData then
  begin
    V := TPenData(Value);
    Result := (Color = V.Color) and (Width = V.Width) and (Style = V.Style);
  end
  else
    Result := False;
end;

function TPenData.GetColor: TColor;
begin
  Result := Color;
end;

function TPenData.GetHandle: THandle;
begin
  Result := THandle(PenHandle);
end;

function TPenData.GetHashCode: Integer;
begin
  Result := Color xor (Width shl 1) xor (Ord(Style) shl 2);
end;

{ TBrushData }

procedure TBrushData.ClearHandle;
begin
  BrushHandle := 0;
end;

function TBrushData.Clone: TBrushData;
begin
  Result := inherited Clone as TBrushData;
end;

function TBrushData.Equals(Value: TObject): Boolean;
var
  V: TBrushData;
begin
  if Value is TBrushData then
  begin
    V := TBrushData(Value);
    Result := (Bitmap = V.Bitmap) and (Color = V.Color) and
      (Style = V.Style);
  end
  else
    Result := False;
end;

function TBrushData.GetColor: TColor;
begin
  Result := Color;
end;

function TBrushData.GetHandle: THandle;
begin
  Result := THandle(BrushHandle);
end;

function TBrushData.GetHashCode: Integer;
begin
  Result := 0;
  if Assigned(Bitmap) then
    Result := Bitmap.GetHashCode;
  Result := Result xor (Color shl 1) xor (Ord(Style) shl 2);
end;

var
  CanvasList: TThreadList;

procedure PaletteChanged;

  procedure ClearColor(ResMan: TResourceManager);
  var
    Enumerator: IEnumerator;
    Entry: DictionaryEntry;
    ResData: TPaletteColoredData;
  begin
    ResMan.Lock;
    try
      Enumerator := (ResMan.Resources as IEnumerable).GetEnumerator;
      while Enumerator.MoveNext do
      begin
        Entry := DictionaryEntry(Enumerator.Current);
        ResData := Entry.Value as TPaletteColoredData;
        if (ResData.Handle <> 0) and (ResData.Color < 0) then
        begin
          DeleteObject(ResData.Handle);
          ResData.ClearHandle;
        end;
      end;
    finally
      ResMan.Unlock;
    end;
  end;

var
  I,J: Integer;
begin
  { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  I := 0;
  with CanvasList.LockList do
  try
    while I < Count do
    begin
      with Items[I] as TCanvas do
      begin
        Lock;
        Inc(I);
        DeselectHandles;
      end;
    end;
    ClearColor(PenManager);
    ClearColor(BrushManager);
  finally
    for J := 0 to I-1 do  // Only unlock the canvases we actually locked
      TCanvas(Items[J]).Unlock;
    CanvasList.UnlockList;
  end;
end;

{ Color mapping routines }

const
  Colors: array[0..51] of TIdentMapEntry = (
    (Value: clBlack; Name: 'clBlack'),
    (Value: clMaroon; Name: 'clMaroon'),
    (Value: clGreen; Name: 'clGreen'),
    (Value: clOlive; Name: 'clOlive'),
    (Value: clNavy; Name: 'clNavy'),
    (Value: clPurple; Name: 'clPurple'),
    (Value: clTeal; Name: 'clTeal'),
    (Value: clGray; Name: 'clGray'),
    (Value: clSilver; Name: 'clSilver'),
    (Value: clRed; Name: 'clRed'),
    (Value: clLime; Name: 'clLime'),
    (Value: clYellow; Name: 'clYellow'),
    (Value: clBlue; Name: 'clBlue'),
    (Value: clFuchsia; Name: 'clFuchsia'),
    (Value: clAqua; Name: 'clAqua'),
    (Value: clWhite; Name: 'clWhite'),

    (Value: clMoneyGreen; Name: 'clMoneyGreen'),
    (Value: clSkyBlue; Name: 'clSkyBlue'),
    (Value: clCream; Name: 'clCream'),
    (Value: clMedGray; Name: 'clMedGray'),

    (Value: clActiveBorder; Name: 'clActiveBorder'),
    (Value: clActiveCaption; Name: 'clActiveCaption'),
    (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
    (Value: clBackground; Name: 'clBackground'),
    (Value: clBtnFace; Name: 'clBtnFace'),
    (Value: clBtnHighlight; Name: 'clBtnHighlight'),
    (Value: clBtnShadow; Name: 'clBtnShadow'),
    (Value: clBtnText; Name: 'clBtnText'),
    (Value: clCaptionText; Name: 'clCaptionText'),
    (Value: clDefault; Name: 'clDefault'),
    (Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'),
    (Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'),
    (Value: clGrayText; Name: 'clGrayText'),
    (Value: clHighlight; Name: 'clHighlight'),
    (Value: clHighlightText; Name: 'clHighlightText'),
    (Value: clHotLight; Name: 'clHotLight'),
    (Value: clInactiveBorder; Name: 'clInactiveBorder'),
    (Value: clInactiveCaption; Name: 'clInactiveCaption'),
    (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
    (Value: clInfoBk; Name: 'clInfoBk'),
    (Value: clInfoText; Name: 'clInfoText'),
    (Value: clMenu; Name: 'clMenu'),
    (Value: clMenuBar; Name: 'clMenuBar'),
    (Value: clMenuHighlight; Name: 'clMenuHighlight'),
    (Value: clMenuText; Name: 'clMenuText'),
    (Value: clNone; Name: 'clNone'),
    (Value: clScrollBar; Name: 'clScrollBar'),
    (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
    (Value: cl3DLight; Name: 'cl3DLight'),
    (Value: clWindow; Name: 'clWindow'),
    (Value: clWindowFrame; Name: 'clWindowFrame'),
    (Value: clWindowText; Name: 'clWindowText'));


function ColorToRGB(Color: TColor): Longint;
begin
  if Color < 0 then
    Result := GetSysColor(Color and $000000FF) else
    Result := Color;
end;

function ColorToString(Color: TColor): string;
begin
  if not ColorToIdent(Color, Result) then
    FmtStr(Result, '%s%0.8x', [HexDisplayPrefix, Integer(Color)]);
end;

function StringToColor(const S: string): TColor;
var
  LColor: LongInt;
begin
  if not IdentToColor(S, LColor) then
    Result := TColor(StrToInt(S))
  else
    Result := TColor(LColor);
end;

procedure GetColorValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
end;

function ColorToIdent(Color: Longint; var Ident: string): Boolean;
begin
  Result := IntToIdent(Color, Ident, Colors);
end;

function IdentToColor(const Ident: string; var Color: Longint): Boolean;
begin
  Result := IdentToInt(Ident, Color, Colors);
end;

{ TGraphicsObject }

procedure TGraphicsObject.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGraphicsObject.Lock;
begin
  if Assigned(FOwnerLock) then
    System.Threading.Monitor.Enter(FOwnerLock);
end;

procedure TGraphicsObject.Unlock;
begin
  if Assigned(FOwnerLock) then
    System.Threading.Monitor.Exit(FOwnerLock);
end;

function TGraphicsObject.HandleAllocated: Boolean;
begin
  Result := (FResource <> nil) and (FResource.Handle <> 0);
end;

{ TFont }

const
  FontCharsets: array[0..17] of TIdentMapEntry = (
    (Value: 0; Name: 'ANSI_CHARSET'),
    (Value: 1; Name: 'DEFAULT_CHARSET'),
    (Value: 2; Name: 'SYMBOL_CHARSET'),
    (Value: 77; Name: 'MAC_CHARSET'),
    (Value: 128; Name: 'SHIFTJIS_CHARSET'),
    (Value: 129; Name: 'HANGEUL_CHARSET'),
    (Value: 130; Name: 'JOHAB_CHARSET'),
    (Value: 134; Name: 'GB2312_CHARSET'),
    (Value: 136; Name: 'CHINESEBIG5_CHARSET'),
    (Value: 161; Name: 'GREEK_CHARSET'),
    (Value: 162; Name: 'TURKISH_CHARSET'),
    (Value: 177; Name: 'HEBREW_CHARSET'),
    (Value: 178; Name: 'ARABIC_CHARSET'),
    (Value: 186; Name: 'BALTIC_CHARSET'),
    (Value: 204; Name: 'RUSSIAN_CHARSET'),
    (Value: 222; Name: 'THAI_CHARSET'),
    (Value: 238; Name: 'EASTEUROPE_CHARSET'),
    (Value: 255; Name: 'OEM_CHARSET'));

procedure GetCharsetValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
end;

function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
begin
  Result := IntToIdent(Charset, Ident, FontCharsets);
end;

function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
begin
  Result := IdentToInt(Ident, CharSet, FontCharsets);
end;

function GetHandleFontData(Font: HFont): TFontData;
var
  LogFont: TLogFont;
begin
  Result := DefFontData.Clone;
  if Font <> 0 then
  begin
    if GetObject(Font, Marshal.SizeOf(TypeOf(TLogFont)), LogFont) <> 0 then
    with Result, LogFont do
    begin
      Height := lfHeight;
      if lfWeight >= FW_BOLD then
        Include(Style, fsBold);
      if lfItalic = 1 then
        Include(Style, fsItalic);
      if lfUnderline = 1 then
        Include(Style, fsUnderline);
      if lfStrikeOut = 1 then
        Include(Style, fsStrikeOut);
      Charset := TFontCharset(lfCharSet);
      Name := lfFaceName;
      case lfPitchAndFamily and $F of
        VARIABLE_PITCH: Pitch := fpVariable;
        FIXED_PITCH: Pitch := fpFixed;
      else
        Pitch := fpDefault;
      end;
      FontHandle := Font;
      Orientation := lfOrientation;
    end;
  end;
end;

constructor TFont.Create;
begin
  inherited Create;
  FResource := FontManager.EnterResource(DefFontData);
  FColor := clWindowText;
  FPixelsPerInch := ScreenLogPixels;
end;

procedure TFont.Changed;
begin
  inherited Changed;
  if FNotify <> nil then FNotify.Changed;
end;

procedure TFont.Assign(Source: TPersistent);
var
  FSource: TFont;
begin
  if Source is TFont then
  begin
    Lock;
    try
      FSource := Source as TFont;
      FSource.Lock;
      try
        SetFontData(FSource.FResource as TFontData);
        Color := FSource.Color;
        if PixelsPerInch <> FSource.PixelsPerInch then
          Size := FSource.Size;
      finally
        FSource.Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

function TFont.GetFontData: TFontData;
begin
  Result := (FResource as TFontData).Clone;
end;

procedure TFont.SetFontData(FontData: TFontData);
var
  NewData: TResData;
begin
  NewData := FontManager.EnterResource(FontData);
  if NewData <> FResource then
  begin
    FResource := NewData;
    Changed;
  end;
end;

procedure TFont.SetColor(const Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    Changed;
  end;
end;

function TFont.GetHandle: HFont;
var
  LogFont: TLogFont;
begin
  with FResource as TFontData do
  begin
    if Handle = 0 then
    begin
      FontManager.Lock;
      with LogFont do
      try
        if Handle = 0 then                           
        begin
          lfHeight := Height;
          lfWidth := 0; { have font mapper choose }
          lfEscapement := Orientation;
          lfOrientation := Orientation;
          if fsBold in Style then
            lfWeight := FW_BOLD
          else
            lfWeight := FW_NORMAL;
          lfItalic := Byte(fsItalic in Style);
          lfUnderline := Byte(fsUnderline in Style);
          lfStrikeOut := Byte(fsStrikeOut in Style);
          lfCharSet := Byte(Charset);
          if SameText(Name, 'Default') then // do not localize
            lfFaceName := DefFontData.Name
          else
            lfFaceName := Name;
          lfQuality := DEFAULT_QUALITY;
          { Everything else as default }
          { Only True Type fonts support the angles }
          if lfOrientation <> 0 then
            lfOutPrecision := OUT_TT_ONLY_PRECIS
          else
           lfOutPrecision := OUT_DEFAULT_PRECIS;
          lfClipPrecision := CLIP_DEFAULT_PRECIS;
          case Pitch of
            fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
            fpFixed: lfPitchAndFamily := FIXED_PITCH;
          else
            lfPitchAndFamily := DEFAULT_PITCH;
          end;
          FontHandle := CreateFontIndirect(LogFont);
        end;
      finally
        FontManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TFont.SetHandle(const Value: HFont);
var
  FontData: TFontData;
begin
  if Handle <> Value then
  begin
    FontData := GetHandleFontData(Value);
    SetFontData(FontData);
  end;
end;

function TFont.GetHeight: Integer;
begin
  Result := (FResource as TFontData).Height;
end;

procedure TFont.SetHeight(const Value: Integer);
var
  FontData: TFontData;
begin
  FontData := GetFontData;
  FontData.Height := Value;
  SetFontData(FontData);
end;

function TFont.GetName: TFontName;
begin
  Result := (FResource as TFontData).Name;
end;

procedure TFont.SetName(const Value: TFontName);
var
  FontData: TFontData;
begin
  if Value <> '' then
  begin
    FontData := GetFontData;
    FontData.Name := Value;
    SetFontData(FontData);
  end;
end;

function TFont.GetSize: Integer;
begin
  Result := -MulDiv(Height, 72, FPixelsPerInch);
end;

procedure TFont.SetSize(const Value: Integer);
begin
  Height := -MulDiv(Value, FPixelsPerInch, 72);
end;

function TFont.GetStyle: TFontStyles;
begin
  Result := (FResource as TFontData).Style;
end;

procedure TFont.SetStyle(const Value: TFontStyles);
var
  FontData: TFontData;
begin
  FontData := GetFontData;
  FontData.Style := Value;
  SetFontData(FontData);
end;

function TFont.GetPitch: TFontPitch;
begin
  Result := (FResource as TFontData).Pitch;
end;

procedure TFont.SetPitch(const Value: TFontPitch);
var
  FontData: TFontData;
begin
  FontData := GetFontData;
  FontData.Pitch := Value;
  SetFontData(FontData);
end;

function TFont.GetCharset: TFontCharset;
begin
  Result := (FResource as TFontData).Charset;
end;

procedure TFont.SetCharset(const Value: TFontCharset);
var
  FontData: TFontData;
begin
  FontData := GetFontData;
  FontData.Charset := Value;
  SetFontData(FontData);
end;

function TFont.GetOrientation: Integer;
begin
  Result := (FResource as TFontData).Orientation;
end;

procedure TFont.SetOrientation(const Value: Integer);
var
  FontData: TFontData;
begin
  FontData := GetFontData;
  FontData.Orientation := Value;
  SetFontData(FontData);
end;

{ TPen }

function DefPenData: TPenData;
begin
  Result := TPenData.Create;
  Result.Color := clBlack;
  Result.Width := 1;
  Result.Style := psSolid;
end;

constructor TPen.Create;
begin
  inherited Create;
  FResource := PenManager.EnterResource(DefPenData);
  FMode := pmCopy;
end;

procedure TPen.Assign(Source: TPersistent);
var
  LSource: TPen;
begin
  if Source is TPen then
  begin
    LSource := Source as TPen;
    Lock;
    try
      LSource.Lock;
      try
        SetPenData(LSource.FResource as TPenData);
        SetMode(LSource.FMode);
      finally
        LSource.Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

function TPen.GetPenData: TPenData;
begin
  Result := (FResource as TPenData).Clone;
end;

procedure TPen.SetPenData(PenData: TPenData);
var
  NewData: TResData;
begin
  Lock;
  try
    NewData := PenManager.EnterResource(PenData);
    if NewData <> FResource then
    begin
      FResource := NewData;
      Changed;
    end;
  finally
    Unlock;
  end;
end;

function TPen.GetColor: TColor;
begin
  Result := (FResource as TPenData).Color;
end;

procedure TPen.SetColor(Value: TColor);
var
  PenData: TPenData;
begin
  PenData := GetPenData;
  PenData.Color := Value;
  SetPenData(PenData);
end;

const
  PenStyles: array[TPenStyle] of Word = (PS_SOLID, PS_DASH, PS_DOT,
    PS_DASHDOT, PS_DASHDOTDOT, PS_NULL, PS_INSIDEFRAME);

function TPen.GetHandle: HPen;
var
  LogPen: TLogPen;
begin
  with FResource as TPenData do
  begin
    if PenHandle = 0 then
    begin
      PenManager.Lock;
      with LogPen do
      try
        if PenHandle = 0 then
        begin
          lopnStyle := PenStyles[Style];
          lopnWidth.X := Width;
          lopnColor := ColorToRGB(Color);
          PenHandle := CreatePenIndirect(LogPen);
        end;
      finally
        PenManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TPen.SetHandle(Value: HPen);
var
  PenData: TPenData;
begin
  if Value <> Handle then
  begin
    PenData := DefPenData;
    PenData.PenHandle := Value;
    SetPenData(PenData);
  end;
end;

procedure TPen.SetMode(Value: TPenMode);
begin
  if FMode <> Value then
  begin
    FMode := Value;
    Changed;
  end;
end;

function TPen.GetStyle: TPenStyle;
begin
  Result := (FResource as TPenData).Style;
end;

procedure TPen.SetStyle(Value: TPenStyle);
var
  PenData: TPenData;
begin
  PenData := GetPenData;
  PenData.Style := Value;
  SetPenData(PenData);
end;

function TPen.GetWidth: Integer;
begin
  Result := (FResource as TPenData).Width;
end;

procedure TPen.SetWidth(Value: Integer);
var
  PenData: TPenData;
begin
  if Value >= 0 then
  begin
    PenData := GetPenData;
    PenData.Width := Value;
    SetPenData(PenData);
  end;
end;

{ TBrush }

function DefBrushData: TBrushData;
begin
  Result := TBrushData.Create;
  Result.Color := clWhite;
  Result.Style := bsSolid;
end;

constructor TBrush.Create;
begin
  inherited Create;
  FResource := BrushManager.EnterResource(DefBrushData);
end;

procedure TBrush.Assign(Source: TPersistent);
var
  LSource: TBrush;
begin
  if Source is TBrush then
  begin
    Lock;
    try
      LSource := Source as TBrush;
      LSource.Lock;
      try
        SetBrushData(LSource.FResource as TBrushData);
      finally
        LSource.Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

function TBrush.GetBrushData: TBrushData;
begin
  Result := (FResource as TBrushData).Clone;
end;

procedure TBrush.SetBrushData(BrushData: TBrushData);
var
  NewData: TResData;
begin
  Lock;
  try
    NewData := BrushManager.EnterResource(BrushData);
    if NewData <> FResource then
    begin
      FResource := NewData;
      Changed;
    end;
  finally
    Unlock;
  end;
end;

function TBrush.GetBitmap: TBitmap;
begin
  Result := (FResource as TBrushData).Bitmap;
end;

procedure TBrush.SetBitmap(Value: TBitmap);
var
  BrushData: TBrushData;
begin
  BrushData := DefBrushData;
  BrushData.Bitmap := Value;
  SetBrushData(BrushData);
end;

function TBrush.GetColor: TColor;
begin
  Result := (FResource as TBrushData).Color;
end;

procedure TBrush.SetColor(Value: TColor);
var
  BrushData: TBrushData;
begin
  BrushData := GetBrushData;
  BrushData.Color := Value;
  if BrushData.Style = bsClear then
    BrushData.Style := bsSolid;
  SetBrushData(BrushData);
end;

function TBrush.GetHandle: HBrush;
var
  LogBrush: TLogBrush;
begin
  with FResource as TBrushData do
  begin
    if Handle = 0 then
    begin
      BrushManager.Lock;
      try
        if Handle = 0 then
        begin
          with LogBrush do
          begin
            if Bitmap <> nil then
            begin
              lbStyle := BS_PATTERN;
              Bitmap.HandleType := bmDDB;
              lbHatch := Bitmap.Handle;
            end else
            begin
              lbHatch := 0;
              case Style of
                bsSolid: lbStyle := BS_SOLID;
                bsClear: lbStyle := BS_HOLLOW;
              else
                lbStyle := BS_HATCHED;
                lbHatch := Ord(Style) - Ord(bsHorizontal);
              end;
            end;
            lbColor := ColorToRGB(Color);
          end;
          BrushHandle := CreateBrushIndirect(LogBrush);
        end;
      finally
        BrushManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TBrush.SetHandle(Value: HBrush);
var
  BrushData: TBrushData;
begin
  BrushData := DefBrushData;
  BrushData.BrushHandle := Value;
  SetBrushData(BrushData);
end;

function TBrush.GetStyle: TBrushStyle;
begin
  Result := (FResource as TBrushData).Style;
end;

procedure TBrush.SetStyle(Value: TBrushStyle);
var
  BrushData: TBrushData;
begin
  BrushData := GetBrushData;
  BrushData.Style := Value;
  if BrushData.Style = bsClear then BrushData.Color := clWhite;
  SetBrushData(BrushData);
end;

{ TFontRecall }

constructor TFontRecall.Create(AFont: TFont);
begin
  inherited Create(TFont.Create, AFont);
end;

{ TPenRecall }

constructor TPenRecall.Create(APen: TPen);
begin
  inherited Create(TPen.Create, APen);
end;

{ TBrushRecall }

constructor TBrushRecall.Create(ABrush: TBrush);
begin
  inherited Create(TBrush.Create, ABrush);
end;

{ TResHandleWrapper }

destructor TResHandleWrapper.Destroy;
begin
  if FHandle <> 0 then
  begin
    DeleteObject(FHandle);
    FHandle := 0;
  end;
  System.GC.SuppressFinalize(Self);
  inherited;
end;

procedure TResHandleWrapper.Finalize;
begin
  if FHandle <> 0 then
  begin
    DeleteObject(FHandle);
    FHandle := 0;
  end;
  inherited;
end;

{ TCanvas }

constructor TCanvas.Create;
begin
  inherited Create;
  FFont := TFont.Create;
  FFont.OnChange := FontChanged;
  FFont.OwnerLock := Self;
  FPen := TPen.Create;
  FPen.OnChange := PenChanged;
  FPen.OwnerLock := Self;
  FBrush := TBrush.Create;
  FBrush.OnChange := BrushChanged;
  FBrush.OwnerLock := Self;
  FCopyMode := cmSrcCopy;
  State := [];
  CanvasList.Add(Self);
end;

destructor TCanvas.Destroy;
begin
  CanvasList.Remove(Self);
  SetHandle(0);
  inherited Destroy;
end;

procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  Changed;
end;

const
  ROP_DSPDxax = $00E20746;

procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  const Source: TRect; Color: TColor);
var
  SrcW, SrcH, DstW, DstH: Integer;
  crBack, crText: TColorRef;
  MaskDC: HDC;
  Mask: TBitmap;
  MaskHandle: HBITMAP;
begin
  if Bitmap = nil then Exit;
  Lock;
  try
    Changing;
    RequiredState([csHandleValid, csBrushValid]);
    Bitmap.Canvas.Lock;
    try
      DstW := Dest.Right - Dest.Left;
      DstH := Dest.Bottom - Dest.Top;
      SrcW := Source.Right - Source.Left;
      SrcH := Source.Bottom - Source.Top;

      if Bitmap.TransparentColor = Color then
      begin
        Mask := nil;
        MaskHandle := Bitmap.MaskHandle;
        MaskDC := CreateCompatibleDC(0);
        MaskHandle := SelectObject(MaskDC, MaskHandle);
      end
      else
      begin
        Mask := TBitmap.Create;
        Mask.Assign(Bitmap);
        { Replace Color with black and all other colors with white }
        Mask.Mask(Color);
        Mask.Canvas.RequiredState([csHandleValid]);
        MaskDC := Mask.Canvas.FHandle;
        MaskHandle := 0;
      end;

      try
        Bitmap.Canvas.RequiredState([csHandleValid]);
        { Draw transparently or use brush color to fill background }
        if Brush.Style = bsClear then
        begin
          TransparentStretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
            Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH,
            MaskDC, Source.Left, Source.Top);
        end
        else
        begin
          StretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
            Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH, SrcCopy);
          crText := SetTextColor(Self.FHandle, 0);
          crBack := SetBkColor(Self.FHandle, $FFFFFF);
          StretchBlt(Self.FHandle, Dest.Left, Dest.Top, DstW, DstH,
            MaskDC, Source.Left, Source.Top, SrcW, SrcH, ROP_DSPDxax);
          SetTextColor(Self.FHandle, crText);
          SetBkColor(Self.FHandle, crBack);
        end;
      finally
        if Assigned(Mask) then Mask.Free
        else
        begin
          if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
          DeleteDC(MaskDC);
        end;
      end;
    finally
      Bitmap.Canvas.Unlock;
    end;
    Changed;
  finally
    Unlock;
  end;
end;

procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  Changed;
end;

procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
  const Source: TRect);
begin
  Changing;
  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  Canvas.RequiredState([csHandleValid, csBrushValid]);
  StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
    Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
    Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
  Changed;
end;

procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
begin
  if (Graphic <> nil) and not Graphic.Empty then
  begin
    Changing;
    RequiredState([csHandleValid]);
    SetBkColor(FHandle, ColorToRGB(FBrush.Color));
    SetTextColor(FHandle, ColorToRGB(FFont.Color));
    Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
    Changed;
  end;
end;

procedure TCanvas.DrawFocusRect(const Rect: TRect);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid]);
  Windows.DrawFocusRect(FHandle, Rect);
  Changed;
end;

procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
  Changed;
end;

procedure TCanvas.Ellipse(const Rect: TRect);
begin
  Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
end;

procedure TCanvas.FillRect(const Rect: TRect);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid]);
  Windows.FillRect(FHandle, Rect, Brush.GetHandle);
  Changed;
end;

const
  FillStyles: array[TFillStyle] of Word = (FLOODFILLSURFACE, FLOODFILLBORDER);

procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  FillStyle: TFillStyle);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid]);
  Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  Changed;
end;

procedure TCanvas.FrameRect(const Rect: TRect);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid]);
  Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
  Changed;
end;

function TCanvas.HandleAllocated: Boolean;
begin
  Result := FHandle <> 0;
end;

procedure TCanvas.LineTo(X, Y: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.LineTo(FHandle, X, Y);
  Changed;
end;

procedure TCanvas.Lock;
begin
  System.Threading.Monitor.Enter(Self);
end;

procedure TCanvas.MoveTo(X, Y: Integer);
begin
  RequiredState([csHandleValid]);
  Windows.MoveToEx(FHandle, X, Y, nil);
end;

procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  Changed;
end;

procedure TCanvas.Polygon(const Points: array of TPoint);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Polygon(FHandle, Points, High(Points) + 1);
  Changed;
end;

procedure TCanvas.Polyline(const Points: array of TPoint);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.Polyline(FHandle, Points, High(Points) + 1);
  Changed;
end;

procedure TCanvas.PolyBezier(const Points: array of TPoint);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.PolyBezier(FHandle, Points, High(Points) + 1);
  Changed;
end;

procedure TCanvas.PolyBezierTo(const Points: array of TPoint);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.PolyBezierTo(FHandle, Points, High(Points) + 1);
  Changed;
end;

procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid, csPenValid]);
  Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
  Changed;
end;

procedure TCanvas.Rectangle(const Rect: TRect);
begin
  Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
end;

procedure TCanvas.Refresh;
begin
  DeselectHandles;
end;

procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid, csPenValid]);
  Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
  Changed;
end;

procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
begin
  if Graphic <> nil then
  begin
    Changing;
    RequiredState(csAllValid);
    Graphic.Draw(Self, Rect);
    Changed;
  end;
end;

function TCanvas.GetCanvasOrientation: TCanvasOrientation;
var
  Point: TPoint;
begin
  Result := coLeftToRight;
  if (FTextFlags and ETO_RTLREADING) <> 0 then
  begin
    GetWindowOrgEx(Handle, Point);
    if Point.X <> 0 then Result := coRightToLeft
  end;
end;

procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
begin
  Changing;
  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  if CanvasOrientation = coRightToLeft then Inc(X, TextWidth(Text) + 1);
  Windows.ExtTextOut(FHandle, X, Y, FTextFlags, nil, Text,
   Length(Text), nil);
  MoveTo(X + TextWidth(Text), Y);
  Changed;
end;

procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
var
  Options: Longint;
begin
  Changing;
  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  Options := ETO_CLIPPED or FTextFlags;
  if Brush.Style <> bsClear then
    Options := Options or ETO_OPAQUE;
  if ((FTextFlags and ETO_RTLREADING) <> 0) and
     (CanvasOrientation = coRightToLeft) then Inc(X, TextWidth(Text) + 1);
  Windows.ExtTextOut(FHandle, X, Y, Options, Rect, Text,
    Length(Text), nil);
  Changed;
end;

const
  cTextFormats: array[TTextFormats] of Integer =
  (DT_BOTTOM, DT_CALCRECT, DT_CENTER, DT_EDITCONTROL, DT_END_ELLIPSIS,
   DT_PATH_ELLIPSIS, DT_EXPANDTABS, DT_EXTERNALLEADING, DT_LEFT,
   DT_MODIFYSTRING, DT_NOCLIP, DT_NOPREFIX, DT_RIGHT, DT_RTLREADING,
   DT_SINGLELINE, DT_TOP, DT_VCENTER, DT_WORDBREAK);

procedure TCanvas.TextRect(var Rect: TRect; var Text: string;
  TextFormat: TTextFormat = []);
var
  Format: Integer;
  F: TTextFormats;
  SB: StringBuilder;
begin
  Format := 0;
  for F := Low(TTextFormats) to High(TTextFormats) do
    if F in TextFormat then
      Format := Format or cTextFormats[F];
  if tfModifyString in TextFormat then
  begin
    SB := StringBuilder.Create(Text, Length(Text) + 4);
    DrawTextEx(Handle, SB, Length(Text), Rect, Format, nil);
    Text := SB.ToString;
  end
  else
    DrawTextEx(Handle, Text, Length(Text), Rect, Format, nil);
end;


function TCanvas.TextExtent(const Text: string): TSize;
begin
  RequiredState([csHandleValid, csFontValid]);
  Result := TSize.Empty;
  Windows.GetTextExtentPoint32(FHandle, Text, Length(Text), Result);
end;

function TCanvas.TextWidth(const Text: string): Integer;
begin
  Result := TextExtent(Text).Width;
end;

function TCanvas.TextHeight(const Text: string): Integer;
begin
  Result := TextExtent(Text).Height;
end;

function TCanvas.TryLock: Boolean;
begin
  Result := System.Threading.Monitor.TryEnter(Self);
end;

procedure TCanvas.Unlock;
begin
  System.Threading.Monitor.Exit(Self);
end;

procedure TCanvas.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TCanvas.SetPen(Value: TPen);
begin
  FPen.Assign(Value);
end;

procedure TCanvas.SetBrush(Value: TBrush);
begin
  FBrush.Assign(Value);
end;

function TCanvas.GetPenPos: TPoint;
begin
  RequiredState([csHandleValid]);
  Windows.GetCurrentPositionEx(FHandle, Result);
end;

procedure TCanvas.SetPenPos(Value: TPoint);
begin
  MoveTo(Value.X, Value.Y);
end;

function TCanvas.GetPixel(X, Y: Integer): TColor;
begin
  RequiredState([csHandleValid]);
  GetPixel := Windows.GetPixel(FHandle, X, Y);
end;

procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid]);
  Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
  Changed;
end;

function TCanvas.GetClipRect: TRect;
begin
  RequiredState([csHandleValid]);
  GetClipBox(FHandle, Result);
end;

function TCanvas.GetHandle: HDC;
begin
  Changing;
  RequiredState(csAllValid);
  Result := FHandle;
end;

procedure TCanvas.DeselectHandles;
begin
  if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
  begin
    SelectObject(FHandle, StockPen);
    SelectObject(FHandle, StockBrush);
    SelectObject(FHandle, StockFont);
    State := State - [csPenValid, csBrushValid, csFontValid];
  end;
end;

procedure TCanvas.CreateHandle;
begin
end;

procedure TCanvas.SetHandle(Value: HDC);
begin
  if FHandle <> Value then
  begin
    if FHandle <> 0 then
    begin
      DeselectHandles;
      FPenPos := GetPenPos;
      FHandle := 0;
      Exclude(State, csHandleValid);
    end;
    if Value <> 0 then
    begin
      Include(State, csHandleValid);
      FHandle := Value;
      SetPenPos(FPenPos);
    end;
  end;
end;

procedure TCanvas.RequiredState(ReqState: TCanvasState);
var
  NeededState: TCanvasState;
begin
  NeededState := ReqState - State;
  if NeededState <> [] then
  begin
    if csHandleValid in NeededState then
    begin
      CreateHandle;
      if FHandle = 0 then
        raise EInvalidOperation.Create(SNoCanvasHandle);
    end;
    if csFontValid in NeededState then CreateFont;
    if csPenValid in NeededState then CreatePen;
    if csBrushValid in NeededState then CreateBrush;
    State := State + NeededState;
  end;
end;

procedure TCanvas.Changing;
begin
  if Assigned(FOnChanging) then FOnChanging(Self);
end;

procedure TCanvas.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TCanvas.CreateFont;
begin
  SelectObject(FHandle, Font.GetHandle);
  SetTextColor(FHandle, ColorToRGB(Font.Color));
end;

const
  PenModes: array[TPenMode] of Word =
    (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
     R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
     R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);

procedure TCanvas.CreatePen;
begin
  SelectObject(FHandle, Pen.GetHandle);
  SetROP2(FHandle, PenModes[Pen.Mode]);
end;

procedure TCanvas.CreateBrush;
begin
  UnrealizeObject(Brush.Handle);
  SelectObject(FHandle, Brush.Handle);
  if Brush.Style = bsSolid then
  begin
    SetBkColor(FHandle, ColorToRGB(Brush.Color));
    SetBkMode(FHandle, OPAQUE);
  end
  else
  begin
    { Win95 doesn't draw brush hatches if bkcolor = brush color }
    { Since bkmode is transparent, nothing should use bkcolor anyway }
    SetBkColor(FHandle, not ColorToRGB(Brush.Color));
    SetBkMode(FHandle, TRANSPARENT);
  end;
end;

procedure TCanvas.FontChanged(AFont: TObject);
begin
  if csFontValid in State then
  begin
    Exclude(State, csFontValid);
    SelectObject(FHandle, StockFont);
  end;
end;

procedure TCanvas.PenChanged(APen: TObject);
begin
  if csPenValid in State then
  begin
    Exclude(State, csPenValid);
    SelectObject(FHandle, StockPen);
  end;
end;

procedure TCanvas.BrushChanged(ABrush: TObject);
begin
  if csBrushValid in State then
  begin
    Exclude(State, csBrushValid);
    SelectObject(FHandle, StockBrush);
  end;
end;

{ Picture support }

{ Metafile types }

const
  WMFKey  = Integer($9AC6CDD7);
  WMFWord = Word($CDD7);

type
  TMetafileHeader = packed record
    Key: Longint;
    Handle: SmallInt;
    Box: TSmallRect;
    Inch: Word;
    Reserved: Longint;
    CheckSum: Word;
  end;

{ Exception routines }

procedure InvalidOperation(const Str: string);
begin
  raise EInvalidGraphicOperation.Create(Str);
end;

procedure InvalidGraphic(const Str: string);
begin
  raise EInvalidGraphic.Create(Str);
end;

procedure InvalidBitmap;
begin
  InvalidGraphic(SInvalidBitmap);
end;

procedure InvalidIcon;
begin
  InvalidGraphic(SInvalidIcon);
end;

procedure InvalidMetafile;
begin
  InvalidGraphic(SInvalidMetafile);
end;

procedure OutOfResources;
begin
  raise EOutOfResources.Create(SOutOfResources);
end;

procedure GDIError;
const
  BufSize = 256;
var
  ErrorCode: Integer;
  Buf: StringBuilder;
begin
  Buf := StringBuilder.Create(BufSize);
  ErrorCode := GetLastError;
  if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
    ErrorCode, LOCALE_USER_DEFAULT, Buf, BufSize, nil) <> 0) then
    raise EOutOfResources.Create(Buf.ToString)
  else
    OutOfResources;
end;

function GDICheck(Value: Integer): Integer;
begin
  if Value = 0 then GDIError;
  Result := Value;
end;

function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
  Dec(Alignment);
  Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  Result := Result div 8;
end;

const
  ROP_DstCopy = $00AA0029;

function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;
var
  MemDC: HDC;
  MemBmp: HBITMAP;
  Save: THandle;
  crText, crBack: TColorRef;
  SavePal: HPALETTE;
begin
  Result := True;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
  begin
    MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
    MemBmp := SelectObject(MaskDC, MemBmp);
    try
      MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
        MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
    finally
      MemBmp := SelectObject(MaskDC, MemBmp);
      DeleteObject(MemBmp);
    end;
    Exit;
  end;
  SavePal := 0;
  MemDC := GDICheck(CreateCompatibleDC(0));
  try
    MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, SrcW, SrcH));
    Save := SelectObject(MemDC, MemBmp);
    SavePal := SelectPalette(SrcDC, SystemPalette16.Handle, False);
    SelectPalette(SrcDC, SavePal, False);
    if SavePal <> 0 then
      SavePal := SelectPalette(MemDC, SavePal, True)
    else
      SavePal := SelectPalette(MemDC, SystemPalette16.Handle, True);
    RealizePalette(MemDC);

    StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcCopy);
    StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcErase);
    crText := SetTextColor(DstDC, $0);
    crBack := SetBkColor(DstDC, $FFFFFF);
    StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
    StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
    SetTextColor(DstDC, crText);
    SetBkColor(DstDC, crBack);

    if Save <> 0 then SelectObject(MemDC, Save);
    DeleteObject(MemBmp);
  finally
    if SavePal <> 0 then SelectPalette(MemDC, SavePal, False);
    DeleteDC(MemDC);
  end;
end;

procedure ByteSwapColors(var Colors: array of COLORREF; Count: Integer);
var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  I: Integer;
  Color: COLORREF;
begin
  for I := 0 to Count - 1 do
  begin
    Color := Colors[I];

    { Alpha = HiByte(HiWord(Color)) = (Color shr 16) shr 8
      Red   = LoByte(Hiword(Color)) = Byte(Color shr 16)
      Green = HiByte(LoWord(Color)) = Word(Color) shr 8
      Blue  = LoByte(LoWord(Color)) = Byte(Word(Color))
      Colors[I] := MakeLong(MakeWord(Red, Green), MakeWord(Blue, Alpha)); }

    Colors[I] := (Byte(Color shr 16) or (Word(Color) shr 8) shl 8) or
      (Byte(Word(Color)) or ((Color shr 16) shr 8) shl 8) shl 16;
  end;
end;

function CreateSystemPalette(const Entries: array of TColor): HPALETTE;
var
  DC: HDC;
  SysPalSize: Integer;
  Pal: TMaxLogPalette;
  I: Integer;
  PalEntries: array of ColorRef;
begin
  Pal.palVersion := $300;
  Pal.palNumEntries := 16;
  for I := 0 to 15 do
    Pal.palPalEntry[I] := Entries[I];
  DC := GetDC(0);
  try
    SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
    { Ignore the disk image of the palette for 16 color bitmaps.
      Replace with the first and last 8 colors of the system palette }
    if SysPalSize >= 16 then
    begin
      SetLength(PalEntries, 8);
      GetSystemPaletteEntries(DC, 0, 8, PalEntries);
      System.Array.Copy(PalEntries, Pal.palPalEntry, 8);
      { Is light and dark gray swapped? }
      if TColor(Pal.palPalEntry[7]) = clSilver then
      begin
        GetSystemPaletteEntries(DC, SysPalSize - 7, 7, PalEntries);
        System.Array.Copy(PalEntries, 0, Pal.palPalEntry, Pal.palNumEntries - 7, 7);

        SetLength(PalEntries, 1);
        GetSystemPaletteEntries(DC, SysPalSize - 8, 1, PalEntries);
        Pal.palPalEntry[7] := PalEntries[0];

        GetSystemPaletteEntries(DC, 7, 1, PalEntries);
        Pal.palPalEntry[8] := PalEntries[0];
      end
      else
      begin
        GetSystemPaletteEntries(DC, SysPalSize - 8, 8, PalEntries);
        System.Array.Copy(PalEntries, 0, Pal.palPalEntry, Pal.palNumEntries - 8, 8);
      end;
    end
    else
    begin
    end;
  finally
    ReleaseDC(0,DC);
  end;
  Result := CreatePalette(Pal);
end;

function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
var
  DC: HDC;
  SysPalSize: Integer;
  PalEntries: array of ColorRef;
begin
  Result := False;
  if SystemPalette16.Handle <> 0 then
  begin
    DC := GetDC(0);
    try
      SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
      if SysPalSize >= 16 then
      begin
        { Ignore the disk image of the palette for 16 color bitmaps.
          Replace with the first and last 8 colors of the system palette }
        SetLength(PalEntries, 8);
        GetPaletteEntries(SystemPalette16.Handle, 0, 8, PalEntries); //Pal.palPalEntry);
        System.Array.Copy(PalEntries, Pal.palPalEntry, 8);
        GetPaletteEntries(SystemPalette16.Handle, 8, 8, PalEntries); //Pal.palPalEntry[Pal.palNumEntries - 8]);
        System.Array.Copy(PalEntries, 0, Pal.palPalEntry, Pal.palNumEntries - 8, 8);
        Result := True;
      end
    finally
      ReleaseDC(0,DC);
    end;
  end;
end;

function PaletteFromDIBColorTable(DIBHandle: THandle;
  ColorTable: array of COLORREF; ColorCount: Integer): HPalette;
var
  DC: HDC;
  Save: THandle;
  Pal: TMaxLogPalette;
  I: Integer;
begin
  Result := 0;
  Pal.palVersion := $300;
  if DIBHandle <> 0 then
  begin
    DC := CreateCompatibleDC(0);
    Save := SelectObject(DC, DIBHandle);
    Pal.palNumEntries := GetDIBColorTable(DC, 0, 256, Pal.palPalEntry);
    SelectObject(DC, Save);
    DeleteDC(DC);
  end
  else
  begin
    Pal.palNumEntries := ColorCount;
    if Length(ColorTable) > 0 then
      for I := 0 to ColorCount - 1 do
        Pal.palPalEntry[I] := ColorTable[I];
  end;
  if Pal.palNumEntries = 0 then Exit;
  if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
    ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  Result := CreatePalette(Pal);
end;

function PaletteToDIBColorTable(Pal: HPalette;
  var ColorTable: array of COLORREF): Integer;
begin
  Result := 0;
  if (Pal = 0) or
     (GetObject(Pal, SizeOf(Result), Result) = 0) or
     (Result = 0) then Exit;
  if Result > High(ColorTable) + 1 then
    Result := High(ColorTable) + 1;
  GetPaletteEntries(Pal, 0, Result, ColorTable);
  ByteSwapColors(ColorTable, Result);
end;

function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
begin
  Result := 0;
  with WMF, Box do
  begin
    Result := Result xor Word(Key);
    Result := Result xor HiWord(Key);
    Result := Result xor Word(Handle);
    Result := Result xor Word(Left);
    Result := Result xor Word(Top);
    Result := Result xor Word(Right);
    Result := Result xor Word(Bottom);
    Result := Result xor Inch;
    Result := Result xor Word(Reserved);
    Result := Result xor HiWord(Reserved);
  end;
end;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  Colors: Integer);
var
  DS: TDIBSection;
  Bytes: Integer;
begin
  DS.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, Marshal.SizeOf(TypeOf(DS)), DS);
  if Bytes = 0 then InvalidBitmap
  else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
    (DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
    BI := DS.dsbmih
  else
  begin
    with BI, DS.dsbm do
    begin
      biSize := SizeOf(BI);
      biWidth := bmWidth;
      biHeight := bmHeight;
    end;
  end;
  case Colors of
    2: BI.biBitCount := 1;
    3..16:
      begin
        BI.biBitCount := 4;
        BI.biClrUsed := Colors;
      end;
    17..256:
      begin
        BI.biBitCount := 8;
        BI.biClrUsed := Colors;
      end;
  else
    BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  end;
  BI.biPlanes := 1;
  if BI.biClrImportant > BI.biClrUsed then
    BI.biClrImportant := BI.biClrUsed;
  if BI.biSizeImage = 0 then
    BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;

procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  var ImageSize: DWORD; Colors: Integer);
var
  BI: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  if BI.biBitCount > 8 then
  begin
    InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    if (BI.biCompression and BI_BITFIELDS) <> 0 then
      Inc(InfoHeaderSize, 12);
  end
  else
    if BI.biClrUsed = 0 then
      InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
        SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
    else
      InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
        SizeOf(TRGBQuad) * BI.biClrUsed;
  ImageSize := BI.biSizeImage;
end;

procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  var ImageSize: DWORD);
begin
  InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
end;

function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  BitmapInfoPtr: IntPtr; var Bits: TBytes; Colors: Integer): Boolean;
var
  OldPal: HPALETTE;
  DC: HDC;
  BitmapInfo: TBitmapInfo;
begin
  BitmapInfo := TBitmapInfo(Marshal.PtrToStructure(BitmapInfoPtr, TypeOf(TBitmapInfo)));
  InitializeBitmapInfoHeader(Bitmap, BitmapInfo.bmiHeader, Colors);
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if Palette <> 0 then
    begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Marshal.StructureToPtr(TObject(BitmapInfo), BitmapInfoPtr, True);
    Result := GetDIBits(DC, Bitmap, 0, BitmapInfo.bmiHeader.biHeight, Bits,
      BitmapInfoPtr, DIB_RGB_COLORS) <> 0;
  finally
    if OldPal <> 0 then SelectPalette(DC, OldPal, False);
    DeleteDC(DC);
  end;
end;

function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; BitmapInfo: IntPtr;
  var Bits: TBytes): Boolean;
begin
  Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
end;

procedure WinError;
begin
end;

procedure CheckBool(Result: Bool);
begin
  if not Result then WinError;
end;

function GetStoredIconType(Stream: TStream): Word;
var
  Int32, Size: Cardinal;
begin
  Size := SizeOf(Int32);
  // Read the 1st two words of the TCursorOrIcon structure
  Stream.ReadBuffer(Int32, Size);
  // Return the 2nd word, which is the "wType" field
  Result := HiWord(Int32);
  Stream.Seek(0 - Size, soCurrent);
end;

{ TGraphic }

constructor TGraphic.Create;
begin                 // This stub is required for C++ compatibility.
  inherited Create;   // C++ doesn't support abstract virtual constructors.
end;

procedure TGraphic.Changed(Sender: TObject);
begin
  FModified := True;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGraphic.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
      Result := not (Filer.Ancestor is TGraphic) or
        not Equals(TGraphic(Filer.Ancestor))
    else
      Result := not Empty;
  end;

begin
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;

function TGraphic.Equals(Graphic: TGraphic): Boolean;
var
  MyImage, GraphicsImage: TMemoryStream;
begin
  Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
  if Empty or Graphic.Empty then
  begin
    Result := Empty and Graphic.Empty;
    Exit;
  end;
  if Result then
  begin
    MyImage := TMemoryStream.Create;
    try
      WriteData(MyImage);
      GraphicsImage := TMemoryStream.Create;
      try
        Graphic.WriteData(GraphicsImage);
        Result := (MyImage.Size = GraphicsImage.Size) and
          CompareBuffer(MyImage.Memory, GraphicsImage.Memory, MyImage.Size);
      finally
        GraphicsImage.Free;
      end;
    finally
      MyImage.Free;
    end;
  end;
end;

function TGraphic.GetPalette: HPALETTE;
begin
  Result := 0;
end;

function TGraphic.GetTransparent: Boolean;
begin
  Result := FTransparent;
end;

procedure TGraphic.LoadFromFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TGraphic.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

procedure TGraphic.ReadData(Stream: TStream);
begin
  LoadFromStream(Stream);
end;

procedure TGraphic.SaveToFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TGraphic.SetPalette(Value: HPalette);
begin
end;

procedure TGraphic.SetModified(Value: Boolean);
begin
  if Value then
    Changed(Self) else
    FModified := False;
end;

procedure TGraphic.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    Changed(Self);
  end;
end;

procedure TGraphic.WriteData(Stream: TStream);
begin
  SaveToStream(Stream);
end;

{ TPicture }

type
  TFileFormat = class(TObject)
  public
    GraphicClass: TGraphicClass;
    Extension: string;
    Description: string;
    DescResID: string;
  end;

  TFileFormatsList = class(TList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(const Ext, Desc: String; DescID: string; AClass: TGraphicClass);
    function FindExt(Ext: string): TGraphicClass;
    function FindClassName(const Classname: string): TGraphicClass;
    procedure Remove(AClass: TGraphicClass);
    procedure BuildFilterStrings(AClass: TGraphicClass;
      var Descriptions, Filters: string);
  end;

constructor TFileFormatsList.Create;
begin
  inherited Create;
  Add('wmf', SVMetafiles, '', TMetafile);
  Add('emf', SVEnhMetafiles, '', TMetafile);
  Add('ico', SVIcons, '', TIcon);
  Add('tiff', SVBitmaps, '', TBitmap);
  Add('tif', SVBitmaps, '', TBitmap);
  Add('png', SVBitmaps, '', TBitmap);
  Add('gif', SVBitmaps, '', TBitmap);
  Add('jpeg', SVBitmaps, '', TBitmap);
  Add('jpg', SVBitmaps, '', TBitmap);
  Add('bmp', SVBitmaps, '', TBitmap);
end;

destructor TFileFormatsList.Destroy;
var
  I: Integer;
begin
  for I := 0 to Count-1 do
    Items[I].Free;
  inherited Destroy;
end;

procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: string;
  AClass: TGraphicClass);
var
  NewFormat: TFileFormat;
begin
  NewFormat := TFileFormat.Create;
  with NewFormat do
  begin
    Extension := LowerCase(Ext);
    GraphicClass := AClass;
    Description := Desc;
    DescResID := DescID;
  end;
  inherited Add(NewFormat);
end;

function TFileFormatsList.FindExt(Ext: string): TGraphicClass;
var
  I: Integer;
begin
  Ext := LowerCase(Ext);
  for I := Count - 1 downto 0 do
    with TFileFormat(Items[I]) do
      if Extension = Ext then
      begin
        Result := GraphicClass;
        Exit;
      end;
  Result := nil;
end;

function TFileFormatsList.FindClassName(const ClassName: string): TGraphicClass;
var
  I: Integer;
begin
  for I := Count-1 downto 0 do
  begin
    Result := TFileFormat(Items[I]).GraphicClass;
    if Result.ClassName = Classname then Exit;
  end;
  Result := nil;
end;

procedure TFileFormatsList.Remove(AClass: TGraphicClass);
var
  I: Integer;
  LFormat: TFileFormat;
begin
  for I := Count-1 downto 0 do
  begin
    LFormat := TFileFormat(Items[I]);
    if LFormat.GraphicClass.InheritsFrom(AClass) then
    begin
      LFormat.Free;
      Delete(I);
    end;
  end;
end;

procedure TFileFormatsList.BuildFilterStrings(AClass: TGraphicClass;
  var Descriptions, Filters: string);
var
  C, I: Integer;
  LFormat: TFileFormat;
  LDescriptions, LFilters: StringBuilder;
begin
  LDescriptions := StringBuilder.Create;
  LFilters := StringBuilder.Create;
  C := 0;
  for I := Count-1 downto 0 do
  begin
    LFormat := TFileFormat(Items[I]);
    with LFormat do
    begin
      if GraphicClass.InheritsFrom(AClass) and (Extension <> '') then
      begin
        if C <> 0 then
        begin
          LDescriptions.Append('|');
          LFilters.Append(';');
        end;
        if (Description = '') and (DescResID <> '') then
          Description := LoadResString(DescResID);
        LDescriptions.Append(Format('%s (*.%s)|*.%1:s', [Description, Extension]));
        LFilters.Append(Format('*.%s', [Extension]));
        Inc(C);
      end;
    end;
  end;
  if C > 1 then
    LDescriptions.Insert(0, Format('%s (%s)|%1:s|', [sAllFilter, LFilters.ToString]));
  Descriptions := LDescriptions.ToString;
  Filters := LFilters.ToString;
end;

type
  TClipboardFormats = class
  private
    FClasses: TList;
    FFormats: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Fmt: Word; AClass: TGraphicClass);
    function FindFormat(Fmt: Word): TGraphicClass;
    procedure Remove(AClass: TGraphicClass);
  end;

constructor TClipboardFormats.Create;
begin
  inherited Create;
  FClasses := TList.Create;
  FFormats := TList.Create;
  Add(CF_METAFILEPICT, TMetafile);
  Add(CF_ENHMETAFILE, TMetafile);
  Add(CF_BITMAP, TBitmap);
end;

destructor TClipboardFormats.Destroy;
begin
  FClasses.Free;
  FFormats.Free;
  inherited Destroy;
end;


procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
var
  I: Integer;
begin
  I := FClasses.Add(TObject(AClass));
  try
     FFormats.Add(TObject(Integer(Fmt)));
  except
    FClasses.Delete(I);
    raise;
  end;
end;

function TClipboardFormats.FindFormat(Fmt: Word): TGraphicClass;
var
  I: Integer;
begin
  for I := FFormats.Count-1 downto 0 do
    if Integer(FFormats[I]) = Fmt then
    begin
      Result := TGraphicClass(FClasses[I]);
      Exit;
    end;
  Result := nil;
end;

procedure TClipboardFormats.Remove(AClass: TGraphicClass);
var
  I: Integer;
begin
  for I := FClasses.Count-1 downto 0 do
    if TGraphicClass(FClasses[I]).InheritsFrom(AClass) then
    begin
      FClasses.Delete(I);
      FFormats.Delete(I);
    end;
end;

var
  ClipboardFormats: TClipboardFormats = nil;
  FileFormats: TFileFormatsList = nil;

function GetFileFormats: TFileFormatsList;
begin
  if FileFormats = nil then FileFormats := TFileFormatsList.Create;
  Result := FileFormats;
end;

function GetClipboardFormats: TClipboardFormats;
begin
  if ClipboardFormats = nil then ClipboardFormats := TClipboardFormats.Create;
  Result := ClipboardFormats;
end;

constructor TPicture.Create;
begin
  inherited Create;
  GetFileFormats;
  GetClipboardFormats;
end;

destructor TPicture.Destroy;
begin
  FGraphic.Free;
  inherited Destroy;
end;

procedure TPicture.AssignTo(Dest: TPersistent);
begin
  if Graphic is Dest.ClassType then
    Dest.Assign(Graphic)
  else
    inherited AssignTo(Dest);
end;

procedure TPicture.ForceType(GraphicType: TGraphicClass);
begin
  if not (Graphic is GraphicType) then
  begin
    FGraphic.Free;
    FGraphic := nil;
    FGraphic := GraphicType.Create;
    FGraphic.OnChange := Changed;
    FGraphic.OnProgress := Progress;
    Changed(Self);
  end;
end;

function TPicture.GetBitmap: TBitmap;
begin
  ForceType(TBitmap);
  Result := TBitmap(Graphic);
end;

function TPicture.GetIcon: TIcon;
begin
  ForceType(TIcon);
  Result := TIcon(Graphic);
end;

function TPicture.GetMetafile: TMetafile;
begin
  ForceType(TMetafile);
  Result := TMetafile(Graphic);
end;

procedure TPicture.SetBitmap(Value: TBitmap);
begin
  SetGraphic(Value);
end;

procedure TPicture.SetIcon(Value: TIcon);
begin
  SetGraphic(Value);
end;

procedure TPicture.SetMetafile(Value: TMetafile);
begin
  SetGraphic(Value);
end;

procedure TPicture.SetGraphic(Value: TGraphic);
var
  NewGraphic: TGraphic;
begin
  NewGraphic := nil;
  if Value <> nil then
  begin
    NewGraphic := TGraphicClass(Value.ClassType).Create;
    NewGraphic.Assign(Value);
    NewGraphic.OnChange := Changed;
    NewGraphic.OnProgress := Progress;
  end;
  try
    FGraphic.Free;
    FGraphic := NewGraphic;
    Changed(Self);
  except
    NewGraphic.Free;
    raise;
  end;
end;

{ Based on the extension of Filename, create the cooresponding TGraphic class
  and call its LoadFromFile method. }

procedure TPicture.LoadFromFile(const Filename: string);
var
  Ext: string;
  NewGraphic: TGraphic;
  GraphicClass: TGraphicClass;
begin
  Ext := ExtractFileExt(Filename);
  Delete(Ext, 1, 1);
  GraphicClass := FileFormats.FindExt(Ext);
  if GraphicClass = nil then
    raise EInvalidGraphic.CreateFmt(SUnknownExtension, [Ext]);

  NewGraphic := GraphicClass.Create;
  try
    NewGraphic.OnProgress := Progress;
    NewGraphic.LoadFromFile(Filename);
  except
    NewGraphic.Free;
    raise;
  end;
  FGraphic.Free;
  FGraphic := NewGraphic;
  FGraphic.OnChange := Changed;
  Changed(Self);
end;

procedure TPicture.SaveToFile(const Filename: string);
begin
  if FGraphic <> nil then FGraphic.SaveToFile(Filename);
end;

procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  NewGraphic: TGraphic;
  GraphicClass: TGraphicClass;
begin
  GraphicClass := ClipboardFormats.FindFormat(AFormat);
  if GraphicClass = nil then
    InvalidGraphic(SUnknownClipboardFormat);

  NewGraphic := GraphicClass.Create;
  try
    NewGraphic.OnProgress := Progress;
    NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
  except
    NewGraphic.Free;
    raise;
  end;
  FGraphic.Free;
  FGraphic := NewGraphic;
  FGraphic.OnChange := Changed;
  Changed(Self);
end;

procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
begin
  if FGraphic <> nil then
    FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
end;

class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
begin
  Result := GetClipboardFormats.FindFormat(AFormat) <> nil;
end;

procedure TPicture.LoadFromStream(Stream: TStream);
begin
  Bitmap.LoadFromStream(Stream);
end;

procedure TPicture.SaveToStream(Stream: TStream);
begin
  Bitmap.SaveToStream(Stream);
end;

procedure TPicture.Assign(Source: TPersistent);
begin
  if Source = nil then
    SetGraphic(nil)
  else if Source is TPicture then
    SetGraphic(TPicture(Source).Graphic)
  else if Source is TGraphic then
    SetGraphic(TGraphic(Source))
  else
    inherited Assign(Source);
end;

class procedure TPicture.RegisterFileFormat(const AExtension,
  ADescription: string; AGraphicClass: TGraphicClass);
begin
  GetFileFormats.Add(AExtension, ADescription, '', AGraphicClass);
end;

class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  ADescriptionResID: string; AGraphicClass: TGraphicClass);
begin
  GetFileFormats.Add(AExtension, '', ADescriptionResID, AGraphicClass);
end;

class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  AGraphicClass: TGraphicClass);
begin
  GetClipboardFormats.Add(AFormat, AGraphicClass);
end;

class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
begin
  if FileFormats <> nil then FileFormats.Remove(AClass);
  if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
end;

procedure TPicture.Changed(Sender: TObject);
begin
  if Assigned(FOnChange) then FOnChange(Self);
  if FNotify <> nil then FNotify.Changed;
end;

procedure TPicture.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

procedure TPicture.ReadData(Stream: TStream);
var
  CName: string;
  NameBuf: TBytes;
  NameLength: Byte;
  NewGraphic: TGraphic;
  GraphicClass: TGraphicClass;
begin
  Stream.Read(NameLength, 1);
  SetLength(NameBuf, NameLength);
  Stream.Read(NameBuf, NameLength);
  CName := StringOf(NameBuf);

  GraphicClass := FileFormats.FindClassName(CName);
  NewGraphic := nil;
  if GraphicClass <> nil then
  begin
    NewGraphic := GraphicClass.Create;
    try
      NewGraphic.ReadData(Stream);
    except
      NewGraphic.Free;
      raise;
    end;
  end;
  FGraphic.Free;
  FGraphic := NewGraphic;
  if NewGraphic <> nil then
  begin
    NewGraphic.OnChange := Changed;
    NewGraphic.OnProgress := Progress;
  end;
  Changed(Self);
end;

procedure TPicture.WriteData(Stream: TStream);
var
  CName: string;
  NameBuf: TBytes;
  NameLength: Integer;
begin
  with Stream do
  begin
    if Graphic <> nil then
      CName := Graphic.ClassName
    else
      CName := '';
    NameBuf := BytesOf(CName);
    NameLength := Length(NameBuf);
    Write(NameLength, 1);  // Only write 1 byte (length of string)
    Write(NameBuf, NameLength);

    if Graphic <> nil then
      Graphic.WriteData(Stream);
  end;
end;

procedure TPicture.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  var
    Ancestor: TPicture;
  begin
    if Filer.Ancestor <> nil then
    begin
      Result := True;
      if Filer.Ancestor is TPicture then
      begin
        Ancestor := TPicture(Filer.Ancestor);
        Result := not ((Graphic = Ancestor.Graphic) or
          ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
          Graphic.Equals(Ancestor.Graphic)));
      end;
    end
    else Result := Graphic <> nil;
  end;

begin
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;

function TPicture.GetWidth: Integer;
begin
  Result := 0;
  if FGraphic <> nil then Result := FGraphic.Width;
end;

function TPicture.GetHeight: Integer;
begin
  Result := 0;
  if FGraphic <> nil then Result := FGraphic.Height;
end;

{ TMetafileImage }

destructor TMetafileImage.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

procedure TMetafileImage.FreeHandle;
begin
  if FHandle <> 0 then
  begin
    DeleteEnhMetafile(FHandle);
    FHandle := 0;
  end;
  if FPalette <> 0 then
  begin
    DeleteObject(FPalette);
    FPalette := 0;
  end;
end;

{ TMetafileDC }

procedure TMetafileDC.Finalize;
begin
  if Handle <> 0 then
  begin
    SelectObject(Handle, StockPen);
    SelectObject(Handle, StockBrush);
    SelectObject(Handle, StockFont);
    DeleteObject(CloseEnhMetafile(Handle));
    Handle := 0;
  end;
  inherited;
end;

{ TMetafileCanvas }

constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
begin
  CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
    AMetafile.Description);
end;

constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
  ReferenceDevice: HDC; const CreatedBy, Description: String);
var
  RefDC: HDC;
  R: TRect;
  P: StringBuilder;
begin
  inherited Create;
  FMetafile := AMetafile;
  RefDC := ReferenceDevice;
  if ReferenceDevice = 0 then RefDC := GetDC(0);
  try
    if FMetafile.MMWidth = 0 then
      if FMetafile.Width = 0 then
        FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE) * 100
      else
        FMetafile.MMWidth := MulDiv(FMetafile.Width,
          GetDeviceCaps(RefDC, HORZSIZE) * 100, GetDeviceCaps(RefDC, HORZRES));
    if FMetafile.MMHeight = 0 then
      if FMetafile.Height = 0 then
        FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE) * 100
      else
        FMetafile.MMHeight := MulDiv(FMetafile.Height,
          GetDeviceCaps(RefDC, VERTSIZE) * 100, GetDeviceCaps(RefDC, VERTRES));
    R := Rect(0, 0, FMetafile.MMWidth, FMetafile.MMHeight);
    if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
    begin
      P := StringBuilder.Create(1024);
      P.Append(CreatedBy);
      P.Append(#0);
      P.Append(Description);
      P.Append(#0#0);
    end
    else
      P := nil;
    FMetafileDC := TMetafileDC.Create;
    FMetafileDC.Handle := CreateEnhMetafile(RefDC, nil, R, P);
    if FMetafileDC.Handle = 0 then
      GDIError;
    Handle := FMetafileDC.Handle;
  finally
    if ReferenceDevice = 0 then
      ReleaseDC(0, RefDC);
  end;
end;

destructor TMetafileCanvas.Destroy;
begin
  if FMetafileDC.Handle <> 0 then
  begin
    Handle := 0;
    FMetafile.Handle := CloseEnhMetafile(FMetafileDC.Handle);
    FMetafileDC.Handle := 0;
  end;
  System.GC.SuppressFinalize(FMetafileDC);
  inherited Destroy;
end;

{ TMetafile }

constructor TMetafile.Create;
begin
  inherited Create;
  FEnhanced := True;
  FTransparent := True;
  Assign(nil);
end;

destructor TMetafile.Destroy;
begin
  FImage.Release;
  inherited Destroy;
end;

procedure TMetafile.Assign(Source: TPersistent);
var
  Pal: HPalette;
begin
  if (Source = nil) or (Source is TMetafile) then
  begin
    Pal := 0;
    if FImage <> nil then
    begin
      Pal := FImage.FPalette;
      FImage.Release;
    end;
    if Assigned(Source) then
    begin
      FImage := TMetafile(Source).FImage;
      FEnhanced := TMetafile(Source).Enhanced;
    end
    else
    begin
      FImage := TMetafileImage.Create;
      FEnhanced := True;
    end;
    FImage.Reference;
    PaletteModified := (Pal <> Palette) and (Palette <> 0);
    Changed(Self);
  end
  else
    inherited Assign(Source);
end;

procedure TMetafile.Clear;
begin
  NewImage;
end;

procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  MetaPal, OldPal: HPALETTE;
  R: TRect;
begin
  if FImage = nil then Exit;
  MetaPal := Palette;
  OldPal := 0;
  if MetaPal <> 0 then
  begin
    OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
    RealizePalette(ACanvas.Handle);
  end;
  R := Rect;
  Dec(R.Right);  // Metafile rect includes right and bottom coords
  Dec(R.Bottom);
  PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
  if MetaPal <> 0 then
    SelectPalette(ACanvas.Handle, OldPal, True);
end;

function TMetafile.GetAuthor: String;
var
  Buf: StringBuilder;
  BufLength: Integer;
begin
  Result := '';
  if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  BufLength := GetEnhMetafileDescription(FImage.FHandle, 0, StringBuilder(nil));
  if BufLength <= 0 then Exit;
  Buf := StringBuilder.Create(BufLength);
  GetEnhMetafileDescription(FImage.FHandle, BufLength, Buf);
  Result := Buf.ToString;
end;

function TMetafile.GetDesc: String;
var
  S: string;
  P, L: Integer;
  Buf: TBytes;
  BufLength: Integer;
begin
  Result := '';
  if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  BufLength := GetEnhMetafileDescription(FImage.FHandle, 0, StringBuilder(nil));
  if BufLength <= 0 then Exit;
  SetLength(Buf, BufLength * Marshal.SystemDefaultCharSize);
  GetEnhMetafileDescription(FImage.FHandle, BufLength, Buf);

  S := PlatformStringOf(Buf);
  P := Pos(#0, S);
  if P > 0 then
  begin
    L := PosEx(#0, S, P + 1) - 1;
    if L > 0 then
      Result := Copy(S, P + 1, L - P)
  end;
end;

function TMetafile.GetEmpty;
begin
  Result := FImage = nil;
end;

function TMetafile.GetHandle: HENHMETAFILE;
begin
  if Assigned(FImage) then
    Result := FImage.FHandle
  else
    Result := 0;
end;

function TMetaFile.HandleAllocated: Boolean;
begin
  Result := Assigned(FImage) and (FImage.FHandle <> 0);
end;

const
  HundredthMMPerInch = 2540;

function TMetafile.GetHeight: Integer;
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImage = nil then NewImage;
  with FImage do
   if FInch = 0 then
     if FHandle = 0 then
       Result := FTempHeight
     else
     begin               { convert 0.01mm units to referenceDC device pixels }
       GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), EMFHeader);
       Result := MulDiv(FHeight,                      { metafile height in 0.01mm }
         EMFHeader.szlDevice.cy,                      { device height in pixels }
         EMFHeader.szlMillimeters.cy * 100);          { device height in mm }
     end
   else          { for WMF files, convert to font dpi based device pixels }
     Result := MulDiv(FHeight, ScreenLogPixels, HundredthMMPerInch);
end;

function TMetafile.GetInch: Word;
begin
  Result := 0;
  if FImage <> nil then Result := FImage.FInch;
end;

function TMetafile.GetMMHeight: Integer;
begin
  if FImage = nil then NewImage;
  Result := FImage.FHeight;
end;

function TMetafile.GetMMWidth: Integer;
begin
  if FImage = nil then NewImage;
  Result := FImage.FWidth;
end;

function TMetafile.GetPalette: HPALETTE;
var
  LogPal: TMaxLogPalette;
  Count: Integer;
begin
  Result := 0;
  if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  if FImage.FPalette = 0 then
  begin
    Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
    if Count = 0 then
      Exit
    else if Count > 256 then
      Count := Count and $FF;
    InternalDeletePalette(FImage.FPalette);
    LogPal.palVersion := $300;
    LogPal.palNumEntries := Count;
    GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, LogPal.palPalEntry);
    FImage.FPalette := CreatePalette(LogPal);
  end;
  Result := FImage.FPalette;
end;

function TMetafile.GetWidth: Integer;
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImage = nil then NewImage;
  with FImage do
    if FInch = 0 then
      if FHandle = 0 then
        Result := FTempWidth
      else
      begin     { convert 0.01mm units to referenceDC device pixels }
        GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), EMFHeader);
        Result := MulDiv(FWidth,                       { metafile width in 0.01mm }
          EMFHeader.szlDevice.cx,                      { device width in pixels }
          EMFHeader.szlMillimeters.cx * 100);          { device width in 0.01mm }
      end
    else      { for WMF files, convert to font dpi based device pixels }
      Result := MulDiv(FWidth, ScreenLogPixels, HundredthMMPerInch);
end;

procedure TMetafile.LoadFromStream(Stream: TStream);
begin
  if TestEMF(Stream) then
    ReadEMFStream(Stream)
  else
    ReadWMFStream(Stream, Stream.Size - Stream.Position);
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TMetafile.NewImage;
begin
  FImage.Release;
  FImage := TMetafileImage.Create;
  FImage.Reference;
end;

procedure TMetafile.ReadData(Stream: TStream);
var
  Length: Longint;
begin
  Stream.Read(Length, SizeOf(Longint));
  if Length <= 4 then
    Assign(nil)
  else
    if TestEMF(Stream) then
      ReadEMFStream(Stream)
    else
      ReadWMFStream(Stream, Length - Sizeof(Length));
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TMetafile.ReadEMFStream(Stream: TStream);
var
  Buffer: TBytes;
  HeaderSize: Cardinal;
  EnhHeader: TEnhMetaheader;
begin
  NewImage;
  HeaderSize := SizeOf(TEnhMetaheader);
  SetLength(Buffer, HeaderSize);
  Stream.ReadBuffer(Buffer, HeaderSize);
  EnhHeader := TEnhMetaheader(BytesToStructure(Buffer, TypeOf(TEnhMetaheader)));
  if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  SetLength(Buffer, EnhHeader.nBytes);
  with FImage do
  begin
    Stream.Read(Buffer, HeaderSize, EnhHeader.nBytes - HeaderSize);
    FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buffer);
    if FHandle = 0 then InvalidMetafile;
    FInch := 0;
    with EnhHeader.rclFrame do
    begin
      FWidth := Right - Left;    { in 0.01 mm units }
      FHeight := Bottom - Top;
    end;
    Enhanced := True;
  end;
end;

procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
var
  Buffer, BitMem: TBytes;
  WMF: TMetafileHeader;
  MFP: TMetaFilePict;
  EMFHeader: TEnhMetaheader;
begin
  NewImage;
  SetLength(Buffer, SizeOf(WMF));
  Stream.Read(Buffer, SizeOf(WMF));
  WMF := TMetafileHeader(BytesToStructure(Buffer, TypeOf(TMetafileHeader)));
  if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
    InvalidMetafile;
  Dec(Length, SizeOf(WMF));
  SetLength(BitMem, Length);
  with FImage do
  begin
    Stream.Read(BitMem, Length);
    FImage.FInch := WMF.Inch;
    if WMF.Inch = 0 then WMF.Inch := 96;
    FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left, HundredthMMPerInch, WMF.Inch);
    FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top, HundredthMMPerInch, WMF.Inch);
    with MFP do
    begin
      MM := MM_ANISOTROPIC;
      xExt := 0;
      yExt := 0;
      hmf := 0;
    end;
    FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
    if FHandle = 0 then InvalidMetafile;
    // Get the maximum extent actually used by the metafile output
    // and re-convert the wmf data using the new extents.
    // This helps preserve whitespace margins in WMFs
    GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), EMFHeader);
    with MFP, EMFHeader.rclFrame do
    begin
      MM := MM_ANISOTROPIC;
      xExt := Right;
      yExt := Bottom;
      hmf := 0;
    end;
    DeleteEnhMetafile(FHandle);
    FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
    if FHandle = 0 then InvalidMetafile;
    Enhanced := False;
  end;
end;

procedure TMetafile.SaveToFile(const Filename: String);
var
  SaveEnh: Boolean;
begin
  SaveEnh := Enhanced;
  try
    if AnsiLowerCaseFileName(ExtractFileExt(Filename)) = '.wmf' then
      Enhanced := False;              { For 16 bit compatibility }
    inherited SaveToFile(Filename);
  finally
    Enhanced := SaveEnh;
  end;
end;

procedure TMetafile.SaveToStream(Stream: TStream);
begin
  if FImage <> nil then
    if Enhanced then
      WriteEMFStream(Stream)
    else
      WriteWMFStream(Stream);
end;

procedure TMetafile.SetHandle(Value: HENHMETAFILE);
var
  EnhHeader: TEnhMetaHeader;
begin
  if (Value <> 0) and
    (GetEnhMetafileHeader(Value, SizeOf(EnhHeader), EnhHeader) = 0) then
    InvalidMetafile;
  UniqueImage;
  if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
  InternalDeletePalette(FImage.FPalette);
  FImage.FPalette := 0;
  FImage.FHandle := Value;
  FImage.FTempWidth := 0;
  FImage.FTempHeight := 0;
  if Value <> 0 then
    with EnhHeader.rclFrame do
    begin
      FImage.FWidth := Right - Left;
      FImage.FHeight := Bottom - Top;
    end;
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TMetafile.SetHeight(Value: Integer);
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImage = nil then NewImage;
  with FImage do
    if FInch = 0 then
      if FHandle = 0 then
        FTempHeight := Value
      else
      begin                 { convert device pixels to 0.01mm units }
        GetEnhMetaFileHeader(FHandle, SizeOf(EMFHeader), EMFHeader);
        MMHeight := MulDiv(Value,                      { metafile height in pixels }
          EMFHeader.szlMillimeters.cy * 100,           { device height in 0.01mm }
          EMFHeader.szlDevice.cy);                     { device height in pixels }
      end
    else
      MMHeight := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
end;

procedure TMetafile.SetInch(Value: Word);
begin
  if FImage = nil then NewImage;
  if FImage.FInch <> Value then
  begin
    UniqueImage;
    FImage.FInch := Value;
    Changed(Self);
  end;
end;

procedure TMetafile.SetMMHeight(Value: Integer);
begin
  if FImage = nil then NewImage;
  FImage.FTempHeight := 0;
  if FImage.FHeight <> Value then
  begin
    UniqueImage;
    FImage.FHeight := Value;
    Changed(Self);
  end;
end;

procedure TMetafile.SetMMWidth(Value: Integer);
begin
  if FImage = nil then NewImage;
  FImage.FTempWidth := 0;
  if FImage.FWidth <> Value then
  begin
    UniqueImage;
    FImage.FWidth := Value;
    Changed(Self);
  end;
end;

procedure TMetafile.SetTransparent(Value: Boolean);
begin
  // Ignore assignments to this property.
  // Metafiles must always be considered transparent.
end;

procedure TMetafile.SetWidth(Value: Integer);
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImage = nil then NewImage;
  with FImage do
    if FInch = 0 then
      if FHandle = 0 then
        FTempWidth := Value
      else
      begin                 { convert device pixels to 0.01mm units }
        GetEnhMetaFileHeader(FHandle, SizeOf(EMFHeader), EMFHeader);
        MMWidth := MulDiv(Value,                      { metafile width in pixels }
          EMFHeader.szlMillimeters.cx * 100,          { device width in mm }
          EMFHeader.szlDevice.cx);                    { device width in pixels }
      end
    else
      MMWidth := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
end;

function TMetafile.TestEMF(Stream: TStream): Boolean;
var
  Size, HeaderSize: Longint;
  Buffer: TBytes;
  Header: TEnhMetaHeader;
begin
  Size := Stream.Size - Stream.Position;
  HeaderSize := SizeOf(Header);
  if Size > HeaderSize then
  begin
    SetLength(Buffer, HeaderSize);
    Stream.Read(Buffer, HeaderSize);
    Stream.Seek(-HeaderSize, soCurrent);
    Header := TEnhMetaHeader(BytesToStructure(Buffer, TypeOf(TEnhMetaHeader)));
  end;
  Result := (Size > SizeOf(Header)) and
    (Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
end;

procedure TMetafile.UniqueImage;
var
  NewImage: TMetafileImage;
begin
  if FImage = nil then
    Self.NewImage
  else
    if FImage.FRefCount > 1 then
    begin
      NewImage:= TMetafileImage.Create;
      if FImage.FHandle <> 0 then
        NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
      NewImage.FHeight := FImage.FHeight;
      NewImage.FWidth := FImage.FWidth;
      NewImage.FInch := FImage.FInch;
      NewImage.FTempWidth := FImage.FTempWidth;
      NewImage.FTempHeight := FImage.FTempHeight;
      FImage.Release;
      FImage := NewImage;
      FImage.Reference;
    end;
end;

procedure TMetafile.WriteData(Stream: TStream);
var
  SavePos: Longint;
begin
  if FImage <> nil then
  begin
    SavePos := 0;
    Stream.Write(SavePos, Sizeof(SavePos));
    SavePos := Stream.Position - Sizeof(SavePos);
    if Enhanced then
      WriteEMFStream(Stream)
    else
      WriteWMFStream(Stream);
    Stream.Seek(SavePos, soBeginning);
    SavePos := Stream.Size - SavePos;
    Stream.Write(SavePos, Sizeof(SavePos));
    Stream.Seek(0, soEnd);
  end;
end;

procedure TMetafile.WriteEMFStream(Stream: TStream);
var
  Buf: TBytes;
  Length: Longint;
begin
  if FImage = nil then Exit;
  Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  if Length = 0 then Exit;
  SetLength(Buf, Length);
  GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
  Stream.WriteBuffer(Buf, Length);
end;

procedure TMetafile.WriteWMFStream(Stream: TStream);
var
  WMF: TMetafileHeader;
  Bits: TBytes;
  Length: UINT;
  RefDC: HDC;
begin
  if FImage = nil then Exit;
  with FImage do
  begin
    with WMF do
    begin
      Key := WMFKEY;
      if FInch = 0 then
        Inch := 96          { WMF defaults to 96 units per inch }
      else
        Inch := FInch;
      with Box do
      begin
        Right := MulDiv(FWidth, WMF.Inch, HundredthMMPerInch);
        Bottom := MulDiv(FHeight, WMF.Inch, HundredthMMPerInch);
      end;
      CheckSum := ComputeAldusChecksum(WMF);
    end;
    RefDC := GetDC(0);
    try
      Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
      SetLength(Bits, Length);
      if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
        RefDC) < Length then GDIError;
      Stream.WriteBuffer(StructureToBytes(TObject(WMF)),
        Marshal.SizeOf(TypeOf(TMetafileHeader)));
      Stream.WriteBuffer(Bits, Length);
    finally
      ReleaseDC(0, RefDC);
    end;
  end;
end;

procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  EnhHeader: TEnhMetaHeader;
begin
  AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
  if AData = 0 then  InvalidGraphic(SUnknownClipboardFormat);
  NewImage;
  with FImage do
  begin
    FHandle := CopyEnhMetafile(AData, nil);
    GetEnhMetaFileHeader(FHandle, Marshal.SizeOf(TypeOf(EnhHeader)), EnhHeader);
    with EnhHeader.rclFrame do
    begin
      FWidth := Right - Left;
      FHeight := Bottom - Top;
    end;
    FInch := 0;
  end;
  Enhanced := True;
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
begin
  if FImage = nil then Exit;
  AFormat := CF_ENHMETAFILE;
  APalette := 0;
  AData := CopyEnhMetaFile(FImage.FHandle, nil);
end;

function TMetafile.ReleaseHandle: HENHMETAFILE;
begin
  UniqueImage;
  Result := FImage.FHandle;
  FImage.FHandle := 0;
end;

var
  BitmapCanvasList: TThreadList = nil;

{ TBitmapDC }

type
  TBitmapDC = class(TResHandleWrapper)
  private
    FOldBitmap: HBITMAP;
    FOldPalette: HPALETTE;
  strict protected
    procedure Finalize; override;
  public
    property OldBitmap: HBITMAP read FOldBitmap write FOldBitmap;
    property OldPalette: HPALETTE read FOldPalette write FOldPalette;
  end;

{ TBitmapCanvas }

{ Create a canvas that gets its DC from the memory DC cache }
  TBitmapCanvas = class(TCanvas)
  private
    FBitmap: TBitmap;
    FBitmapDC: TBitmapDC;
    procedure FreeContext;
  protected
    procedure CreateHandle; override;
  public
    constructor Create(ABitmap: TBitmap);
    destructor Destroy; override;
  end;

{ FreeMemoryContexts is called by the VCL main winproc to release
  memory DCs after every message is processed (garbage collection).
  Only memory DCs not locked by other threads will be freed. }
procedure FreeMemoryContexts;
var
  I: Integer;
begin
  with BitmapCanvasList.LockList do
  try
    for I := Count-1 downto 0 do
    with TBitmapCanvas(Items[I]) do
      if TryLock then
      try
        FreeContext;
      finally
        Unlock;
      end;
  finally
    BitmapCanvasList.UnlockList;
  end;
end;

{ DeselectBitmap is called to ensure that a bitmap handle is not
  selected into any memory DC anywhere in the system.  If the bitmap
  handle is in use by a locked canvas, DeselectBitmap must wait for
  the canvas to unlock. }
procedure DeselectBitmap(AHandle: HBITMAP);
var
  I: Integer;
begin
  if AHandle = 0 then Exit;
  with BitmapCanvasList.LockList do
  try
    for I := Count - 1 downto 0 do
      with TBitmapCanvas(Items[I]) do
        if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
          FreeContext;
  finally
    BitmapCanvasList.UnlockList;
  end;
end;

{ TBitmapDC }

procedure TBitmapDC.Finalize;
begin
  if Handle <> 0 then
  begin
    if FOldBitmap <> 0 then SelectObject(Handle, FOldBitmap);
    if FOldPalette <> 0 then SelectPalette(Handle, FOldPalette, True);
    SelectObject(Handle, StockPen);
    SelectObject(Handle, StockBrush);
    SelectObject(Handle, StockFont);
    DeleteDC(Handle);
    Handle := 0;
  end;
  inherited;
end;

{ TBitmapCanvas }

constructor TBitmapCanvas.Create(ABitmap: TBitmap);
begin
  inherited Create;
  FBitmapDC := TBitmapDC.Create;
  FBitmap := ABitmap;
end;

destructor TBitmapCanvas.Destroy;
begin
  FreeContext;
  System.GC.SuppressFinalize(FBitmapDC);
  inherited Destroy;
end;

procedure TBitmapCanvas.FreeContext;
begin
  if FBitmapDC.Handle <> 0 then
  begin
    Lock;
    try
      if FBitmapDC.OldBitmap <> 0 then
        SelectObject(FBitmapDC.Handle, FBitmapDC.OldBitmap);
      if FBitmapDC.OldPalette <> 0 then
        SelectPalette(FBitmapDC.Handle, FBitmapDC.OldPalette, True);
      Self.Handle := 0;
      DeleteDC(FBitmapDC.Handle);
      BitmapCanvasList.Remove(Self);
    finally
      Unlock;
    end;
  end;
end;

procedure TBitmapCanvas.CreateHandle;
begin
  if FBitmap <> nil then
  begin
    Lock;
    try
      FBitmap.HandleNeeded;
      DeselectBitmap(FBitmap.FImage.FHandle);
                           
//!!      DeselectBitmap(FBitmap.FImage.FMaskHandle);
      FBitmap.PaletteNeeded;
      FBitmapDC.Handle := CreateCompatibleDC(0);
      if FBitmap.FImage.FHandle <> 0 then
        FBitmapDC.OldBitmap := SelectObject(FBitmapDC.Handle, FBitmap.FImage.FHandle)
      else
        FBitmapDC.OldBitmap := 0;
      Handle := FBitmapDC.Handle;
      BitmapCanvasList.Add(Self);
    finally
      Unlock;
    end;
  end;
end;

{ TSharedImage }

destructor TSharedImage.Destroy;
begin
  FreeHandle;
  System.GC.SuppressFinalize(Self);
  inherited Destroy;
end;

procedure TSharedImage.Finalize;
begin
  FreeHandle;
  inherited;
end;

procedure TSharedImage.Reference;
begin
  Inc(FRefCount);
end;

procedure TSharedImage.Release;
begin
  if Self <> nil then
  begin
    Dec(FRefCount);
    if FRefCount = 0 then
    begin
      FreeHandle;
      Free;
    end;
  end;
end;

{ TBitmapImage }

destructor TBitmapImage.Destroy;
begin
  FreeHandle;
  FreeAndNil(FSaveStream);
  inherited Destroy;
end;

procedure TBitmapImage.FreeHandle;
begin
  if (FDIBHandle <> 0) and (FDIBHandle <> FHandle) then
  begin
    DeselectBitmap(FDIBHandle);
    DeleteObject(FDIBHandle);
    FDIBHandle := 0;
  end;
  if FHandle <> 0 then
  begin
    DeselectBitmap(FHandle);
    DeleteObject(FHandle);
    if FHandle = FDIBHandle then FDIBHandle := 0;
    FHandle := 0;
  end;
  if FMaskHandle <> 0 then
  begin
    DeselectBitmap(FMaskHandle);
    DeleteObject(FMaskHandle);
    FMaskHandle := 0;
  end;
  if FPalette <> 0 then
  begin
    DeleteObject(FPalette);
    FPalette := 0;
  end;
end;

{ TBitmap }

procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
  const DIB: TDIBSection);
var
  ScreenDC, DC: HDC;
  OldBM: HBitmap;
  ColorCount: Integer;
  Colors: array [Byte] of COLORREF;
begin
  if (DIBHandle <> 0) and (DIB.dsbmih.biBitCount <= 8) then
  begin
    ColorCount := PaletteToDIBColorTable(Pal, Colors);
    if ColorCount = 0 then Exit;
    ScreenDC := GetDC(0);
    DC := CreateCompatibleDC(ScreenDC);
    OldBM := SelectObject(DC, DIBHandle);
    try
      SetDIBColorTable(DC, 0, ColorCount, Colors);
    finally
      SelectObject(DC, OldBM);
      DeleteDC(DC);
      ReleaseDC(0, ScreenDC);
    end;
  end;
end;

procedure FixupBitFields(var DIB: TDIBSection);
begin
  if (DIB.dsbmih.biCompression and BI_BITFIELDS <> 0) and
    (DIB.dsBitFields[0] = 0) then
    if DIB.dsbmih.biBitCount = 16 then
    begin
      // fix buggy 16 bit color drivers
      DIB.dsBitFields[0] := $F800;
      DIB.dsBitFields[1] := $07E0;
      DIB.dsBitFields[2] := $001F;
    end else if DIB.dsbmih.biBitCount = 32 then
    begin
      // fix buggy 32 bit color drivers
      DIB.dsBitFields[0] := $00FF0000;
      DIB.dsBitFields[1] := $0000FF00;
      DIB.dsBitFields[2] := $000000FF;
    end;
end;

function CopyBitmap(Handle: HBITMAP; OldPalette, NewPalette: HPALETTE;
  var DIB: TDIBSection; Canvas: TCanvas): HBITMAP;
var
  OldScr, NewScr: HBITMAP;
  ScreenDC, NewImageDC, OldImageDC: HDC;
  BI: TBitmapInfo;
  BitsMem: IntPtr;
  SrcDIB: TDIBSection;
  MonoColors: array [0..1] of COLORREF;
  Pal1, Pal2: HPalette;
begin
  Result := 0;
  with DIB, dsbm, dsbmih do
  begin
    if (biSize <> 0) and ((biWidth = 0) or (biHeight = 0)) then Exit;
    if (biSize = 0) and ((bmWidth = 0) or (bmHeight = 0)) then Exit;
  end;

  DeselectBitmap(Handle);

  SrcDIB.dsbmih.biSize := 0;
  if Handle <> 0 then
    if GetObject(Handle, Marshal.SizeOf(TypeOf(SrcDIB)), SrcDIB) < sizeof(SrcDIB.dsbm) then
      InvalidBitmap;

  ScreenDC := GDICheck(GetDC(0));
  NewImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  with DIB.dsbm do
  try
    if DIB.dsbmih.biSize < DWORD(sizeof(DIB.dsbmih)) then
      if (bmPlanes or bmBitsPixel) = 1 then // monochrome
        Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
      else  // Create DDB
        Result := GDICheck(CreateCompatibleBitmap(ScreenDC, bmWidth, bmHeight))
    else  // Create DIB
    begin
      if (bmBits = nil) and ((bmPlanes or bmBitsPixel) = 1) then // monochrome
        Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
      else  // Create DIB
      begin
        with DIB.dsbmih do
        begin
          biSize := sizeof(BI.bmiHeader);
          biPlanes := 1;
          if bmBitsPixel = 0 then
            biBitCount := GetDeviceCaps(ScreenDC, BITSPIXEL) * GetDeviceCaps(ScreenDC, PLANES)
          else
            biBitCount := bmBitsPixel;
          biWidth := bmWidth;
          biHeight := bmHeight;
          biCompression := BI_RGB;
          BI.bmiHeader := DIB.dsbmih;

          if (biBitCount <= 8) then
          begin
            if (biBitCount = 1) and ((Handle = 0) or (SrcDIB.dsbm.bmBits = nil)) then
            begin  // set mono DIB to white/black when converting from DDB.
              BI.bmiColors[0] := 0;
              BI.bmiColors[1] := $FFFFFF;
            end
            else if (NewPalette <> 0) then
              PaletteToDIBColorTable(NewPalette, BI.bmiColors)
            else if Handle <> 0 then
            begin
              NewScr := SelectObject(NewImageDC, Handle);
              if SrcDIB.dsbm.bmBits <> nil then
                biClrUsed := GetDIBColorTable(NewImageDC, 0, 1 shl biBitCount, BI.bmiColors)
              else
                GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), nil, BI, DIB_RGB_COLORS);
              SelectObject(NewImageDC, NewScr);
            end;
          end
          else if ((biBitCount = 16) or (biBitCount = 32)) and
            ((biCompression and BI_BITFIELDS) <> 0) then
          begin
            FixupBitFields(DIB);
            BI.bmiColors[0] := DIB.dsBitFields[0];
            BI.bmiColors[1] := DIB.dsBitFields[1];
            BI.bmiColors[2] := DIB.dsBitFields[2];
          end;

          Result := GDICheck(CreateDIBSection(ScreenDC, BI, DIB_RGB_COLORS, BitsMem, 0, 0));
          if (BitsMem = nil) then GDIError;

          if (Handle <> 0) and (SrcDIB.dsbm.bmWidth = biWidth) and
            (SrcDIB.dsbm.bmHeight = biHeight) and (biBitCount > 8) then
          begin    // shortcut bitblt steps
            GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), BitsMem, BI, DIB_RGB_COLORS);
            Exit;
          end;
        end;
      end;
    end;

    GDICheck(Result);
    NewScr := GDICheck(SelectObject(NewImageDC, Result));
    try
      try
        Pal1 := 0;
        Pal2 := 0;
        if NewPalette <> 0 then
        begin
          Pal1 := SelectPalette(NewImageDC, NewPalette, False);
          RealizePalette(NewImageDC);
        end;
        try
          if Canvas <> nil then
          begin
            FillRect(NewImageDC, Rect(0, 0, bmWidth, bmHeight),
              Canvas.Brush.Handle);
            SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
            SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
            if (DIB.dsbmih.biBitCount = 1) and (DIB.dsbm.bmBits <> nil) then
            begin
              MonoColors[0] := ColorToRGB(Canvas.Font.Color);
              MonoColors[1] := ColorToRGB(Canvas.Brush.Color);
              SetDIBColorTable(NewImageDC, 0, 2, MonoColors);
            end;
          end
          else
            PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);

          if Handle <> 0 then
          begin
            OldImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
            try
              OldScr := GDICheck(SelectObject(OldImageDC, Handle));
              if OldPalette <> 0 then
              begin
                Pal2 := SelectPalette(OldImageDC, OldPalette, False);
                RealizePalette(OldImageDC);
              end;
              if Canvas <> nil then
              begin
                SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
                SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
              end;
              BitBlt(NewImageDC, 0, 0, bmWidth, bmHeight, OldImageDC, 0, 0, SRCCOPY);
              if OldPalette <> 0 then
                SelectPalette(OldImageDC, Pal2, True);
              GDICheck(SelectObject(OldImageDC, OldScr));
            finally
              DeleteDC(OldImageDC);
            end;
          end;
        finally
          if NewPalette <> 0 then
            SelectPalette(NewImageDC, Pal1, True);
        end;
      finally
        SelectObject(NewImageDC, NewScr);
      end;
    except
      DeleteObject(Result);
      raise;
    end;
  finally
    DeleteDC(NewImageDC);
    ReleaseDC(0, ScreenDC);
    if (Result <> 0) then
      GetObject(Result, Marshal.SizeOf(TypeOf(DIB)), DIB);
  end;
end;

function CopyPalette(Palette: HPALETTE): HPALETTE;
var
  PaletteSize: Integer;
  LogPal: TMaxLogPalette;
begin
  Result := 0;
  if Palette = 0 then Exit;
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), PaletteSize) = 0 then Exit;
  if PaletteSize = 0 then Exit;
  with LogPal do
  begin
    palVersion := $0300;
    palNumEntries := PaletteSize;
    GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  end;
  Result := CreatePalette(LogPal);
end;

function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
  TransparentColor: TColorRef): HBITMAP;
var
  DIB: TDIBSection;
  ScreenDC, BitmapDC, MonoDC: HDC;
  BkColor: TColorRef;
  Remove: Boolean;
  SaveBitmap, SaveMono: HBITMAP;
begin
  Result := 0;
  if (Handle <> 0) and (GetObject(Handle, Marshal.SizeOf(TypeOf(DIB)), DIB) <> 0) then
  begin
    DeselectBitmap(Handle);
    ScreenDC := 0;
    MonoDC := 0;
    try
      ScreenDC := GDICheck(GetDC(0));
      MonoDC := GDICheck(CreateCompatibleDC(ScreenDC));
      with DIB, dsBm do
      begin
        Result := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
        if Result <> 0 then
        begin
          SaveMono := SelectObject(MonoDC, Result);
          if TransparentColor = TColorRef(clNone) then
            PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
          else
          begin
            BitmapDC := GDICheck(CreateCompatibleDC(ScreenDC));
            try
              { Convert DIB to DDB }
              if bmBits <> nil then
              begin
                Remove := True;
                DIB.dsbmih.biSize := 0;
                Handle := CopyBitmap(Handle, Palette, Palette, DIB, nil);
              end
              else Remove := False;
              SaveBitmap := SelectObject(BitmapDC, Handle);
              if Palette <> 0 then
              begin
                SelectPalette(BitmapDC, Palette, False);
                RealizePalette(BitmapDC);
                SelectPalette(MonoDC, Palette, False);
                RealizePalette(MonoDC);
              end;
              BkColor := SetBkColor(BitmapDC, TransparentColor);
              BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
              SetBkColor(BitmapDC, BkColor);
              if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
              if Remove then DeleteObject(Handle);
            finally
              DeleteDC(BitmapDC);
            end;
          end;
          if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
        end;
      end;
    finally
      if MonoDC <> 0 then DeleteDC(MonoDC);
      if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
    end;
  end;
end;

constructor TBitmap.Create;
begin
  inherited Create;
  FTransparentColor := clDefault;
  FImage := TBitmapImage.Create;
  FImage.Reference;
  if DDBsOnly then HandleType := bmDDB; 
end;

destructor TBitmap.Destroy;
begin
  FreeContext;
  FImage.Release;
  FCanvas.Free;
  inherited Destroy;
end;

procedure TBitmap.Assign(Source: TPersistent);
var
  NewHandle: HBITMAP;
  NewPalette: HPALETTE;
  DIB: TDIBSection;
begin
  if (Source = nil) or (Source is TBitmap) then
  begin
    System.Threading.Monitor.Enter(BitmapImageLock);
    try
      if Source <> nil then
      begin
        TBitmap(Source).FImage.Reference;
        FImage.Release;
        FImage := TBitmap(Source).FImage;
        FTransparent := TBitmap(Source).FTransparent;
        FTransparentColor := TBitmap(Source).FTransparentColor;
        FTransparentMode := TBitmap(Source).FTransparentMode;
      end
      else
        NewImage(0, 0, DIB);
    finally
      System.Threading.Monitor.Exit(BitmapImageLock);
    end;
    PaletteModified := Palette <> 0;
    Changed(Self);
  end
  else
  begin
    if Source is System.Drawing.Bitmap then
    begin
      FreeContext;
      InternalLoadFromBitmap(System.Drawing.Bitmap(Source), NewHandle, NewPalette, DIB);
      NewImage(NewHandle, NewPalette, DIB, System.Drawing.Bitmap(Source).RawFormat);
      PaletteModified := Palette <> 0;
      Changed(Self);
    end
    else
      inherited Assign(Source);
  end;
end;

procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
var
  NewHandle, NewPalette: THandle;
begin
  FreeContext;
  NewHandle := 0;
  NewPalette := 0;
  try
    if THandle(APalette) = SystemPalette16.Handle then
      NewPalette := APalette
    else
      NewPalette := CopyPalette(APalette);
    NewHandle := CopyBitmap(AHandle, APalette, NewPalette, DIB, FCanvas);
    NewImage(NewHandle, NewPalette, DIB, FImage.FImageFormat);
  except
    InternalDeletePalette(NewPalette);
    if NewHandle <> 0 then DeleteObject(NewHandle);
    raise;
  end;
end;

{ Called by the FCanvas whenever an operation is going to be performed on the
  bitmap that would modify it.  Since modifications should only affect this
  TBitmap, the handle needs to be 'cloned' if it is being refered to by more
  than one TBitmap }
procedure TBitmap.Changing(Sender: TObject);
begin
  FreeImage;
  FreeAndNil(FImage.FSaveStream);
end;

procedure TBitmap.Changed(Sender: TObject);
begin
  FMaskBitsValid := False;
  inherited Changed(Sender);
end;

procedure TBitmap.Dormant;
var
  S: TMemoryStream;
  DIB: TDIBSection;
begin
  S := TMemoryStream.Create;
  SaveToStream(S);
  S.Size := S.Size;  // compact to minimum buffer
  DIB := FImage.FDIB;
  DIB.dsBm.bmBits := nil;
  FreeContext; // InternalDeletePalette requires this
  FreeAndNil(FCanvas);
  NewImage(0, 0, DIB, FImage.FImageFormat, S);
end;

procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  OldPalette: HPalette;
  RestorePalette: Boolean;
  DoHalftone: Boolean;
  Pt: TPoint;
  BPP: Integer;
  MaskDC: HDC;
  Save: THandle;
begin
  with Rect, FImage do
  begin
    ACanvas.RequiredState(csAllValid);
    PaletteNeeded;
    OldPalette := 0;
    RestorePalette := False;

    if FPalette <> 0 then
    begin
      OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
      RealizePalette(ACanvas.FHandle);
      RestorePalette := True;
    end;

    BPP := GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
      GetDeviceCaps(ACanvas.FHandle, PLANES);
    DoHalftone := (BPP <= 8) and (BPP < (FDIB.dsBm.bmBitsPixel * FDIB.dsBm.bmPlanes));
    if DoHalftone then
    begin
      GetBrushOrgEx(ACanvas.FHandle, pt);
      SetStretchBltMode(ACanvas.FHandle, HALFTONE);
      SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, pt);
    end
    else
      if not Monochrome then
        SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
    try
      { Call MaskHandleNeeded prior to creating the canvas handle since
        it causes FreeContext to be called. }
      if Transparent then MaskHandleNeeded;
      Canvas.RequiredState(csAllValid);
      if Transparent then
      begin
        Save := 0;
        MaskDC := 0;
        try
          MaskDC := GDICheck(CreateCompatibleDC(0));
          Save := SelectObject(MaskDC, FMaskHandle);
          TransparentStretchBlt(ACanvas.FHandle, Left, Top, Right - Left,
            Bottom - Top, Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
            FDIB.dsbm.bmHeight, MaskDC, 0, 0);
        finally
          if Save <> 0 then SelectObject(MaskDC, Save);
          if MaskDC <> 0 then DeleteDC(MaskDC);
        end;
      end
      else
      begin
        StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
          Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
          FDIB.dsbm.bmHeight, ACanvas.CopyMode);
      end;
    finally
      if RestorePalette then
        SelectPalette(ACanvas.FHandle, OldPalette, True);
    end;
  end;
end;

{ FreeImage:
  If there are multiple references to the image, create a unique copy of the image.
  If FHandle = FDIBHandle, the DIB memory will be updated when the drawing
  handle is drawn upon, so no changes are needed to maintain image integrity.
  If FHandle <> FDIBHandle, the DIB will not track with changes made to
  the DDB, so destroy the DIB handle (but keep the DIB pixel format info).  }

procedure TBitmap.FreeImage;
var
  P: HPalette;
begin
  with FImage do
    if FRefCount > 1 then
    begin
      HandleNeeded;
      if FHalftone then
        P := 0
      else
        P := FPalette;
      CopyImage(FHandle, P, FDIB)
    end
    else
      if (FHandle <> 0) and (FHandle <> FDIBHandle) then
      begin
        if FDIBHandle <> 0 then
          if not DeleteObject(FDIBHandle) then GDIError;
        FDIBHandle := 0;
        FDIB.dsbm.bmBits := nil;
      end;
end;

function TBitmap.GetEmpty: Boolean;
begin
  with FImage do
    Result := (FHandle = 0) and (FDIBHandle = 0) and (FSaveStream = nil);
end;

function TBitmap.GetCanvas: TCanvas;
begin
  if FCanvas = nil then
  begin
    HandleNeeded;
    if FCanvas = nil then    // possible recursion
    begin
      FCanvas := TBitmapCanvas.Create(Self);
      FCanvas.OnChange := Changed;
      FCanvas.OnChanging := Changing;
    end;
  end;
  Result := FCanvas;
end;

{ Since the user might modify the contents of the HBITMAP it must not be
  shared by another TBitmap when given to the user nor should it be selected
  into a DC. }
function TBitmap.GetHandle: HBITMAP;
begin
  FreeContext;
  HandleNeeded;
  Changing(Self);
  Result := FImage.FHandle;
end;

function TBitmap.HandleAllocated: Boolean;
begin
  Result := Assigned(FImage) and (FImage.FHandle <> 0);
end;

function TBitmap.GetHandleType: TBitmapHandleType;
begin
  with FImage do
  begin
    if (FHandle = 0) or (FHandle = FDIBHandle) then
      if FDIBHandle = 0 then
        if FDIB.dsbmih.biSize = 0 then
          Result := bmDDB
        else
          Result := bmDIB
      else
        Result := bmDIB
    else
      Result := bmDDB;
  end;
end;

function TBitmap.GetHeight: Integer;
begin
  Result := Abs(FImage.FDIB.dsBm.bmHeight);
end;

function TBitmap.GetImageFormat: TImageFormat;
begin
  Result := FImage.FImageFormat;
end;

function TBitmap.GetMaskHandle: HBITMAP;
begin
  MaskHandleNeeded;
  Result := FImage.FMaskHandle;
end;

function TBitmap.GetMonochrome: Boolean;
begin
  with FImage.FDIB.dsBm do
    Result := (bmPlanes = 1) and (bmBitsPixel = 1);
end;

function TBitmap.GetPalette: HPALETTE;
begin
  PaletteNeeded;
  Result := FImage.FPalette;
end;

function TBitmap.GetPixelFormat: TPixelFormat;
begin
  Result := pfCustom;
  if HandleType = bmDDB then
    Result := pfDevice
  else
    with FImage.FDIB, dsBm, dsbmih do
      case bmBitsPixel of
        1: Result := pf1Bit;
        4: Result := pf4Bit;
        8: Result := pf8Bit;
       16: case biCompression of
             BI_RGB : Result := pf15Bit;
             BI_BITFIELDS: if dsBitFields[1] = $7E0 then Result := pf16Bit;
           end;
       24: Result := pf24Bit;
       32: if biCompression = BI_RGB then Result := pf32Bit;
      end;
end;

function TBitmap.GetScanLine(Row: Integer): IntPtr;
begin
  Changing(Self);
  with FImage.FDIB.dsBm do
  begin
    if (Row < 0) or (Row >= bmHeight) then
      InvalidOperation(SScanLine);
    DIBNeeded;
    GDIFlush;
    Row := bmHeight - Row - 1; // Always bottom-up DIB
    Result := IntPtr(Longint(bmBits) +
      Row * BytesPerScanline(bmWidth, bmBitsPixel, 32));
  end;
end;

function TBitmap.GetTransparentColor: TColor;
begin
  if FTransparentColor = clDefault then
  begin
    if Monochrome then
      Result := clWhite
    else
      Result := Canvas.Pixels[0, Height - 1];
  end
  else Result := ColorToRGB(FTransparentColor);
  Result := Result or $02000000;
end;

function TBitmap.GetWidth: Integer;
begin
  Result := FImage.FDIB.dsBm.bmWidth;
end;

procedure TBitmap.DIBNeeded;
begin
  with FImage do
  begin
    if (FHandle = 0) or (FDIBHandle <> 0) then Exit;
    PaletteNeeded;
    if FDIB.dsbmih.biSize = 0 then
    begin
      GetObject(FHandle, Marshal.SizeOf(TypeOf(FDIB)), FDIB);
      with FDIB, dsbm, dsbmih do
      begin
        biSize := SizeOf(dsbmih);
        biWidth := bmWidth;
        biHeight := bmHeight;
        biPlanes := 1;
        biBitCount := bmPlanes * bmBitsPixel;
      end;
    end;
    FDIBHandle := CopyBitmap(FHandle, FPalette, FPalette, FDIB, nil);
  end;
end;

procedure TBitmap.FreeContext;
begin
  if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
end;

procedure TBitmap.HandleNeeded;
var
  vChange: TNotifyEvent;
begin
  if (FImage.FHandle = 0) and (FImage.FDIBHandle = 0) and (FImage.FSaveStream <> nil) then
  begin
    FImage.FSaveStream.Position := 0;
    vChange := OnChange;
    try
      OnChange := nil;
      LoadFromStream(FImage.FSaveStream);  // Current FImage may be destroyed here
    finally
      OnChange := vChange;
    end;
  end;

  with FImage do
    if FHandle = 0 then
      FHandle := FDIBHandle;
end;

procedure TBitmap.Mask(TransparentColor: TColor);
var
  NewHandle, NewPalette: THandle;
  DIB: TDIBSection;
begin
  NewHandle := 0;
  NewPalette := 0;
  try
    FreeContext;
    HandleNeeded;
    NewHandle := CopyBitmapAsMask(FImage.FHandle, FImage.FPalette,
      ColorToRGB(TransparentColor));
    GetObject(NewHandle, Marshal.SizeOf(TypeOf(DIB)), DIB);
    if THandle(FImage.FPalette) = SystemPalette16.Handle then
      NewPalette := FImage.FPalette
    else
      NewPalette := CopyPalette(FImage.FPalette);
    NewImage(NewHandle, NewPalette, DIB);
  except
    InternalDeletePalette(NewPalette);
    if NewHandle <> 0 then DeleteObject(NewHandle);
    raise;
  end;
  Changed(Self);
end;

procedure TBitmap.MaskHandleNeeded;
begin
  if FMaskValid and FMaskBitsValid then Exit;
  with FImage do
  begin
  { Delete existing mask if any }
    if FMaskHandle <> 0 then
    begin
      DeselectBitmap(FMaskHandle);
      DeleteObject(FMaskHandle);
      FMaskHandle := 0;
    end;
    FreeContext;
    HandleNeeded;  // may change FImage instance pointer
  end;
  with FImage do   // use new FImage from here on
  begin
    FMaskHandle := CopyBitmapAsMask(FHandle, FPalette, GetTransparentColor);
    FMaskValid := True;
    FMaskBitsValid := True;
  end;
end;

procedure TBitmap.PaletteNeeded;
var
  DC: HDC;
begin
  with FImage do
  begin
    if FIgnorePalette or (FPalette <> 0) or (FDIBHandle = 0) then Exit;
    if FHandle = FDIBHandle then DeselectBitmap(FDIBHandle);
    FPalette := PaletteFromDIBColorTable(FDIBHandle, [], 1 shl FDIB.dsbmih.biBitCount);
    if FPalette <> 0 then Exit;
    DC := GDICheck(GetDC(0));
    FHalftone := FHalftone or
      ((GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <
      (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
    if FHalftone then FPalette := CreateHalftonePalette(DC);
    ReleaseDC(0, DC);
    if FPalette = 0 then IgnorePalette := True;
  end;
end;

procedure TBitmap.InternalLoadFromBitmap(Bitmap: System.Drawing.Bitmap;
  var BMHandle: HBITMAP; var APalette: HPALETTE; var DIB: TDIBSection);
var
  BmData: System.Drawing.Imaging.BitmapData;
  BitsMem: IntPtr;
  BI: TBitmapInfo;
  ScreenDC, NewImageDC: HDC;
  NewGraphics: System.Drawing.Graphics;
  OldHandle: THandle;
  ColorCount, I: Integer;
  OldPalette: HPalette;
begin
  // Calculate bits per pixel, setup BitmapInfo structure
  BmData := Bitmap.LockBits(Rectangle.FromLTRB(0, 0, Bitmap.Width, Bitmap.Height),
    ImageLockMode.ReadOnly, Bitmap.PixelFormat);
  with BI, bmiHeader, Bitmap do
  begin
    try
      biSize := Marshal.SizeOf(TypeOf(TBitmapInfoHeader));
      biPlanes := 1;

      biBitCount := Abs(BmData.Stride) div Width;
      if biBitCount > 0 then
        biBitCount := biBitCount * 8
      else
      begin
        if BmData.PixelFormat = System.Drawing.Imaging.PixelFormat.Format1bppIndexed then
          biBitCount := 1
        else
          if BmData.PixelFormat = System.Drawing.Imaging.PixelFormat.Format4bppIndexed then
            biBitCount := 4
          else
            if BmData.PixelFormat = System.Drawing.Imaging.PixelFormat.Format8bppIndexed then
              biBitCount := 8
            else
              raise Exception.Create(SInvalidPixelFormat);
      end;

      biWidth := Width;
      biHeight := Height;
      biCompression := BI_RGB;
    finally
      Bitmap.UnlockBits(BmData);
    end;

    // Copy color table and invert alpha channel
    ColorCount := Length(Bitmap.Palette.Entries);
    if ColorCount > 0 then
      for I := 0 to ColorCount - 1 do
        bmiColors[I] := Bitmap.Palette.Entries[I].ToArgb xor Longint($FF000000);
  end;

  OldPalette := 0;
  APalette := 0;
  ScreenDC := GetDC(0);
  NewImageDC := CreateCompatibleDC(ScreenDC);
  try
    // Create Bitmap
    BMHandle := CreateDIBSection(NewImageDC, BI, DIB_RGB_COLORS, BitsMem, 0, 0);
    if (BitsMem = nil) then GDIError;
    GDICheck(BMHandle);
    OldHandle := SelectObject(NewImageDC, BMHandle);
    try
      // Create palette
      if ColorCount > 0 then
      begin
        SetDIBColorTable(NewImageDC, 0, ColorCount, BI.bmiColors);
        APalette := PaletteFromDIBColorTable(0, BI.bmiColors, ColorCount);
        OldPalette := SelectPalette(NewImageDC, APalette, False);
        RealizePalette(NewImageDC);
      end;

      // Draw image on device context
      NewGraphics := System.Drawing.Graphics.FromHDC(IntPtr(NewImageDC));
      NewGraphics.DrawImage(Bitmap, 0, 0, Bitmap.Width, Bitmap.Height);
    finally
      if OldHandle <> 0 then SelectObject(NewImageDC, OldHandle);
    end;
  finally
    if OldPalette <> 0 then SelectPalette(NewImageDC, OldPalette, True);
    if NewImageDC <> 0 then DeleteDC(NewImageDC);
    if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
  end;

  GetObject(BMHandle, Marshal.SizeOf(TypeOf(DIB)), DIB);
end;

procedure TBitmap.LoadFromBitmap(Bitmap: System.Drawing.Bitmap);
var
  DIB: TDIBSection;
  BMHandle: HBITMAP;
  APalette: HPALETTE;
begin
  InternalLoadFromBitmap(Bitmap, BMHandle, APalette, DIB);
  NewImage(BMHandle, APalette, DIB, Bitmap.RawFormat);
  Changed(Self);
end;

                                                      
procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  DIB: TDIBSection;
begin
  if (AFormat <> CF_BITMAP) or (AData = 0) then
    InvalidGraphic(SUnknownClipboardFormat);
  FreeContext;
  GetObject(AData, Marshal.SizeOf(TypeOf(DIB)), DIB);
  if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
  CopyImage(AData, APalette, DIB);
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TBitmap.LoadFromResourceName(const ResName, BaseName: String;
  ResourceAssembly: Assembly; Culture: CultureInfo);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(BaseName, ResourceAssembly);
  LoadFromBitmap(System.Drawing.Bitmap(ResMgr.GetObject(ResName, Culture)));
end;

procedure TBitmap.LoadFromResourceName(const ResName, BaseName: String;
  ResourceAssembly: Assembly; ResourceSet: System.Type; Culture: CultureInfo = nil);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(BaseName, ResourceAssembly, ResourceSet);
  LoadFromBitmap(System.Drawing.Bitmap(ResMgr.GetObject(ResName, Culture)));
end;

procedure TBitmap.LoadFromResourceName(const ResName: String;
  AType: System.Type; Culture: CultureInfo);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(AType);
  LoadFromBitmap(System.Drawing.Bitmap(ResMgr.GetObject(ResName, Culture)));
end;

procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
var
  DIB: TDIBSection;
  NewHandle: HBITMAP;
begin
  NewHandle := LoadImage(Instance, ResName, IMAGE_BITMAP, 0, 0,
    LR_CREATEDIBSECTION or LR_DEFAULTSIZE);
  GetObject(NewHandle, Marshal.SizeOf(TypeOf(DIB)), DIB);
  NewImage(NewHandle, 0, DIB);
  Changed(Self);
end;

procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
  DIB: TDIBSection;
  NewHandle: HBITMAP;
begin
  NewHandle := LoadImage(Instance, ResID, IMAGE_BITMAP, 0, 0,
    LR_CREATEDIBSECTION or LR_DEFAULTSIZE);
  GetObject(NewHandle, Marshal.SizeOf(TypeOf(DIB)), DIB);
  NewImage(NewHandle, 0, DIB);
  Changed(Self);
end;

procedure TBitmap.LoadFromStream(Stream: TStream);
begin
  ReadStream(Stream, Stream.Size - Stream.Position);
end;

procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  const NewDIB: TDIBSection; NewImageFormat: TImageFormat = nil;
  NewSaveStream: TMemoryStream = nil);
var
  Image: TBitmapImage;
begin
  Image := TBitmapImage.Create;
  with Image do
  try
    FHandle := NewHandle;
    FPalette := NewPalette;
    FDIB := NewDIB;
    FImageFormat := NewImageFormat;
    if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
    if FSaveStream <> nil then FreeAndNil(FSaveStream);
    FSaveStream := NewSaveStream;
  except
    Image.Free;
    raise;
  end;

  System.Threading.Monitor.Enter(BitmapImageLock);
    try
    FImage.Release;
    FImage := Image;
    FImage.Reference;
  finally
    System.Threading.Monitor.Exit(BitmapImageLock);
  end;
  FMaskValid := False;
end;

procedure TBitmap.ReadData(Stream: TStream);
var
  Size: Longint;
begin
  Stream.Read(Size, SizeOf(Size));
  ReadStream(Stream, Size);
end;

procedure TBitmap.ReadDIB(Stream: TStream; ImageSize: LongWord);
var
  BMHandle: HBITMAP;
  APalette: HPALETTE;
  DIB: TDIBSection;
  ImageFormat: TImageFormat;
  SaveStream: TMemoryStream;
  Image: System.Drawing.Bitmap;
begin
  // Load image from stream, create DIB from image
  Image := System.Drawing.Bitmap(System.Drawing.Image.FromStream(TStreamToCLRStream.GetStream(Stream)));
  InternalLoadFromBitmap(Image, BMHandle, APalette, DIB);
  ImageFormat := Image.RawFormat;
  Image.Dispose;

  // Preserve original stream
  SaveStream := TMemoryStream.Create;
  Stream.Position := Stream.Size - ImageSize;
  SaveStream.SetSize(ImageSize);
  SaveStream.CopyFrom(Stream, ImageSize);

  NewImage(BMHandle, APalette, DIB, ImageFormat, SaveStream);
  Changed(Self);
end;

procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
var
  DIB: TDIBSection;
  MemStream: TMemoryStream;
begin
  FreeContext;
  if Size = 0 then
    NewImage(0, 0, DIB)
  else
  begin
    // System.Drawing.Image always reads from the beginning of the
    // stream so we need to copy the stream into a temporary memory
    // stream before calling ReadDIB if Stream.Position isn't 0.
    if Stream.Position = 0 then
      ReadDIB(Stream, Size)
    else
    begin
      MemStream := TMemoryStream.Create;
      MemStream.SetSize(Size);
      MemStream.CopyFrom(Stream, Size);
      ReadDIB(MemStream, Size);
    end;
  end;
end;

procedure TBitmap.SetHandle(Value: HBITMAP);
var
  DIB: TDIBSection;
  APalette: HPALETTE;
begin
  with FImage do
    if FHandle <> Value then
    begin
      FreeContext;
      if Value <> 0 then
        GetObject(Value, Marshal.SizeOf(TypeOf(DIB)), DIB);
      if FRefCount = 1 then
      begin
        APalette := FPalette;
        FPalette := 0;
      end
      else
        if THandle(FPalette) = SystemPalette16.Handle then
          APalette := SystemPalette16.Handle
        else
          APalette := CopyPalette(FPalette);
      try
        NewImage(Value, APalette, DIB);
      except
        InternalDeletePalette(APalette);
        raise;
      end;
      Changed(Self);
    end;
end;

procedure TBitmap.SetHandleType(Value: TBitmapHandleType);
var
  DIB: TDIBSection;
  AHandle: HBITMAP;
  NewPalette: HPALETTE;
  DoCopy: Boolean;
begin
  if Value = GetHandleType then Exit;
  with FImage do
  begin
    if (FHandle = 0) and (FDIBHandle = 0) then
      if Value = bmDDB then
        FDIB.dsbmih.biSize := 0
      else
        FDIB.dsbmih.biSize := sizeof(FDIB.dsbmih)
    else
    begin
      if Value = bmDIB then
      begin
        if (FDIBHandle <> 0) and (FDIBHandle = FHandle) then Exit;
        FreeContext;
        PaletteNeeded;
        DIBNeeded;
        if FRefCount = 1 then
        begin
          AHandle := FDIBHandle;
          FDIBHandle := 0;
          NewPalette := FPalette;
          FPalette := 0;
          NewImage(AHandle, NewPalette, FDIB, FImageFormat);
        end
        else
          CopyImage(FDIBHandle, FPalette, FDIB);
      end
      else
      begin
        if (FHandle <> 0) and (FHandle <> FDIBHandle) then Exit;
        FreeContext;
        PaletteNeeded;
        DIB := FDIB;
        DIB.dsbmih.biSize := 0;   // flag to tell CopyBitmap to create a DDB
        DoCopy := FRefCount = 1;
        if DoCopy then
          NewPalette := FPalette
        else
          NewPalette := CopyPalette(FPalette);
        AHandle := CopyBitmap(FDIBHandle, FPalette, NewPalette, DIB, nil);
        if DoCopy then
          FHandle := AHandle
        else
          NewImage(AHandle, NewPalette, DIB, FImageFormat); 
      end;
      Changed(Self);
    end;
  end;
end;

procedure TBitmap.SetHeight(Value: Integer);
var
  DIB: TDIBSection;
begin
  with FImage do
    if FDIB.dsBm.bmHeight <> Value then
    begin
      HandleNeeded;
      DIB := FDIB;
      DIB.dsBm.bmHeight := Value;
      CopyImage(FHandle, FPalette, DIB); 
      Changed(Self);
    end;
end;

procedure TBitmap.SetPalette(Value: HPALETTE);
var
  AHandle: HBITMAP;
  DIB: TDIBSection;
begin
  if FImage.FPalette <> Value then
  begin
    with FImage do
      if (Value = 0) and (FRefCount = 1) then
      begin
        InternalDeletePalette(FPalette);
        FPalette := 0;
      end
      else
      begin
        FreeContext;
        HandleNeeded;
        DIB := FDIB;
        AHandle := CopyBitmap(FHandle, FPalette, Value, DIB, nil); 
        try
          NewImage(AHandle, Value, DIB);
        except
          DeleteObject(AHandle);
          raise;
        end;
      end;
    UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
    PaletteModified := True;
    Changed(Self);
  end;
end;

const
  BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);

procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
var
  DIB: TDIBSection;
  Pal: HPalette;
  DC: HDC;
  KillPal: Boolean;
begin
  if Value = GetPixelFormat then Exit;
  case Value of
    pfDevice:
      begin
        HandleType := bmDDB;
        Exit;
      end;
    pfCustom: InvalidGraphic(SInvalidPixelFormat);
  else
    DIB.dsbm := FImage.FDIB.dsbm;
    KillPal := False;
    with DIB, dsbm, dsbmih do
    begin
      bmBits := nil;
      biSize := sizeof(DIB.dsbmih);
      biWidth := bmWidth;
      biHeight := bmHeight;
      biPlanes := 1;
      biBitCount := BitCounts[Value];
      Pal := FImage.FPalette;
      case Value of
        // Copy Palette to prevent holding the same handle as SystemPalette16,
        // which would cause problems with the undetermined sequence of
        // finalizers in .NET
        pf4Bit: Pal := CopyPalette(SystemPalette16.Handle);
        pf8Bit:
          begin
            DC := GDICheck(GetDC(0));
            Pal := CreateHalftonePalette(DC);
            KillPal := True;
            ReleaseDC(0, DC);
          end;
        pf16Bit:
          begin
            biCompression := BI_BITFIELDS;
            dsBitFields[0] := $F800;
            dsBitFields[1] := $07E0;
            dsBitFields[2] := $001F;
          end;
      end;
      try
        CopyImage(Handle, Pal, DIB);
        PaletteModified := Pal <> 0;
      finally
        if KillPal then DeleteObject(Pal);
      end;
      Changed(Self);
    end;
  end;
end;

procedure TBitmap.SetImageFormat(Value: TImageFormat);
begin
  with FImage do
    if Value <> FImageFormat then
    begin
      FImageFormat := Value;
      FreeAndNil(FImage.FSaveStream);
    end;
end;

procedure TBitmap.SetMaskHandle(Value: HBITMAP);
begin
  with FImage do
    if FMaskHandle <> Value then
    begin
      FMaskHandle := Value;
      FMaskValid := True;
      FMaskBitsValid := True;
    end;
end;

procedure TBitmap.SetMonochrome(Value: Boolean);
var
  DIB: TDIBSection;
begin
  with FImage, FDIB.dsbmih do
    if Value <> ((biPlanes = 1) and (biBitCount = 1)) then
    begin
      HandleNeeded;
      DIB := FDIB;
      with DIB.dsbmih, DIB.dsbm do
      begin
        biSize := 0;   // request DDB handle
        biPlanes := Byte(Value);  // 0 = request screen BMP format
        biBitCount := Byte(Value);
        bmPlanes := Byte(Value);
        bmBitsPixel := Byte(Value);
      end;
      CopyImage(FHandle, FPalette, DIB); 
      Changed(Self);
    end;
end;

procedure TBitmap.SetTransparentColor(Value: TColor);
begin
  if Value <> FTransparentColor then
  begin
    if Value = clDefault then
      FTransparentMode := tmAuto else
      FTransparentMode := tmFixed;
    FTransparentColor := Value;
    if FImage.FRefCount > 1 then
    with FImage do
    begin
      HandleNeeded;
      CopyImage(FHandle, FPalette, FDIB); 
    end;
    Changed(Self);
  end;
end;

procedure TBitmap.SetTransparentMode(Value: TTransparentMode);
begin
  if Value <> FTransparentMode then
  begin
    if Value = tmAuto then
      SetTransparentColor(clDefault) else
      SetTransparentColor(GetTransparentColor);
  end;
end;

procedure TBitmap.SetWidth(Value: Integer);
var
  DIB: TDIBSection;
begin
  with FImage do
    if FDIB.dsBm.bmWidth <> Value then
    begin
      HandleNeeded;
      DIB := FDIB;
      DIB.dsBm.bmWidth := Value;
      CopyImage(FHandle, FPalette, DIB); 
      Changed(Self);
    end;
end;

procedure TBitmap.WriteData(Stream: TStream);
begin
  WriteStream(Stream, True);
end;

procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
var
  Size: DWORD; 
  MemStream: TMemoryStream;
  Format: TImageFormat;
  Bitmap: System.Drawing.Bitmap;
begin
  if FImage.FSaveStream <> nil then
  begin
    Size := FImage.FSaveStream.Size;
    if WriteSize then
      Stream.WriteBuffer(Size, SizeOf(Size));
    Stream.Write(FImage.FSaveStream.Memory, FImage.FSaveStream.Size);
    Exit;
  end;

  DIBNeeded;
  if FImage.FDIBHandle <> 0 then
  begin
    Bitmap := System.Drawing.Bitmap.FromHBitmap(IntPtr(FImage.FDIBHandle));

    if FImage.FImageFormat = nil then
      Format := System.Drawing.Imaging.ImageFormat.Bmp
    else
      Format := FImage.FImageFormat;

    if WriteSize then
    begin
      MemStream := TMemoryStream.Create;
      Bitmap.Save(TStreamToCLRStream.GetStream(MemStream), Format);
      Size := MemStream.Size;
      Stream.WriteBuffer(Size, SizeOf(Size));
      Stream.Write(MemStream.Memory, MemStream.Size);
    end
    else
      Bitmap.Save(TStreamToCLRStream.GetStream(Stream), Format);
  end;
end;

{ ReleaseHandle gives up ownership of the bitmap handle the TBitmap contains. }
function TBitmap.ReleaseHandle: HBITMAP;
begin
  HandleNeeded;
  Changing(Self);
  with FImage do
  begin
    Result := FHandle;
    if FHandle = FDIBHandle then
    begin
      FDIBHandle := 0;
      FDIB.dsbm.bmBits := nil;
    end;
    FHandle := 0;
  end;
end;

function TBitmap.ReleaseMaskHandle: HBITMAP;
begin
  Result := GetMaskHandle;
  FImage.FMaskHandle := 0;
end;

function TBitmap.ReleasePalette: HPALETTE;
begin
  HandleNeeded;
  Changing(Self);
  Result := FImage.FPalette;
  FImage.FPalette := 0;
end;

procedure TBitmap.SaveToStream(Stream: TStream);
begin
  WriteStream(Stream, False);
end;

                                                      
procedure TBitmap.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
var
  DIB: TDIBSection;
begin
  AFormat := CF_BITMAP;
  HandleNeeded;
  with FImage do
  begin
    DIB := FDIB;
    DIB.dsbmih.biSize := 0;   // copy to device bitmap
    DIB.dsbm.bmBits := nil;
    AData := CopyBitmap(FHandle, FPalette, FPalette, DIB, FCanvas);
  end;
  try
    APalette := CopyPalette(FImage.FPalette);
  except
    DeleteObject(AData);
    raise;
  end;
end;

function TBitmap.TransparentColorStored: Boolean;
begin
  Result := FTransparentMode = tmFixed;
end;

{ TIconImage }

destructor TIconImage.Destroy;
begin
  FMemoryImage.Free;
  if Assigned(FIcon) then
    FIcon.Free;
  inherited Destroy;
end;

procedure TIconImage.FreeHandle;
begin
  if Assigned(FIcon) then
    FreeAndNil(FIcon);
end;

{ TIcon }

constructor TIcon.Create;
begin
  inherited Create;
  FTransparent := True;
  FImage := TIconImage.Create;
  FImage.Reference;
end;

destructor TIcon.Destroy;
begin
  FImage.Release;
  inherited Destroy;
end;

procedure TIcon.Assign(Source: TPersistent);
begin
  if (Source = nil) or (Source is TIcon) then
  begin
    if Source <> nil then
    begin
      TIcon(Source).FImage.Reference;
      FImage.Release;
      FImage := TIcon(Source).FImage;
    end
    else
      NewImage(nil, nil);
    Changed(Self);
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
  with Rect do
  begin
    ACanvas.RequiredState([csHandleValid]);
    DrawIconEx(ACanvas.FHandle, Left, Top, Handle, 0, 0, 0, 0, DI_NORMAL);
  end;
end;

function TIcon.GetEmpty: Boolean;
begin
  with FImage do
    Result := (not Assigned(FIcon)) and (FMemoryImage = nil);
end;

function TIcon.GetHandle: HICON;
begin
  HandleNeeded;
  if Assigned(FImage.FIcon) then
    Result := HICON(FImage.FIcon.Handle)
  else
    Result := 0;
end;

function TIcon.HandleAllocated: Boolean;
begin
  Result := Assigned(FImage) and Assigned(FImage.FIcon) and
    (FImage.FIcon.Handle <> nil);
end;

function TIcon.GetHeight: Integer;
begin
  Result := FImage.FSize.y;
  if Result = 0 then
    Result := GetSystemMetrics(SM_CYICON)
end;

function TIcon.GetWidth: Integer;
begin
  Result := FImage.FSize.X;
  if Result = 0 then
    Result := GetSystemMetrics(SM_CXICON);
end;

procedure TIcon.HandleNeeded;
var
  IconType: Word;
  NewIcon: System.Drawing.Icon;
begin
  NewIcon := nil;
  with FImage do
  begin
    if Assigned(FIcon) then Exit;
    if FMemoryImage = nil then Exit;
    FMemoryImage.Position := 0;
    IconType := GetStoredIconType(FMemoryImage);
    case IconType of
      RC3_STOCKICON: NewIcon := System.Drawing.Icon.FromHandle(IntPtr(StockIcon));
      RC3_ICON: NewIcon := System.Drawing.Icon.Create(TStreamToCLRStream.GetStream(FMemoryImage));
    else
      InvalidIcon;
    end;
    FIcon := NewIcon;
  end;
end;

procedure TIcon.ImageNeeded;
var
  Image: TMemoryStream;
begin
  with FImage do
  begin
    if FMemoryImage <> nil then Exit;
    if (not Assigned(FIcon)) or (Assigned(FIcon) and (FIcon.Handle = nil)) then
      InvalidIcon;
    Image := TMemoryStream.Create;
    try
      if GetHandle = StockIcon then
      begin
        // Stream out blank TCursorOrIcon structure
        Image.WriteBuffer(0, SizeOf(Word)); // TCursorOrIcon.Reserved
        Image.WriteBuffer(0, SizeOf(Word)); // TCursorOrIcon.wType
        Image.WriteBuffer(0, SizeOf(Word)); // TCursorOrIcon.Count
      end
      else
        FIcon.Save(TStreamToCLRStream.GetStream(Image));
    except
      Image.Free;
      raise;
    end;
    FMemoryImage := Image;
  end;
end;

procedure TIcon.LoadFromResourceID(Instance: THandle; ResID: Integer);
begin
  SetHandle(LoadIcon(Instance, ResID));
end;

procedure TIcon.LoadFromResourceName(const ResName, BaseName: String;
  ResourceAssembly: Assembly; Culture: CultureInfo);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(BaseName, ResourceAssembly);
  NewImage(System.Drawing.Icon(ResMgr.GetObject(ResName, Culture)), nil);
end;

procedure TIcon.LoadFromResourceName(const ResName, BaseName: String;
  ResourceAssembly: Assembly; ResourceSet: System.Type; Culture: CultureInfo = nil);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(BaseName, ResourceAssembly, ResourceSet);
  NewImage(System.Drawing.Icon(ResMgr.GetObject(ResName, Culture)), nil);
end;

procedure TIcon.LoadFromResourceName(const ResName: String;
  AType: System.Type; Culture: CultureInfo);
var
  ResMgr: ResourceManager;
begin
  ResMgr := ResourceManager.Create(AType);
  NewImage(System.Drawing.Icon(ResMgr.GetObject(ResName, Culture)), nil);
end;

procedure TIcon.LoadFromResourceName(Instance: THandle; const ResName: String);
begin
  SetHandle(LoadIcon(Instance, ResName));
end;

procedure TIcon.LoadFromStream(Stream: TStream);
var
  IconType: Word;
  Image: TMemoryStream;
begin
  Image := TMemoryStream.Create;
  try
    Image.SetSize(Stream.Size - Stream.Position);
    Stream.ReadBuffer(Image.Memory, Image.Size);
    IconType := GetStoredIconType(Image);
    if not (IconType in [RC3_STOCKICON, RC3_ICON]) then
      InvalidIcon;
    NewImage(nil, Image);
  except
    Image.Free;
    raise;
  end;
  Changed(Self);
end;

procedure TIcon.NewImage(NewIcon: System.Drawing.Icon; NewImage: TMemoryStream);
var
  Image: TIconImage;
begin
  Image := TIconImage.Create;
  try
    Image.FIcon := NewIcon;
    Image.FMemoryImage := NewImage;
  except
    Image.Free;
    raise;
  end;
  Image.Reference;
  FImage.Release;
  FImage := Image;
end;

function TIcon.ReleaseHandle: HICON;
begin
  with FImage do
  begin
    if FRefCount > 1 then
      NewImage(System.Drawing.Icon(FIcon.Clone), nil);
    // Return copy of icon since the original will be destroyed
    // when the icon object is freed.
    Result := CopyIcon(HICON(FIcon.Handle));
    FIcon.Free;
    FIcon := nil;
  end;
  Changed(Self);
end;

procedure TIcon.SetHandle(Value: HICON);
begin
  if Value = 0 then
    NewImage(nil, nil)
  else
    NewImage(System.Drawing.Icon.FromHandle(IntPtr(Value)), nil);
  Changed(Self);
end;

procedure TIcon.SetHeight(Value: Integer);
begin
  if not Assigned(FImage.FIcon) then
    FRequestedSize.Y := Value
  else
    InvalidOperation(SChangeIconSize);
end;

procedure TIcon.SetTransparent(Value: Boolean);
begin
  // Ignore assignments to this property.
  // Icons are always transparent.
end;

procedure TIcon.SetWidth(Value: Integer);
begin
  if not Assigned(FImage.FIcon) then
    FRequestedSize.X := Value
  else
    InvalidOperation(SChangeIconSize);
end;

procedure TIcon.SaveToStream(Stream: TStream);
begin
  ImageNeeded;
  with FImage.FMemoryImage do Stream.WriteBuffer(Memory, Size);
end;

procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
begin
  InvalidOperation(SIconToClipboard);
end;

procedure TIcon.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
begin
  InvalidOperation(SIconToClipboard);
end;


function GraphicFilter(GraphicClass: TGraphicClass): string;
var
  Filters: string;
begin
  GetFileFormats.BuildFilterStrings(GraphicClass, Result, Filters);
end;

function GraphicExtension(GraphicClass: TGraphicClass): string;
var
  I: Integer;
begin
  for I := GetFileFormats.Count-1 downto 0 do
    if TFileFormat(FileFormats[I]).GraphicClass.ClassName = GraphicClass.ClassName then
    begin
      Result := TFileFormat(FileFormats[I]).Extension;
      Exit;
    end;
  Result := '';
end;

function GraphicFileMask(GraphicClass: TGraphicClass): string;
var
  Descriptions: string;
begin
  GetFileFormats.BuildFilterStrings(GraphicClass, Descriptions, Result);
end;

procedure InitScreenLogPixels;
const
  Pal16: array [0..15] of TColor =
    (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clDkGray,
     clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
var
  DC: HDC;
begin
  DC := GetDC(0);
  ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0,DC);
                           
//!!  SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
  SystemPalette16 := TResHandleWrapper.Create;
  SystemPalette16.Handle := CreateSystemPalette(Pal16);
end;

function GetDefFontCharSet: TFontCharSet;
var
  DisplayDC: HDC;
  TxtMetric: TTEXTMETRIC;
begin
  Result := DEFAULT_CHARSET;
  DisplayDC := GetDC(0);
  if (DisplayDC <> 0) then
  begin
    if (SelectObject(DisplayDC, StockFont) <> 0) then
      if (GetTextMetrics(DisplayDC, TxtMetric)) then
        Result := TxtMetric.tmCharSet;
    ReleaseDC(0, DisplayDC);
  end;
end;

procedure InitDefFontData;
var
  Reg: TRegistry;
  FName: string;
begin
  DefFontData := TFontData.Create;
  DefFontData.Pitch := fpDefault;
  DefFontData.CharSet := DEFAULT_CHARSET;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows NT\CurrentVersion\FontSubstitutes') then { do not localize }
    begin
      FName := Reg.ReadString('MS Shell Dlg 2'); { do not localize }
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  if FName <> '' then
    DefFontData.Name := FName
  else
    DefFontData.Name := 'MS Sans Serif'; { do not localize }
  DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  DefFontData.Orientation := 0; { No rotation }
end;

type
  TPattern = class
    Next: TPattern;
    Bitmap: TBitmap;
    BkColorRef: TColorRef;
    FgColorRef: TColorRef;
  end;

  TPatternManager = class(TObject)
  private
    List: TPattern;
    function CreateBitmap(BkColor, FgColor: TColor): TBitmap;
  public
    function AllocPattern(BkColor, FgColor: TColorRef): TPattern;
    procedure Lock;
    procedure Unlock;
  end;

procedure TPatternManager.Lock;
begin
  System.Threading.Monitor.Enter(Self);
end;

procedure TPatternManager.Unlock;
begin
  System.Threading.Monitor.Exit(Self);
end;

function TPatternManager.AllocPattern(BkColor, FgColor: TColorRef): TPattern;
begin
  Lock;
  try
    Result := List;
    while (Result <> nil) and ((Result.BkColorRef <> BkColor) or
      (Result.FgColorRef <> FgColor)) do
      Result := Result.Next;
    if Result = nil then
    begin
      Result := TPattern.Create;
      with Result do
      begin
        Next := List;
        Bitmap := CreateBitmap(BkColor, FgColor);
        BkColorRef := BkColor;
        FgColorRef := FgColor;
      end;
      List := Result;
    end;
  finally
    Unlock;
  end;
end;

function TPatternManager.CreateBitmap(BkColor, FgColor: TColor): TBitmap;
var
  X, Y: Integer;
begin
  Result := TBitmap.Create;
  try
    with Result do
    begin
      Width := 8;
      Height := 8;
      with Canvas do
      begin
        Brush.Style := bsSolid;
        Brush.Color := BkColor;
        FillRect(Rect(0, 0, Width, Height));
        for Y := 0 to 8 do
          for X := 0 to 8 do
            if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }
              Pixels[X, Y] := FgColor;     { on even/odd rows }
      end;
      Dormant;
    end;
  except
    Result.Free;
    raise;
  end;
end;

var
  PatternManager: TPatternManager;


function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
begin
  if PatternManager <> nil then
    Result := PatternManager.AllocPattern(ColorToRGB(BkColor),
      ColorToRGB(FgColor)).Bitmap
    else
      Result := nil;
end;

initialization
  InitScreenLogPixels;
  BitmapImageLock := TObject.Create;
  StockPen := GetStockObject(BLACK_PEN);
  StockBrush := GetStockObject(HOLLOW_BRUSH);
  StockFont := GetStockObject(SYSTEM_FONT);
  StockIcon := LoadIcon(0, IDI_APPLICATION);
  InitDefFontData;
  FontManager := TResourceManager.Create;
  PenManager := TResourceManager.Create;
  BrushManager := TResourceManager.Create;
  PatternManager := TPatternManager.Create;
  BitmapCanvasList := TThreadList.Create;
  CanvasList := TThreadList.Create;
  RegisterIntegerConsts(TypeOf(TColor), IdentToColor, ColorToIdent);
  RegisterIntegerConsts(TypeOf(TFontCharset), IdentToCharset, CharsetToIdent);

// Finalization section may not execute on all platforms
finalization
  PatternManager.Free;
  FileFormats.Free;
  ClipboardFormats.Free;
  BitmapCanvasList.Free;
  CanvasList.Free;
  FontManager.Free;
  PenManager.Free;
  BrushManager.Free;
  BitmapImageLock.Free;
  SystemPalette16.Free;
end.
