登录 用户中心() [退出] 后台管理 注册
   
您的位置: 首页 首页 >> CLQ工作室开源代码 >> CLQ工作室开源代码 >> 主题: [dephi7]修改后的 Graphics.pas 目前是支持超大文件和图片格式自动检测    [最新]
标题
[dephi7]修改后的 Graphics.pas 目前是支持超大文件和图片格式自动检测
clq
浏览(3) - 2018-07-21 13:19:40 发表 编辑

关键字:

[2018-07-21 13:20:31 最后更新]
[dephi7]修改后的 Graphics.pas 目前是支持超大文件和图片格式自动检测

原理超大文件的原理解析为:
//clq CreateCompatibleBitmap 在 xp 下使用系统内存,有限制
//from http://blog.csdn.net/bagboy_taobao_com/article/details/8332642

而格式自动判断其实是先读取文件的前几个字节,现在的浏览器基本上都有这种功能。
文件内容见回复,以后可能还会更新。



clq
2018-07-21 13:20:31 发表 编辑


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

unit Graphics;

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

interface

{$IFDEF MSWINDOWS}
uses Windows,
{$ENDIF}
{$IFDEF LINUX}
uses WinUtils, Libc, Windows,
{$ENDIF}
SysUtils, Classes;

{ Graphics Objects }

type
  PColor = ^TColor;
  TColor = -$7FFFFFFF-1..$7FFFFFFF;
  {$NODEFINE TColor}

  (*$HPPEMIT 'namespace Graphics'*)
  (*$HPPEMIT '{'*)
  (*$HPPEMIT '  enum TColor {clMin=-0x7fffffff-1, clMax=0x7fffffff};'*)
  (*$HPPEMIT '}'*)


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);

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;

  {$EXTERNALSYM HMETAFILE}
  HMETAFILE = THandle;
  {$EXTERNALSYM HENHMETAFILE}
  HENHMETAFILE = THandle;

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

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

  TResData = record
    Handle: THandle;
  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[LF_FACESIZE - 1];
  {$NODEFINE TFontDataName}
  TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  {$NODEFINE TFontStyle}
  TFontStyles = set of TFontStyle;
  TFontStylesBase = set of TFontStyle;
  {$NODEFINE TFontStylesBase}

  (*$HPPEMIT 'namespace Graphics'*)
  (*$HPPEMIT '{'*)
  (*$HPPEMIT '  enum TFontStyle { fsBold, fsItalic, fsUnderline, fsStrikeOut };'*)
  (*$HPPEMIT '  typedef SmallStringBase<31> TFontDataName;'*)
  (*$HPPEMIT '  typedef SetBase<TFontStyle, fsBold, fsStrikeOut> TFontStylesBase;'*)
  (*$HPPEMIT '}'*)

  TFontData = record
    Handle: HFont;
    Height: Integer;
    Pitch: TFontPitch;
    Style: TFontStylesBase;
    Charset: TFontCharset;
    Name: TFontDataName;
  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 = record
    Handle: HPen;
    Color: TColor;
    Width: Integer;
    Style: TPenStyle;
  end;

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

  TBrushData = record
    Handle: HBrush;
    Color: TColor;
    Bitmap: TBitmap;
    Style: TBrushStyle;
  end;

  PResource = ^TResource;
  TResource = record
    Next: PResource;
    RefCount: Integer;
    Handle: THandle;
    HashCode: Word;
    case Integer of
      0: (Data: TResData);
      1: (Font: TFontData);
      2: (Pen: TPenData);
      3: (Brush: TBrushData);
  end;

  TGraphicsObject = class(TPersistent)
  private
    FOnChange: TNotifyEvent;
    FResource: PResource;
    FOwnerLock: PRTLCriticalSection;
  protected
    procedure Changed; dynamic;
    procedure Lock;
    procedure Unlock;
  public
    function HandleAllocated: Boolean;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OwnerCriticalSection: PRTLCriticalSection 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;
    procedure GetData(var FontData: TFontData);
    procedure SetData(const FontData: TFontData);
  protected
    procedure Changed; override;
    function GetHandle: HFont;
    function GetHeight: Integer;
    function GetName: TFontName;
    function GetPitch: TFontPitch;
    function GetSize: Integer;
    function GetStyle: TFontStyles;
    function GetCharset: TFontCharset;
    procedure SetColor(Value: TColor);
    procedure SetHandle(Value: HFont);
    procedure SetHeight(Value: Integer);
    procedure SetName(const Value: TFontName);
    procedure SetPitch(Value: TFontPitch);
    procedure SetSize(Value: Integer);
    procedure SetStyle(Value: TFontStyles);
    procedure SetCharset(Value: TFontCharset);
  public
    constructor Create;
    destructor Destroy; override;
    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 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;
    procedure GetData(var PenData: TPenData);
    procedure SetData(const 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;
    destructor Destroy; override;
    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
    procedure GetData(var BrushData: TBrushData);
    procedure SetData(const 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;
    destructor Destroy; override;
    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;

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

  TCopyMode = Longint;

  TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  TCanvasState = set of TCanvasStates;
  TCanvasOrientation = (coLeftToRight, coRightToLeft);

  TCanvas = class(TPersistent)
  private
    FHandle: HDC;
    State: TCanvasState;
    FFont: TFont;
    FPen: TPen;
    FBrush: TBrush;
    FPenPos: TPoint;
    FCopyMode: TCopyMode;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    FLock: TRTLCriticalSection;
    FLockCount: Integer;
    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(Rect: TRect; X, Y: Integer; const Text: string);
    function TextWidth(const Text: string): Integer;
    function TryLock: Boolean;
    procedure Unlock;
    property ClipRect: TRect read GetClipRect;
    property Handle: HDC read GetHandle write SetHandle;
    property LockCount: Integer read FLockCount;
    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: Integer; 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 *)
  }

  TMetafileCanvas = class(TCanvas)
  private
    FMetafile: TMetafile;
  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;
  protected
    procedure Reference;
    procedure Release;
    procedure FreeHandle; virtual; abstract;
    property RefCount: Integer read FRefCount;
  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 }

  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
    FOS2Format: Boolean;  // Write BMP file header, color table in OS/2 format
    FHalftone: Boolean;   // FPalette is halftone; don't write to file
  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 GetMaskHandle: HBITMAP; virtual;
    function GetMonochrome: Boolean;
    function GetPixelFormat: TPixelFormat;
    function GetScanline(Row: Integer): Pointer;
    function GetTransparentColor: TColor;
    procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
      const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
    procedure ReadStream(Stream: TStream; Size: Longint);
    procedure ReadDIB(Stream: TStream; ImageSize: LongWord; bmf: PBitmapFileHeader = nil);
    procedure SetHandle(Value: HBITMAP);
    procedure SetHandleType(Value: TBitmapHandleType); virtual;
    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 LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String);
{$IFDEF MSWINDOWS}
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
{$ENDIF}
    procedure Mask(TransparentColor: TColor);
    function ReleaseHandle: HBITMAP;
    function ReleaseMaskHandle: HBITMAP;
    function ReleasePalette: HPALETTE;
    procedure SaveToClipboardFormat(var Format: Word; var Data: 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 MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
    property Monochrome: Boolean read GetMonochrome write SetMonochrome;
    property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
    property ScanLine[Row: Integer]: Pointer 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
    FHandle: HICON;
    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(NewHandle: HICON; 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 LoadFromStream(Stream: TStream); override;
    function ReleaseHandle: HICON;
    procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    property Handle: HICON read GetHandle write SetHandle;
  end;

var    // New TFont instances are intialized with the values in this structure:
  DefFontData: TFontData = (
    Handle: 0;
    Height: 0;
    Pitch: fpDefault;
    Style: [];
    Charset : DEFAULT_CHARSET;
    Name: 'MS Sans Serif');

var
  SystemPalette16: HPalette; // 16 color palette that maps to the system palette

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; var BitmapInfo; var Bits): 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 CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateMappedRes(Instance: THandle; ResName: PChar; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;

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;

//clq
type
  PFileFormat = ^TFileFormat;
  TFileFormat = record
    GraphicClass: TGraphicClass;
    Extension: string;
    Description: string;
    DescResID: Integer;
  end;

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

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

implementation

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

uses Consts;

const
  csAllValid = [csHandleValid..csBrushValid];

var
  ScreenLogPixels: Integer;
  StockPen: HPEN;
  StockBrush: HBRUSH;
  StockFont: HFONT;
  StockIcon: HICON;
  BitmapImageLock: TRTLCriticalSection;
  CounterLock: TRTLCriticalSection;

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

{ Resource managers }

const
  ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);

type
  TResourceManager = class(TObject)
    ResList: PResource;
    FLock: TRTLCriticalSection;
    ResDataSize: Word;
    constructor Create(AResDataSize: Word);
    destructor Destroy; override;
    function AllocResource(const ResData): PResource;
    procedure FreeResource(Resource: PResource);
    procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
    procedure AssignResource(GraphicsObject: TGraphicsObject;
      AResource: PResource);
    procedure Lock;
    procedure Unlock;
  end;

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

function GetHashCode(const Buffer; Count: Integer): Word; assembler;
asm
        MOV     ECX,EDX
        MOV     EDX,EAX
        XOR     EAX,EAX
@@1:    ROL     AX,5
        XOR     AL,[EDX]
        INC     EDX
        DEC     ECX
        JNE     @@1
end;

constructor TResourceManager.Create(AResDataSize: Word);
begin
  ResDataSize := AResDataSize;
  InitializeCriticalSection(FLock);
end;

destructor TResourceManager.Destroy;
begin
  DeleteCriticalSection(FLock);
end;

procedure TResourceManager.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TResourceManager.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

function TResourceManager.AllocResource(const ResData): PResource;
var
  ResHash: Word;
begin
  ResHash := GetHashCode(ResData, ResDataSize);
  Lock;
  try
    Result := ResList;
    while (Result <> nil) and ((Result^.HashCode <> ResHash) or
      not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
      Result := Result^.Next;
    if Result = nil then
    begin
      GetMem(Result, ResDataSize + ResInfoSize);
      with Result^ do
      begin
        Next := ResList;
        RefCount := 0;
        Handle := TResData(ResData).Handle;
        HashCode := ResHash;
        Move(ResData, Data, ResDataSize);
      end;
      ResList := Result;
    end;
    Inc(Result^.RefCount);
  finally
    Unlock;
  end;
end;

procedure TResourceManager.FreeResource(Resource: PResource);
var
  P: PResource;
  DeleteIt: Boolean;
begin
  if Resource <> nil then
    with Resource^ do
    begin
      Lock;
      try
        Dec(RefCount);
        DeleteIt := RefCount = 0;
        if DeleteIt then
        begin
          if Resource = ResList then
            ResList := Resource^.Next
          else
          begin
            P := ResList;
            while P^.Next <> Resource do P := P^.Next;
            P^.Next := Resource^.Next;
          end;
        end;
      finally
        Unlock;
      end;
      if DeleteIt then
      begin  // this is outside the critsect to minimize lock time
        if Handle <> 0 then DeleteObject(Handle);
        FreeMem(Resource);
      end;
    end;
end;

procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  const ResData);
var
  P: PResource;
begin
  Lock;
  try  // prevent changes to GraphicsObject.FResource pointer between steps
    P := GraphicsObject.FResource;
    GraphicsObject.FResource := AllocResource(ResData);
    if GraphicsObject.FResource <> P then GraphicsObject.Changed;
    FreeResource(P);
  finally
    Unlock;
  end;
end;

procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  AResource: PResource);
var
  P: PResource;
begin
  Lock;
  try
    P := GraphicsObject.FResource;
    if P <> AResource then
    begin
      Inc(AResource^.RefCount);
      GraphicsObject.FResource := AResource;
      GraphicsObject.Changed;
      FreeResource(P);
    end;
  finally
    Unlock;
  end;
end;

var
  CanvasList: TThreadList;

procedure PaletteChanged;

  procedure ClearColor(ResMan: TResourceManager);
  var
    Resource: PResource;
  begin
    ResMan.Lock;
    try
      Resource := ResMan.ResList;
      while Resource <> nil do
      begin
        with Resource^ do
        { Assumes Pen.Color and Brush.Color share the same location }
          if (Handle <> 0) and (Pen.Color < 0) then
          begin
            DeleteObject(Handle);
            Handle := 0;
          end;
        Resource := Resource^.Next;
      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 TCanvas(Items[I]) 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%.8x', [HexDisplayPrefix, Color]);
end;

function StringToColor(const S: string): TColor;
begin
  if not IdentToColor(S, Longint(Result)) then
    Result := TColor(StrToInt(S));
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 EnterCriticalSection(FOwnerLock^);
end;

procedure TGraphicsObject.Unlock;
begin
  if Assigned(FOwnerLock) then LeaveCriticalSection(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 GetFontData(Font: HFont): TFontData;
var
  LogFont: TLogFont;
begin
  Result := DefFontData;
  if Font <> 0 then
  begin
    if GetObject(Font, SizeOf(LogFont), @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;
      Handle := Font;
    end;
  end;
end;

constructor TFont.Create;
begin
  DefFontData.Handle := 0;
  FResource := FontManager.AllocResource(DefFontData);
  FColor := clWindowText;
  FPixelsPerInch := ScreenLogPixels;
end;

destructor TFont.Destroy;
begin
  FontManager.FreeResource(FResource);
end;

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

procedure TFont.Assign(Source: TPersistent);
begin
  if Source is TFont then
  begin
    Lock;
    try
      TFont(Source).Lock;
      try
        FontManager.AssignResource(Self, TFont(Source).FResource);
        Color := TFont(Source).Color;
        if PixelsPerInch <> TFont(Source).PixelsPerInch then
          Size := TFont(Source).Size;
      finally
        TFont(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TFont.GetData(var FontData: TFontData);
begin
  FontData := FResource^.Font;
  FontData.Handle := 0;
end;

procedure TFont.SetData(const FontData: TFontData);
begin
  Lock;
  try
    FontManager.ChangeResource(Self, FontData);
  finally
    Unlock;
  end;
end;

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

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

procedure TFont.SetHandle(Value: HFont);
begin
  SetData(GetFontData(Value));
end;

function TFont.GetHeight: Integer;
begin
  Result := FResource^.Font.Height;
end;

procedure TFont.SetHeight(Value: Integer);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Height := Value;
  SetData(FontData);
end;

function TFont.GetName: TFontName;
begin
  Result := FResource^.Font.Name;
end;

procedure TFont.SetName(const Value: TFontName);
var
  FontData: TFontData;
begin
  if Value <> '' then
  begin
    GetData(FontData);
    FillChar(FontData.Name, SizeOf(FontData.Name), 0);
    FontData.Name := Value;
    SetData(FontData);
  end;
end;

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

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

function TFont.GetStyle: TFontStyles;
begin
  Result := FResource^.Font.Style;
end;

procedure TFont.SetStyle(Value: TFontStyles);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Style := Value;
  SetData(FontData);
end;

function TFont.GetPitch: TFontPitch;
begin
  Result := FResource^.Font.Pitch;
end;

procedure TFont.SetPitch(Value: TFontPitch);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Pitch := Value;
  SetData(FontData);
end;

function TFont.GetCharset: TFontCharset;
begin
  Result := FResource^.Font.Charset;
end;

procedure TFont.SetCharset(Value: TFontCharset);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Charset := Value;
  SetData(FontData);
end;

{ TPen }

const
  DefPenData: TPenData = (
    Handle: 0;
    Color: clBlack;
    Width: 1;
    Style: psSolid);

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

destructor TPen.Destroy;
begin
  PenManager.FreeResource(FResource);
end;

procedure TPen.Assign(Source: TPersistent);
begin
  if Source is TPen then
  begin
    Lock;
    try
      TPen(Source).Lock;
      try
        PenManager.AssignResource(Self, TPen(Source).FResource);
        SetMode(TPen(Source).FMode);
      finally
        TPen(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TPen.GetData(var PenData: TPenData);
begin
  PenData := FResource^.Pen;
  PenData.Handle := 0;
end;

procedure TPen.SetData(const PenData: TPenData);
begin
  Lock;
  try
    PenManager.ChangeResource(Self, PenData);
  finally
    Unlock;
  end;
end;

function TPen.GetColor: TColor;
begin
  Result := FResource^.Pen.Color;
end;

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

function TPen.GetHandle: HPen;
const
  PenStyles: array[TPenStyle] of Word =
    (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
     PS_INSIDEFRAME);
var
  LogPen: TLogPen;
begin
  with FResource^ do
  begin
    if Handle = 0 then
    begin
      PenManager.Lock;
      with LogPen do
      try
        if Handle = 0 then
        begin
          lopnStyle := PenStyles[Pen.Style];
          lopnWidth.X := Pen.Width;
          lopnColor := ColorToRGB(Pen.Color);
          Handle := CreatePenIndirect(LogPen);
        end;
      finally
        PenManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TPen.SetHandle(Value: HPen);
var
  PenData: TPenData;
begin
  PenData := DefPenData;
  PenData.Handle := Value;
  SetData(PenData);
end;

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

function TPen.GetStyle: TPenStyle;
begin
  Result := FResource^.Pen.Style;
end;

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

function TPen.GetWidth: Integer;
begin
  Result := FResource^.Pen.Width;
end;

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

{ TBrush }

const
  DefBrushData: TBrushData = (
    Handle: 0;
    Color: clWhite;
    Bitmap: nil;
    Style: bsSolid);

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

destructor TBrush.Destroy;
begin
  BrushManager.FreeResource(FResource);
end;

procedure TBrush.Assign(Source: TPersistent);
begin
  if Source is TBrush then
  begin
    Lock;
    try
      TBrush(Source).Lock;
      try
        BrushManager.AssignResource(Self, TBrush(Source).FResource);
      finally
        TBrush(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TBrush.GetData(var BrushData: TBrushData);
begin
  BrushData := FResource^.Brush;
  BrushData.Handle := 0;
  BrushData.Bitmap := nil;
end;

procedure TBrush.SetData(const BrushData: TBrushData);
begin
  Lock;
  try
    BrushManager.ChangeResource(Self, BrushData);
  finally
    Unlock;
  end;
end;

function TBrush.GetBitmap: TBitmap;
begin
  Result := FResource^.Brush.Bitmap;
end;

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

function TBrush.GetColor: TColor;
begin
  Result := FResource^.Brush.Color;
end;

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

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

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

function TBrush.GetStyle: TBrushStyle;
begin
  Result := FResource^.Brush.Style;
end;

procedure TBrush.SetStyle(Value: TBrushStyle);
var
  BrushData: TBrushData;
begin
  GetData(BrushData);
  BrushData.Style := Value;
  if BrushData.Style = bsClear then BrushData.Color := clWhite;
  SetData(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;

{ TCanvas }

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

destructor TCanvas.Destroy;
begin
  CanvasList.Remove(Self);
  SetHandle(0);
  FFont.Free;
  FPen.Free;
  FBrush.Free;
  DeleteCriticalSection(FLock);
  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;

procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  const Source: TRect; Color: TColor);
const
  ROP_DSPDxax = $00E20746;
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;

procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  FillStyle: TFillStyle);
const
  FillStyles: array[TFillStyle] of Word =
    (FLOODFILLSURFACE, FLOODFILLBORDER);
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
  EnterCriticalSection(CounterLock);
  Inc(FLockCount);
  LeaveCriticalSection(CounterLock);
  EnterCriticalSection(FLock);
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;

type
  PPoints = ^TPoints;
  TPoints = array[0..0] of TPoint;

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

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

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

procedure TCanvas.PolyBezierTo(const Points: array of TPoint);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  Windows.PolyBezierTo(FHandle, PPoints(@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, PChar(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, PChar(Text),
    Length(Text), nil);
  Changed;
end;

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

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

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

function TCanvas.TryLock: Boolean;
begin
  EnterCriticalSection(CounterLock);
  try
    Result := FLockCount = 0;
    if Result then Lock;
  finally
    LeaveCriticalSection(CounterLock);
  end;
end;

procedure TCanvas.Unlock;
begin
  LeaveCriticalSection(FLock);
  EnterCriticalSection(CounterLock);
  Dec(FLockCount);
  LeaveCriticalSection(CounterLock);
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.CreateRes(@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;

procedure TCanvas.CreatePen;
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);
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 = $CDD7;

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

{ Exception routines }

procedure InvalidOperation(Str: PResStringRec);
begin
  raise EInvalidGraphicOperation.CreateRes(Str);
end;

procedure InvalidGraphic(Str: PResStringRec);
begin
  raise EInvalidGraphic.CreateRes(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;
var
  ErrorCode: Integer;
  Buf: array [Byte] of Char;
begin
  ErrorCode := GetLastError;
  if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
    ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
    raise EOutOfResources.Create(Buf)
  else
    OutOfResources;
end;

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





//clq CreateCompatibleBitmap 在 xp 下使用系统内存,有限制
//from http://blog.csdn.net/bagboy_taobao_com/article/details/8332642
function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP;// stdcall;
var
  bmih:BITMAPINFOHEADER;
  bmi:BITMAPINFO;
  bitMap:HBITMAP;
  p: Pointer;
begin
  //Result := windows.CreateCompatibleBitmap(DC, Width, Height);


  //memset(&bmih, 0, sizeof(BITMAPINFOHEADER));
  FillChar(bmih, 0, sizeof(BITMAPINFOHEADER));

  bmih.biSize := sizeof(BITMAPINFOHEADER);
  bmih.biBitCount := 24;
  bmih.biCompression := BI_RGB;
  bmih.biPlanes := 1;
  bmih.biWidth := Width;
  bmih.biHeight := Height;

  //memset(&bmi, 0, sizeof(BITMAPINFO));
  FillChar(bmi, 0, sizeof(BITMAPINFO));
  bmi.bmiHeader := bmih;

  //void* p; //据说这里生成的 p 指针会自动释放//可以直接写入像素?
  bitMap := CreateDIBSection(DC, bmi, DIB_RGB_COLORS, p, 0, 0);

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

  //--------------------------------------------------
  Result := bitMap;


end;




function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
var
  DC, Mem1, Mem2: HDC;
  Old1, Old2: HBITMAP;
  Bitmap: Windows.TBitmap;
begin
  Mem1 := CreateCompatibleDC(0);
  Mem2 := CreateCompatibleDC(0);

  try
    GetObject(Src, SizeOf(Bitmap), @Bitmap);
    if Mono then
      Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
    else
    begin
      DC := GetDC(0);
      if DC = 0 then GDIError;
      try
        Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
        if Result = 0 then GDIError;
      finally
        ReleaseDC(0, DC);
      end;
    end;

    if Result <> 0 then
    begin
      Old1 := SelectObject(Mem1, Src);
      Old2 := SelectObject(Mem2, Result);

      StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
        Bitmap.bmHeight, SrcCopy);
      if Old1 <> 0 then SelectObject(Mem1, Old1);
      if Old2 <> 0 then SelectObject(Mem2, Old2);
    end;
  finally
    DeleteDC(Mem1);
    DeleteDC(Mem2);
  end;
end;

function GetDInColors(BitCount: Word): Integer;
begin
  case BitCount of
    1, 4, 8: Result := 1 shl BitCount;
  else
    Result := 0;
  end;
end;

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

function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;
const
  ROP_DstCopy = $00AA0029;
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, False);
    SelectPalette(SrcDC, SavePal, False);
    if SavePal <> 0 then
      SavePal := SelectPalette(MemDC, SavePal, True)
    else
      SavePal := SelectPalette(MemDC, SystemPalette16, 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;

type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array [Byte] of TRGBTriple;
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array [Byte] of TRGBQuad;

{ RGBTripleToQuad performs in-place conversion of an OS2 color
  table into a DIB color table.   }
procedure RGBTripleToQuad(var ColorTable);
var
  I: Integer;
  P3: PRGBTripleArray;
  P4: PRGBQuadArray;
begin
  P3 := PRGBTripleArray(@ColorTable);
  P4 := Pointer(P3);
  for I := 255 downto 1 do  // don't move zeroth item
    with P4^[I], P3^[I] do
    begin                     // order is significant for last item moved
      rgbRed := rgbtRed;
      rgbGreen := rgbtGreen;
      rgbBlue := rgbtBlue;
      rgbReserved := 0;
    end;
  P4^[0].rgbReserved := 0;
end;

{ RGBQuadToTriple performs the inverse of RGBTripleToQuad. }
procedure RGBQuadToTriple(var ColorTable; var ColorCount: Integer);
var
  I: Integer;
  P3: PRGBTripleArray;
  P4: PRGBQuadArray;
begin
  P3 := PRGBTripleArray(@ColorTable);
  P4 := Pointer(P3);
  for I := 1 to ColorCount-1 do  // don't move zeroth item
    with P4^[I], P3^[I] do
    begin
      rgbtRed := rgbRed;
      rgbtGreen := rgbGreen;
      rgbtBlue := rgbBlue;
    end;
  if ColorCount < 256 then
  begin
    FillChar(P3^[ColorCount], (256 - ColorCount) * sizeof(TRGBTriple), 0);
    ColorCount := 256;   // OS2 color tables always have 256 entries
  end;
end;

procedure ByteSwapColors(var Colors; Count: Integer);
var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  SysInfo: TSystemInfo;
begin
  GetSystemInfo(SysInfo);
  asm
        MOV   EDX, Colors
        MOV   ECX, Count
        DEC   ECX
        JS    @@END
        LEA   EAX, SysInfo
        CMP   [EAX].TSystemInfo.wProcessorLevel, 3
        JE    @@386
  @@1:  MOV   EAX, [EDX+ECX*4]
        BSWAP EAX
        SHR   EAX,8
        MOV   [EDX+ECX*4],EAX
        DEC   ECX
        JNS   @@1
        JMP   @@END
  @@386:
        PUSH  EBX
  @@2:  XOR   EBX,EBX
        MOV   EAX, [EDX+ECX*4]
        MOV   BH, AL
        MOV   BL, AH
        SHR   EAX,16
        SHL   EBX,8
        MOV   BL, AL
        MOV   [EDX+ECX*4],EBX
        DEC   ECX
        JNS   @@2
        POP   EBX
    @@END:
  end;
end;

function CreateSystemPalette(const Entries: array of TColor): HPALETTE;
var
  DC: HDC;
  SysPalSize: Integer;
  Pal: TMaxLogPalette;
begin
  Pal.palVersion := $300;
  Pal.palNumEntries := 16;
  Move(Entries, Pal.palPalEntry, 16 * SizeOf(TColor));
  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
      GetSystemPaletteEntries(DC, 0, 8, Pal.palPalEntry);
      { Is light and dark gray swapped? }
      if TColor(Pal.palPalEntry[7]) = clSilver then
      begin
        GetSystemPaletteEntries(DC, SysPalSize - 8, 1, Pal.palPalEntry[7]);
        GetSystemPaletteEntries(DC, SysPalSize - 7, 7, Pal.palPalEntry[Pal.palNumEntries - 7]);
        GetSystemPaletteEntries(DC, 7, 1, Pal.palPalEntry[8]);
      end
      else
        GetSystemPaletteEntries(DC, SysPalSize - 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
    end
    else
    begin
    end;
  finally
    ReleaseDC(0,DC);
  end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
var
  DC: HDC;
  SysPalSize: Integer;
begin
  Result := False;
  if SystemPalette16 <> 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 }
        GetPaletteEntries(SystemPalette16, 0, 8, Pal.palPalEntry);
        GetPaletteEntries(SystemPalette16, 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
        Result := True;
      end
    finally
      ReleaseDC(0,DC);
    end;
  end;
end;

function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
  ColorCount: Integer): HPalette;
var
  DC: HDC;
  Save: THandle;
  Pal: TMaxLogPalette;
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;
    Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
  end;
  if Pal.palNumEntries = 0 then Exit;
  if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
    ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

function PaletteToDIBColorTable(Pal: HPalette;
  var ColorTable: array of TRGBQuad): 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;

procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP;
  const IconSize: TPoint);
type
  PLongArray = ^TLongArray;
  TLongArray = array[0..1] of Longint;
var
  Temp: HBITMAP;
  NumColors: Integer;
  DC: HDC;
  Bits: Pointer;
  Colors: PLongArray;
begin
  with BI do
  begin
    biHeight := biHeight shr 1; { Size in record is doubled }
    biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
    NumColors := GetDInColors(biBitCount);
  end;
  DC := GetDC(0);
  if DC = 0 then OutOfResources;
  try
    Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
    Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
    try
      XorBits := DupBits(Temp, IconSize, False);
    finally
      DeleteObject(Temp);
    end;
    with BI do
    begin
      Inc(Longint(Bits), biSizeImage);
      biBitCount := 1;
      biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
      biClrUsed := 2;
      biClrImportant := 2;
    end;
    Colors := Pointer(Longint(@BI) + SizeOf(BI));
    Colors^[0] := 0;
    Colors^[1] := $FFFFFF;
    Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
    try
      AndBits := DupBits(Temp, IconSize, True);
    finally
      DeleteObject(Temp);
    end;
  finally
    ReleaseDC(0, DC);
  end;
end;

procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  StartOffset: Integer; const RequestedSize: TPoint; var IconSize: TPoint);
type
  PIconRecArray = ^TIconRecArray;
  TIconRecArray = array[0..300] of TIconRec;
var
  List: PIconRecArray;
  HeaderLen, Length: Integer;
  BitsPerPixel: Word;
  Colors, BestColor, C1, N, Index: Integer;
  DC: HDC;
  BI: PBitmapInfoHeader;
  ResData: Pointer;
  XorBits, AndBits: HBITMAP;
  XorInfo, AndInfo: Windows.TBitmap;
  XorMem, AndMem: Pointer;
  XorLen, AndLen: Integer;
(*
var
  P: PChar;
begin
  P := Pointer(Integer((Stream as TCustomMemoryStream).Memory) + Stream.Position);
//  N := LookupIconIdFromDirectoryEx(Pointer(P), True, 0, 0, LR_DEFAULTCOLOR);
  Icon := GDICheck(CreateIconFromResourceEx(
    Pointer(P + PIconRec(P)^.DIBOffset - StartOffset),
    PIconRec(P)^.DIBSize, True, $00030000, 0, 0, LR_DEFAULTCOLOR));
end;
*)

  function AdjustColor(I: Integer): Integer;
  begin
    if I = 0 then
      Result := MaxInt
    else
      Result := I;
  end;

  function BetterSize(const Old, New: TIconRec): Boolean;
  var
    NewX, NewY, OldX, OldY: Integer;
  begin
    NewX := New.Width - IconSize.X;
    NewY := New.Height - IconSize.Y;
    OldX := Old.Width - IconSize.X;
    OldY := Old.Height - IconSize.Y;
    Result := (Abs(NewX) <= Abs(OldX)) and ((NewX <= 0) or (NewX <= OldX)) and
       (Abs(NewY) <= Abs(OldY)) and ((NewY <= 0) or (NewY <= OldY));
  end;

begin
  HeaderLen := SizeOf(TIconRec) * ImageCount;
  List := AllocMem(HeaderLen);
  try
    Stream.Read(List^, HeaderLen);
    if (RequestedSize.X or RequestedSize.Y) = 0 then
    begin
      IconSize.X := GetSystemMetrics(SM_CXICON);
      IconSize.Y := GetSystemMetrics(SM_CYICON);
    end
    else
      IconSize := RequestedSize;
    DC := GetDC(0);
    if DC = 0 then OutOfResources;
    try
      BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
      if BitsPerPixel > 8 then
        Colors := MaxInt
      else
        Colors := 1 shl BitsPerPixel;
    finally
      ReleaseDC(0, DC);
    end;

    { Find the image that most closely matches (<=) the current screen color
      depth and the requested image size.  }
    Index := 0;
    BestColor := AdjustColor(List^[0].Colors);
    for N := 1 to ImageCount-1 do
    begin
      C1 := AdjustColor(List^[N].Colors);
      if (C1 <= Colors) and (C1 >= BestColor) and
        BetterSize(List^[Index], List^[N]) then
      begin
        Index := N;
        BestColor := C1;
      end;
    end;

    { the following code determines which image most closely matches the
      current device. It is not meant to absolutely match Windows
      (known broken) algorithm }
(*    C2 := 0;
    for N := 0 to ImageCount - 1 do
    begin
      C1 := List^[N].Colors;
      if C1 = Colors then
      begin
        Index := N;
        if (IconSize.X = List^[N].Width) and (IconSize.Y = List^[N].Height) then
          Break;  // exact match on size and color
      end
      else if Index = -1 then
      begin            // take the first icon with fewer colors than screen
        if C1 <= Colors then
        begin
          Index := N;
          C2 := C1;
        end;
      end
      else if C1 > C2 then  // take icon with more colors than first match
        Index := N;
    end;
    if Index = -1 then Index := 0;
*)
    with List^[Index] do
    begin
      IconSize.X := Width;
      IconSize.Y := Height;
      BI := AllocMem(DIBSize);
      try
        Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
        Stream.Read(BI^, DIBSize);
        TwoBitsFromDIB(BI^, XorBits, AndBits, IconSize);
        GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
        GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
        with AndInfo do
          AndLen := bmWidthBytes * bmHeight * bmPlanes;
        with XorInfo do
          XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
        Length := AndLen + XorLen;
        ResData := AllocMem(Length);
        try
          AndMem := ResData;
          with AndInfo do
            XorMem := Pointer(Longint(ResData) + AndLen);
          GetBitmapBits(AndBits, AndLen, AndMem);
          GetBitmapBits(XorBits, XorLen, XorMem);
          DeleteObject(XorBits);
          DeleteObject(AndBits);
          Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
            XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
          if Icon = 0 then GDIError;
        finally
          FreeMem(ResData, Length);
        end;
      finally
        FreeMem(BI, DIBSize);
      end;
    end;
  finally
    FreeMem(List, HeaderLen);
  end;
end;

function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
type
  PWord = ^Word;
var
  pW: PWord;
  pEnd: PWord;
begin
  Result := 0;
  pW := @WMF;
  pEnd := @WMF.CheckSum;
  while Longint(pW) < Longint(pEnd) do
  begin
    Result := Result xor pW^;
    Inc(Longint(pW), SizeOf(Word));
  end;
end;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  Colors: Integer);
var
  DS: TDIBSection;
  Bytes: Integer;
begin
  DS.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(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
    FillChar(BI, sizeof(BI), 0);
    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;
  var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
  OldPal: HPALETTE;
  DC: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if Palette <> 0 then
    begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
      TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  finally
    if OldPal <> 0 then SelectPalette(DC, OldPal, False);
    DeleteDC(DC);
  end;
end;

function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): 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;

procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
var
  IconInfo: TIconInfo;
  MonoInfoSize, ColorInfoSize: DWORD;
  MonoBitsSize, ColorBitsSize: DWORD;
  MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  CI: TCursorOrIcon;
  List: TIconRec;
  Length: Longint;
begin
  FillChar(CI, SizeOf(CI), 0);
  FillChar(List, SizeOf(List), 0);
  CheckBool(GetIconInfo(Icon, IconInfo));
  try
    InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
    InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
    MonoInfo := nil;
    MonoBits := nil;
    ColorInfo := nil;
    ColorBits := nil;
    try
      MonoInfo := AllocMem(MonoInfoSize);
      MonoBits := AllocMem(MonoBitsSize);
      ColorInfo := AllocMem(ColorInfoSize);
      ColorBits := AllocMem(ColorBitsSize);
      InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
      InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
      if WriteLength then
      begin
        Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
          ColorBitsSize + MonoBitsSize;
        Stream.Write(Length, SizeOf(Length));
      end;
      with CI do
      begin
        CI.wType := RC3_ICON;
        CI.Count := 1;
      end;
      Stream.Write(CI, SizeOf(CI));
      with List, PBitmapInfoHeader(ColorInfo)^ do
      begin
        Width := biWidth;
        Height := biHeight;
        Colors := biPlanes * biBitCount;
        DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
        DIBOffset := SizeOf(CI) + SizeOf(List);
      end;
      Stream.Write(List, SizeOf(List));
      with PBitmapInfoHeader(ColorInfo)^ do
        Inc(biHeight, biHeight); { color height includes mono bits }
      Stream.Write(ColorInfo^, ColorInfoSize);
      Stream.Write(ColorBits^, ColorBitsSize);
      Stream.Write(MonoBits^, MonoBitsSize);
    finally
      FreeMem(ColorInfo, ColorInfoSize);
      FreeMem(ColorBits, ColorBitsSize);
      FreeMem(MonoInfo, MonoInfoSize);
      FreeMem(MonoBits, MonoBitsSize);
    end;
  finally
    DeleteObject(IconInfo.hbmColor);
    DeleteObject(IconInfo.hbmMask);
  end;
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
          CompareMem(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 }



constructor TFileFormatsList.Create;
begin
  inherited Create;
  Add('wmf', SVMetafiles, 0, TMetafile);
  Add('emf', SVEnhMetafiles, 0, TMetafile);
  Add('ico', SVIcons, 0, TIcon);
  Add('bmp', SVBitmaps, 0, TBitmap);
end;

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

procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
  AClass: TGraphicClass);
var
  NewRec: PFileFormat;
begin
  New(NewRec);
  with NewRec^ do
  begin
    Extension := AnsiLowerCase(Ext);
    GraphicClass := AClass;
    Description := Desc;
    DescResID := DescID;
  end;
  inherited Add(NewRec);
end;

function TFileFormatsList.FindExt(Ext: string): TGraphicClass;
var
  I: Integer;
begin
  Ext := AnsiLowerCase(Ext);
  for I := Count-1 downto 0 do
    with PFileFormat(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 := PFileFormat(Items[I])^.GraphicClass;
    if Result.ClassName = Classname then Exit;
  end;
  Result := nil;
end;

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

procedure TFileFormatsList.BuildFilterStrings(GraphicClass: TGraphicClass;
  var Descriptions, Filters: string);
var
  C, I: Integer;
  P: PFileFormat;
begin
  Descriptions := '';
  Filters := '';
  C := 0;
  for I := Count-1 downto 0 do
  begin
    P := PFileFormat(Items[I]);
    if P^.GraphicClass.InheritsFrom(GraphicClass) and (P^.Extension <> '') then
      with P^ do
      begin
        if C <> 0 then
        begin
          Descriptions := Descriptions + '|';
          Filters := Filters + ';';
        end;
        if (Description = '') and (DescResID <> 0) then
          Description := LoadStr(DescResID);
        FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
        FmtStr(Filters, '%s*.%s', [Filters, Extension]);
        Inc(C);
      end;
  end;
  if C > 1 then
    FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
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
  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;
end;

procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
var
  I: Integer;
begin
  I := FClasses.Add(AClass);
  try
    FFormats.Add(Pointer(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 Word(FFormats[I]) = Fmt then
    begin
      Result := 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;
  //clq//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;

//--------------------------------------------------
//网上下载的图片经常弄错,这里用Delphi从内存流中判断图片格式
function _img_mem2ext(fn, ext:string):string; //Button1的单击事件
var
  MyImage:TMemoryStream;   //内存流对象
  Buffer:Word;
  i:integer;
begin
  Result := ext;
  MyImage:=TMemoryStream.Create; //建立内存流对象

  try
     MyImage.LoadFromFile(fn); //把刚刚用户选择的文件载入到内存流中
     MyImage.Position := 0;   //移动指针到最开头的位置
     if MyImage.Size = 0 then   //如果文件大小等于0,那么
     begin
       //错误
       //ShowMessage('错误');
       Exit;
     end;
     MyImage.ReadBuffer(Buffer,2); //读取文件的前2个字节,放到Buffer里面

     if Buffer=$4D42 then //如果前两个字节是以4D42[低位到高位]
     begin
       result := 'bmp'; //ShowMessage('BMP'); //那么这个是BMP格式的文件
     end
     else if Buffer=$D8FF then //如果前两个字节是以D8FF[低位到高位]
    begin
         //JPEG
       result := 'jpg'; //ShowMessage('JPEG'); //........一样 下面不注释了
     end
     else if Buffer=$4947 then
     begin
         //GIF
       result := 'gif'; //ShowMessage('GIF');
     end
     else if Buffer=$050A then
     begin
         //PCX
       //ShowMessage('PCX');
     end
     else if Buffer=$5089 then
     begin
         //PNG
       result := 'png'; //ShowMessage('PNG');
     end
     else if Buffer=$4238 then
     begin
        //PSD
       //ShowMessage('PSD');
     end
     else if Buffer=$A659 then
     begin
        //RAS
       //ShowMessage('RAS');
     end
     else if Buffer=$DA01 then
     begin
         //SGI
       //ShowMessage('SGI');
     end
     else if Buffer=$4949 then
     begin
         //TIFF
       //ShowMessage('TIFF');
     end
     else   //如是其他类型的文件的话,直接显示错误
     begin
         //ERR
       //ShowMessage('ERR');
     end; //if


  finally

  MyImage.Free;   //释放内存流对象

  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);

  Ext := _img_mem2ext(Filename ,Ext); //clq add

  GraphicClass := FileFormats.FindExt(Ext); //clq tag
  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, 0, AGraphicClass);
end;

class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  ADescriptionResID: Integer; 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[63];
  NewGraphic: TGraphic;
  GraphicClass: TGraphicClass;
begin
  Stream.Read(CName[0], 1);
  Stream.Read(CName[1], Integer(CName[0]));
  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[63];
begin
  with Stream do
  begin
    if Graphic <> nil then
      CName := Graphic.ClassName else
      CName := '';
    Write(CName, Length(CName) + 1);
    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
  if FHandle <> 0 then DeleteEnhMetafile(FHandle);
  InternalDeletePalette(FPalette);
  inherited Destroy;
end;

procedure TMetafileImage.FreeHandle;
begin
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;
  Temp: HDC;
  P: PChar;
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
      P := PChar(CreatedBy+#0+Description+#0#0)
    else
      P := nil;
    Temp := CreateEnhMetafile(RefDC, nil, @R, P);
    if Temp = 0 then GDIError;
    Handle := Temp;
  finally
    if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  end;
end;

destructor TMetafileCanvas.Destroy;
var
  Temp: HDC;
begin
  Temp := Handle;
  Handle := 0;
  FMetafile.Handle := CloseEnhMetafile(Temp);
  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
  Temp: Integer;
begin
  Result := '';
  if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  if Temp <= 0 then Exit;
  SetLength(Result, Temp);
  GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  SetLength(Result, StrLen(PChar(Result)));
end;

function TMetafile.GetDesc: String;
var
  Temp: Integer;
begin
  Result := '';
  if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  if Temp <= 0 then Exit;
  SetLength(Result, Temp);
  GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  Delete(Result, 1, StrLen(PChar(Result))+1);
  SetLength(Result, StrLen(PChar(Result)));
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(PLogPalette(@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
  EnhHeader: TEnhMetaheader;
  Buf: PChar;
begin
  NewImage;
  Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
  if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  GetMem(Buf, EnhHeader.nBytes);
  with FImage do
  try
    Move(EnhHeader, Buf^, Sizeof(EnhHeader));
    Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
      EnhHeader.nBytes - Sizeof(EnhHeader));
    FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
    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;
  finally
    FreeMem(Buf, EnhHeader.nBytes);
  end;
end;

procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
var
  WMF: TMetafileHeader;
  BitMem: Pointer;
  MFP: TMetaFilePict;
  EMFHeader: TEnhMetaheader;
begin
  NewImage;
  Stream.Read(WMF, SizeOf(WMF));
  if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
    InvalidMetafile;
  Dec(Length, SizeOf(WMF));
  GetMem(Bitmem, Length);
  with FImage do
  try
    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;
  finally
    Freemem(BitMem, Length);
  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: Longint;
  Header: TEnhMetaHeader;
begin
  Size := Stream.Size - Stream.Position;
  if Size > Sizeof(Header) then
  begin
    Stream.Read(Header, Sizeof(Header));
    Stream.Seek(-Sizeof(Header), soFromCurrent);
  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, soFromBeginning);
    SavePos := Stream.Size - SavePos;
    Stream.Write(SavePos, Sizeof(SavePos));
    Stream.Seek(0, soFromEnd);
  end;
end;

procedure TMetafile.WriteEMFStream(Stream: TStream);
var
  Buf: Pointer;
  Length: Longint;
begin
  if FImage = nil then Exit;
  Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  if Length = 0 then Exit;
  GetMem(Buf, Length);
  try
    GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
    Stream.WriteBuffer(Buf^, Length);
  finally
    FreeMem(Buf, Length);
  end;
end;

procedure TMetafile.WriteWMFStream(Stream: TStream);
var
  WMF: TMetafileHeader;
  Bits: Pointer;
  Length: UINT;
  RefDC: HDC;
begin
  if FImage = nil then Exit;
  FillChar(WMF, SizeOf(WMF), 0);
  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);
      GetMem(Bits, Length);
      try
        if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
          RefDC) < Length then GDIError;
        Stream.WriteBuffer(WMF, SizeOf(WMF));
        Stream.WriteBuffer(Bits^, Length);
      finally
        FreeMem(Bits, Length);
      end;
    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, sizeof(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;

{ TBitmapCanvas }
{ Create a canvas that gets its DC from the memory DC cache }
type
  TBitmapCanvas = class(TCanvas)
  private
    FBitmap: TBitmap;
    FOldBitmap: HBITMAP;
    FOldPalette: HPALETTE;
    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;

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

destructor TBitmapCanvas.Destroy;
begin
  FreeContext;
  inherited Destroy;
end;

procedure TBitmapCanvas.FreeContext;
var
  H: HBITMAP;
begin
  if FHandle <> 0 then
  begin
    Lock;
    try
      if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
      if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
      H := FHandle;
      Handle := 0;
      DeleteDC(H);
      BitmapCanvasList.Remove(Self);
    finally
      Unlock;
    end;
  end;
end;

procedure TBitmapCanvas.CreateHandle;
var
  H: HBITMAP;
begin
  if FBitmap <> nil then
  begin
    Lock;
    try
      FBitmap.HandleNeeded;
      DeselectBitmap(FBitmap.FImage.FHandle);
//!!      DeselectBitmap(FBitmap.FImage.FMaskHandle);
      FBitmap.PaletteNeeded;
      H := CreateCompatibleDC(0);
      if FBitmap.FImage.FHandle <> 0 then
        FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
        FOldBitmap := 0;
      if FBitmap.FImage.FPalette <> 0 then
      begin
        FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
        RealizePalette(H);
      end
      else
        FOldPalette := 0;
      Handle := H;
      BitmapCanvasList.Add(Self);
    finally
      Unlock;
    end;
  end;
end;

{ TSharedImage }

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

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

{ TBitmapImage }

destructor TBitmapImage.Destroy;
begin
  if FDIBHandle <> 0 then
  begin
    DeselectBitmap(FDIBHandle);
    DeleteObject(FDIBHandle);
    FDIBHandle := 0;
  end;
  FreeHandle;
  if FDIB.dshSection <> 0 then CloseHandle(FDIB.dshSection);
  FreeAndNil(FSaveStream);
  inherited Destroy;
end;

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

{ TBitmap }

const
  { Mapping from color in DIB to system color }
  Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);
  SysGrays: array[0..3] of TColor = (clBtnHighlight, clBtnFace, clBtnShadow,
    clBtnText);

{ This function will replace OldColors in Handle's colortable with NewColors and
  return a new DDB which uses that color table.  For bitmap's with more than
  256 colors (8bpp) this function returns the original bitmap. }
function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
var
  Bitmap: PBitmapInfoHeader;
  ColorCount: Integer;
  BitmapInfoSize: DWORD;
  BitmapBitsSize: DWORD;
  Bits: Pointer;
  Colors: PRGBQuadArray;
  I, J: Integer;
  OldColor, NewColor: Integer;
  ScreenDC, DC: HDC;
  Save: HBITMAP;
begin
  Result := Handle;
  if Handle = 0 then Exit;
  InternalGetDIBSizes(Handle, BitmapInfoSize, BitmapBitsSize, 0);
  Bitmap := AllocMem(DWORD(BitmapInfoSize) + BitmapBitsSize);
  try
    Bits := Pointer(DWORD(Bitmap) + BitmapInfoSize);
    InternalGetDIB(Handle, 0, Bitmap^, Bits^, 0);
    if Bitmap^.biBitCount <= 8 then
    begin
      ColorCount := 1 shl (Bitmap^.biBitCount);
      Colors := Pointer(DWORD(Bitmap) + Bitmap^.biSize);
      ByteSwapColors(Colors^, ColorCount);
      for I := 0 to ColorCount - 1 do
        for J := Low(OldColors) to High(OldColors) do
        begin
          OldColor := ColorToRGB(OldColors[J]);
          if Integer(Colors[I]) = OldColor then
          begin
            NewColor := ColorToRGB(NewColors[J]);
            Integer(Colors[I]) := NewColor;
          end;
        end;
      ByteSwapColors(Colors^, ColorCount);
      ScreenDC := GetDC(0);
      try
        DC := CreateCompatibleDC(ScreenDC);
        if DC <> 0 then
          with Bitmap^ do
          begin
            Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
            if Result <> 0 then
            begin
              Save := SelectObject(DC, Result);
              StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
                Bits, PBitmapInfo(Bitmap)^, DIB_RGB_COLORS, SrcCopy);
              SelectObject(DC, Save);
            end;
          end;
          DeleteDC(DC);
      finally
        ReleaseDC(0, ScreenDC);
      end;
    end;
  finally
    FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  end;
end;

{ This function will create a new DDB from the bitmap resource, replacing
  OldColors in the colortable with NewColors.  If the bitmap resource has more
  than 256 colors (8bpp) this function returns the new DDB without color
  modifications. }
function CreateMappedRes(Instance: THandle; ResName: PChar;
  const OldColors, NewColors: array of TColor): HBITMAP;
var
  Rsrc: HRSRC;
  Res: THandle;
  ColorCount: DWORD;
  BitmapInfoSize: Integer;
  Bitmap: PBitmapInfoHeader;
  BitmapInfo: PBitmapInfoHeader;
  Colors: PRGBQuadArray;
  I, J: Integer;
  OldColor, NewColor: Integer;
  Bits: Pointer;
  ScreenDC, DC: HDC;
  Save: HBITMAP;
  Temp: TBitmap;
begin
  Result := 0;
  Rsrc := FindResource(Instance, ResName, RT_BITMAP);
  if Rsrc = 0 then Exit;
  Res := LoadResource(Instance, Rsrc);
  try
    { Lock the bitmap and get a pointer to the color table. }
    Bitmap := LockResource(Res);
    if Bitmap <> nil then
    try
      if (Bitmap^.biBitCount * Bitmap^.biPlanes) <= 8 then
      begin
        ColorCount := 1 shl (Bitmap^.biBitCount);
        BitmapInfoSize := Bitmap^.biSize + ColorCount * SizeOf(TRGBQuad);
        GetMem(BitmapInfo, BitmapInfoSize);
        try
          Move(Bitmap^, BitmapInfo^, BitmapInfoSize);
          if Bitmap^.biBitCount <= 8 then
          begin
            Colors := Pointer(DWORD(BitmapInfo) + BitmapInfo^.biSize);
            ByteSwapColors(Colors^, ColorCount);
            for I := 0 to ColorCount - 1 do
              for J := Low(OldColors) to High(OldColors) do
              begin
                OldColor := ColorToRGB(OldColors[J]);
                if Integer(Colors[I]) = OldColor then
                begin
                  NewColor := ColorToRGB(NewColors[J]);
                  Integer(Colors[I]) := NewColor;
                end;
              end;
            ByteSwapColors(Colors^, ColorCount);
          end;
          { First skip over the header structure and color table entries, if any. }
          Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
          { Create a color bitmap compatible with the display device. }
          ScreenDC := GetDC(0);
          try
            DC := CreateCompatibleDC(ScreenDC);
            if DC <> 0 then
              with BitmapInfo^ do
              begin
                Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
                if Result <> 0 then
                begin
                  Save := SelectObject(DC, Result);
                  StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
                    Bits, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS, SrcCopy);
                  SelectObject(DC, Save);
                end;
              end;
              DeleteDC(DC);
          finally
            ReleaseDC(0, ScreenDC);
          end;
        finally
          FreeMem(BitmapInfo, BitmapInfoSize);
        end;
      end
      else
      begin
        Temp := TBitmap.Create;
        try
{$IFDEF MSWINDOWS}
          Temp.LoadFromResourceID(Instance, Integer(ResName));
{$ELSE}
          Temp.LoadFromResourceName(Instance, ResName);
{$ENDIF}
          Result := Temp.ReleaseHandle;
        finally
          Temp.Free;
        end;
      end;
    finally
      UnlockResource(Res);
    end;
  finally
    FreeResource(Res);
  end;
end;

{ This function replaces the standard gray colors in a bitmap with the system
  grays (Grays, SysGrays). }
function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
begin
  Result := CreateMappedBmp(Handle, Grays, SysGrays);
end;

{ This function replaces the standard gray colors in a bitmap resource with the
  system grays (Grays, SysGrays). }
function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
begin
  Result := CreateMappedRes(Instance, ResName, Grays, SysGrays);
end;

procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
  const DIB: TDIBSection);
var
  ScreenDC, DC: HDC;
  OldBM: HBitmap;
  ColorCount: Integer;
  Colors: array [Byte] of TRGBQuad;
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: PBitmapInfo;
  BitsMem: Pointer;
  SrcDIB: TDIBSection;
  MonoColors: array [0..1] of Integer;
  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, sizeof(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
      GetMem(BI, sizeof(TBitmapInfo) + 256 * sizeof(TRGBQuad));
      with DIB.dsbmih do
      try
        biSize := sizeof(BI.bmiHeader);
        biPlanes := 1;
        if biBitCount = 0 then
          biBitCount := GetDeviceCaps(ScreenDC, BITSPIXEL) * GetDeviceCaps(ScreenDC, PLANES);
        BI.bmiHeader := DIB.dsbmih;
        bmWidth := biWidth;
        bmHeight := biHeight;

        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.
            Integer(BI^.bmiColors[0]) := 0;
            PInteger(Integer(@BI^.bmiColors) + sizeof(Integer))^ := $FFFFFF;
          end
          else if (NewPalette <> 0) then
            PaletteToDIBColorTable(NewPalette, PRGBQuadArray(@BI.bmiColors)^)
          else if Handle <> 0 then
          begin
            NewScr := SelectObject(NewImageDC, Handle);
            if (SrcDIB.dsbmih.biSize > 0) and (SrcDIB.dsbm.bmBits <> nil) then
              biClrUsed := GetDIBColorTable(NewImageDC, 0, 256, 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);
          Move(DIB.dsBitFields, BI.bmiColors, sizeof(DIB.dsBitFields));
        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;
      finally
        FreeMem(BI);
      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, sizeof(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(PLogPalette(@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, SizeOf(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
  DIB: TDIBSection;
begin
  if (Source = nil) or (Source is TBitmap) then
  begin
    EnterCriticalSection(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
      begin
        FillChar(DIB, Sizeof(DIB), 0);
        NewImage(0, 0, DIB, False);
      end;
    finally
      LeaveCriticalSection(BitmapImageLock);
    end;
    PaletteModified := Palette <> 0;
    Changed(Self);
  end
  else inherited Assign(Source);
end;

procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
var
  NewHandle, NewPalette: THandle;
begin
  FreeContext;
  NewHandle := 0;
  NewPalette := 0;
  try
    if APalette = SystemPalette16 then
      NewPalette := APalette
    else
      NewPalette := CopyPalette(APalette);
    NewHandle := CopyBitmap(AHandle, APalette, NewPalette, DIB, FCanvas);
    NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  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;
  FImage.FDIB.dsbmih.biClrUsed := 0;
  FImage.FDIB.dsbmih.biClrImportant := 0;
  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.FOS2Format, 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
        StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
          Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
          FDIB.dsbm.bmHeight, ACanvas.CopyMode);
    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;
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.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, dsbmih do
      case biBitCount 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): Pointer;
begin
  Changing(Self);
  with FImage.FDIB, dsbm, dsbmih do
  begin
    if (Row < 0) or (Row >= bmHeight) then
      InvalidOperation(@SScanLine);
    DIBNeeded;
    GDIFlush;
    if biHeight > 0 then  // bottom-up DIB
      Row := biHeight - Row - 1;
    Integer(Result) := Integer(bmBits) +
      Row * BytesPerScanline(biWidth, biBitCount, 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, sizeof(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));
    FillChar(DIB, SizeOf(DIB), 0);
    GetObject(NewHandle, SizeOf(DIB), @DIB);
    if FImage.FPalette = SystemPalette16 then
      NewPalette := FImage.FPalette
    else
      NewPalette := CopyPalette(FImage.FPalette);
    NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  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, nil, 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.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  DIB: TDIBSection;
begin
  if (AFormat <> CF_BITMAP) or (AData = 0) then
    InvalidGraphic(@SUnknownClipboardFormat);
  FreeContext;
  FillChar(DIB, sizeof(DIB), 0);
  GetObject(AData, sizeof(DIB), @DIB);
  if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
  CopyImage(AData, APalette, DIB);
  FImage.FOS2Format := False;
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

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

procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  try
    ReadDIB(Stream, Stream.Size);
  finally
    Stream.Free;
  end;
end;

{$IFDEF MSWINDOWS}
procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  try
    ReadDIB(Stream, Stream.Size);
  finally
    Stream.Free;
  end;
end;
{$ENDIF}

procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
var
  Image: TBitmapImage;
begin
  Image := TBitmapImage.Create;
  with Image do
  try
    FHandle := NewHandle;
    FPalette := NewPalette;
    FDIB := NewDIB;
    FOS2Format := OS2Format;
    if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
    FSaveStream := RLEStream as TMemoryStream;
  except
    Image.Free;
    raise;
  end;
  //!! replace with InterlockedExchange()
  EnterCriticalSection(BitmapImageLock);
  try
    FImage.Release;
    FImage := Image;
    FImage.Reference;
  finally
    LeaveCriticalSection(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; bmf: PBitmapFileHeader);
const
  DIBPalSizes: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
  DC, MemDC: HDC;
  BitsMem: Pointer;
  OS2Header: TBitmapCoreHeader;
  BitmapInfo: PBitmapInfo;
  ColorTable: Pointer;
  HeaderSize: Integer;
  OS2Format: Boolean;
  BMHandle, OldBMP: HBITMAP;
  DIB: TDIBSection;
  Pal, OldPal: HPalette;
  RLEStream: TStream;
  vbmf: TBitmapFileHeader;
{$IFDEF LINUX}
  I: Integer;
{$ENDIF}
begin
  Pal := 0;
  BMHandle := 0;
  RLEStream := nil;
  Stream.Read(HeaderSize, sizeof(HeaderSize));
  OS2Format := HeaderSize = sizeof(OS2Header);
  if OS2Format then HeaderSize := sizeof(TBitmapInfoHeader);
  GetMem(BitmapInfo, HeaderSize + 12 + 256 * sizeof(TRGBQuad));
  with BitmapInfo^ do
  try
    try
      if OS2Format then  // convert OS2 DIB to Win DIB
      begin
        Stream.Read(Pointer(Longint(@OS2Header) + sizeof(HeaderSize))^,
          sizeof(OS2Header) - sizeof(HeaderSize));
        FillChar(bmiHeader, sizeof(bmiHeader), 0);
        with bmiHeader, OS2Header do
        begin
          biWidth := bcWidth;
          biHeight := bcHeight;
          biPlanes := bcPlanes;
          biBitCount := bcBitCount;
        end;
        Dec(ImageSize, sizeof(OS2Header));
      end
      else
      begin // support bitmap headers larger than TBitmapInfoHeader
        Stream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
          HeaderSize - sizeof(HeaderSize));
        Dec(ImageSize, HeaderSize);

        if (bmiHeader.biCompression <> BI_BITFIELDS) and
          (bmiHeader.biCompression <> BI_RGB) then
        begin // Preserve funky non-DIB data (like RLE) until modified
          RLEStream := TMemoryStream.Create;
          // source stream could be unidirectional.  don't reverse seek
          if bmf = nil then
          begin
            FillChar(vbmf, sizeof(vbmf), 0);
            vbmf.bfType := $4D42;
            vbmf.bfSize := ImageSize + Cardinal(HeaderSize);
            bmf := @vbmf;
          end;
          RLEStream.Write(bmf^, sizeof(bmf^));
          RLEStream.Write(HeaderSize, sizeof(HeaderSize));
          RLEStream.Write(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
            HeaderSize - sizeof(HeaderSize));
          RLEStream.CopyFrom(Stream, ImageSize);
          { Cast ImageSize (long word) to integer to avoid integer overflow when negating. }
          RLEStream.Seek(-Integer(ImageSize), soFromEnd);
          Stream := RLEStream;  // the rest of the proc reads from RLEStream
        end;
      end;

      with bmiHeader do
      begin
        biSize := HeaderSize;
        ColorTable := Pointer(Longint(BitmapInfo) + HeaderSize);

        { check number of planes. DIBs must be 1 color plane (packed pixels) }
        if biPlanes <> 1 then InvalidBitmap;

        // 3 DWORD color element bit masks (ie 888 or 565) can precede colors
        // TBitmapInfoHeader sucessors include these masks in the headersize
        if (HeaderSize = sizeof(TBitmapInfoHeader)) and
          ((biBitCount = 16) or (biBitCount = 32)) and
          (biCompression = BI_BITFIELDS) then
        begin
          Stream.ReadBuffer(ColorTable^, 3 * sizeof(DWORD));
          Inc(Longint(ColorTable), 3 * sizeof(DWORD));
          Dec(ImageSize, 3 * sizeof(DWORD));
        end;

        // Read the color palette
        if biClrUsed = 0 then
          biClrUsed := GetDInColors(biBitCount);
        Stream.ReadBuffer(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
        Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);

        // biSizeImage can be zero. If zero, compute the size.
        if biSizeImage = 0 then            // top-down DIBs have negative height
          biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);

        if biSizeImage < ImageSize then ImageSize := biSizeImage;
      end;

      { convert OS2 color table to DIB color table }
      if OS2Format then RGBTripleToQuad(ColorTable^);

      DC := GDICheck(GetDC(0));
      try
        if ((bmiHeader.biCompression <> BI_RGB) and
          (bmiHeader.biCompression <> BI_BITFIELDS)) or DDBsOnly then
        begin
          MemDC := 0;
          GetMem(BitsMem, ImageSize);
          try
            Stream.ReadBuffer(BitsMem^, ImageSize);
            MemDC := GDICheck(CreateCompatibleDC(DC));
            OldBMP := SelectObject(MemDC, CreateCompatibleBitmap(DC, 1, 1));
            OldPal := 0;
            if bmiHeader.biClrUsed > 0 then
            begin
              Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
              OldPal := SelectPalette(MemDC, Pal, False);
              RealizePalette(MemDC);
            end;

            try
              BMHandle := CreateDIBitmap(MemDC, BitmapInfo^.bmiHeader, CBM_INIT, BitsMem,
                BitmapInfo^, DIB_RGB_COLORS);
              if (BMHandle = 0) then
                if GetLastError = 0 then InvalidBitmap else RaiseLastOSError;
            finally
              if OldPal <> 0 then
                SelectPalette(MemDC, OldPal, True);
              DeleteObject(SelectObject(MemDC, OldBMP));
            end;
          finally
            if MemDC <> 0 then DeleteDC(MemDC);
            FreeMem(BitsMem);
          end;
        end
        else
        begin
          BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem, 0, 0);
          if (BMHandle = 0) or (BitsMem = nil) then
            if GetLastError = 0 then InvalidBitmap else RaiseLastOSError;

          try
{$IFDEF LINUX}
            // I need to pre-touch the memory in 4096 byte increments to ensure
            // the read will succeed. WINE marks this memory as not present to
            // catch when we make changes to it. If we read directly into it
            // Linux will (correctly) terminate the read with a failure since an
            // exception occured during the read. We need to make sure these
            // exceptions are triggered in user space instead of kernel.
            for I := 1 to (ImageSize + 4095) div 4096 do
              PByteArray(BitsMem)^[(I - 1) * 4096] := 0;
{$ENDIF}
            Stream.ReadBuffer(BitsMem^, ImageSize);
          except
            DeleteObject(BMHandle);
            raise;
          end;
        end;
      finally
        ReleaseDC(0, DC);
      end;
      // Hi-color DIBs don't preserve color table, so create palette now
      if (bmiHeader.biBitCount > 8) and (bmiHeader.biClrUsed > 0) and (Pal = 0)then
        Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);

      FillChar(DIB, sizeof(DIB), 0);
      GetObject(BMHandle, Sizeof(DIB), @DIB);
      // GetObject / CreateDIBSection don't preserve these info values
      DIB.dsBmih.biXPelsPerMeter := bmiHeader.biXPelsPerMeter;
      DIB.dsBmih.biYPelsPerMeter := bmiHeader.biYPelsPerMeter;
      DIB.dsBmih.biClrUsed := bmiHeader.biClrUsed;
      DIB.dsBmih.biClrImportant := bmiHeader.biClrImportant;
    except
      RLEStream.Free;
      raise;
    end;
  finally
    FreeMem(BitmapInfo);
  end;
  NewImage(BMHandle, Pal, DIB, OS2Format, RLEStream);
  PaletteModified := Palette <> 0;
  Changed(Self);
end;

procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
var
  Bmf: TBitmapFileHeader;
  DIB: TDIBSection;
begin
  FreeContext;
  if Size = 0 then
  begin
    FillChar(DIB, sizeof(DIB), 0);
    NewImage(0, 0, DIB, False);
  end
  else
  begin
    Stream.ReadBuffer(Bmf, sizeof(Bmf));
    if Bmf.bfType <> $4D42 then InvalidBitmap;
    ReadDIB(Stream, Size - sizeof(Bmf), @Bmf);
  end;
end;

procedure TBitmap.SetHandle(Value: HBITMAP);
var
  DIB: TDIBSection;
  APalette: HPALETTE;
begin
  with FImage do
    if FHandle <> Value then
    begin
      FreeContext;
      FillChar(DIB, sizeof(DIB), 0);
      if Value <> 0 then
        GetObject(Value, SizeOf(DIB), @DIB);
      if FRefCount = 1 then
      begin
        APalette := FPalette;
        FPalette := 0;
      end
      else
        if FPalette = SystemPalette16 then
          APalette := SystemPalette16
        else
          APalette := CopyPalette(FPalette);
      try
        NewImage(Value, APalette, DIB, False);
      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, FOS2Format);
        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, FOS2Format);
      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;
      DIB.dsbmih.biHeight := Value;
      CopyImage(FHandle, FPalette, DIB);
      Changed(Self);
    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.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, FOS2Format);
        except
          DeleteObject(AHandle);
          raise;
        end;
      end;
    UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
    PaletteModified := True;
    Changed(Self);
  end;
end;

procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
const
  BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
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
    FillChar(DIB, sizeof(DIB), 0);
    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
        pf4Bit: Pal := SystemPalette16;
        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.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;
      DIB.dsbmih.biWidth := 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);
const
  PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
  Size, ColorCount: DWORD;
  HeaderSize: DWORD;
  BMF: TBitmapFileHeader;
  Save: THandle;
  BC: TBitmapCoreHeader;
  Colors: array [Byte] of TRGBQuad;
begin
  FillChar(BMF, sizeof(BMF), 0);
  BMF.bfType := $4D42;
  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;
  with FImage do
  begin
    Size := 0;
    if FDIBHandle <> 0 then
    begin
      InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, FDIB.dsbmih.biClrUsed);
      if FOS2Format then
      begin // OS2 format cannot have partial palette
        HeaderSize := sizeof(BC);
        if FDIB.dsbmih.biBitCount <= 8 then
          Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
      end;
      Inc(Size, HeaderSize + sizeof(BMF));

      FillChar(BMF, sizeof(BMF), 0);
      BMF.bfType := $4D42;

      Canvas.RequiredState([csHandleValid]);
      Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
      ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
      SelectObject(FCanvas.FHandle, Save);
      // GetDIBColorTable always reports the full palette; trim it back for partial palettes
      if (0 < FDIB.dsbmih.biClrUsed) and (FDIB.dsbmih.biClrUsed < ColorCount) then
        ColorCount := FDIB.dsbmih.biClrUsed;
      if (not FOS2Format) and (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
      begin
        ColorCount := PaletteToDIBColorTable(FPalette, Colors);
        if FDIB.dsbmih.biBitCount > 8 then
        begin  // optional color palette for hicolor images (non OS2)
          Inc(Size, ColorCount * sizeof(TRGBQuad));
          Inc(HeaderSize, ColorCount * sizeof(TRGBQuad));
        end;
      end;

      BMF.bfSize := Size;
      BMF.bfOffBits := sizeof(BMF) + HeaderSize;
    end;

    if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));

    if Size <> 0 then
    begin
      FixupBitFields(FDIB);
      if (ColorCount <> 0) then
      begin
        if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
          FDIB.dsbmih.biClrUsed := ColorCount;
        if FOS2Format then RGBQuadToTriple(Colors, Integer(ColorCount));
      end;
      if FOS2Format then
      begin
        with BC, FDIB.dsbmih do
        begin
          bcSize := sizeof(BC);
          bcWidth := biWidth;
          bcHeight := biHeight;
          bcPlanes := 1;
          bcBitCount := biBitCount;
        end;
        Stream.WriteBuffer(BMF, sizeof(BMF));
        Stream.WriteBuffer(BC, sizeof(BC));
      end
      else
      begin
        Stream.WriteBuffer(BMF, Sizeof(BMF));
        Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
        if (FDIB.dsbmih.biBitCount > 8) and
          ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
          Stream.WriteBuffer(FDIB.dsBitfields, 12);
      end;
      Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
      Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
    end;
  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 Format: Word; var Data: THandle;
  var APalette: HPALETTE);
var
  DIB: TDIBSection;
begin
  Format := CF_BITMAP;
  HandleNeeded;
  with FImage do
  begin
    DIB := FDIB;
    DIB.dsbmih.biSize := 0;   // copy to device bitmap
    DIB.dsbm.bmBits := nil;
    Data := CopyBitmap(FHandle, FPalette, FPalette, DIB, FCanvas);
  end;
  try
    APalette := CopyPalette(FImage.FPalette);
  except
    DeleteObject(Data);
    raise;
  end;
end;

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

{ TIconImage }

destructor TIconImage.Destroy;
begin
  FMemoryImage.Free;
  inherited Destroy;
end;

procedure TIconImage.FreeHandle;
begin
  if FHandle <> 0 then DestroyIcon(FHandle);
  FHandle := 0;
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(0, nil);
    Changed(Self);
    Exit;
  end;
  inherited Assign(Source);
end;

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

function TIcon.GetEmpty: Boolean;
begin
  with FImage do
    Result := (FHandle = 0) and (FMemoryImage = nil);
end;

function TIcon.GetHandle: HICON;
begin
  HandleNeeded;
  Result := FImage.FHandle;
end;

function TIcon.HandleAllocated: Boolean;
begin
  Result := Assigned(FImage) and (FImage.FHandle <> 0);
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
  CI: TCursorOrIcon;
  NewHandle: HICON;
begin
  with FImage do
  begin
    if FHandle <> 0 then Exit;
    if FMemoryImage = nil then Exit;
    FMemoryImage.Position := 0;
    FMemoryImage.ReadBuffer(CI, SizeOf(CI));
    case CI.wType of
      RC3_STOCKICON: NewHandle := StockIcon;
      RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI),
        FRequestedSize, FSize);
    else
      InvalidIcon;
    end;
    FHandle := NewHandle;
  end;
end;

procedure TIcon.ImageNeeded;
var
  Image: TMemoryStream;
  CI: TCursorOrIcon;
begin
  with FImage do
  begin
    if FMemoryImage <> nil then Exit;
    if FHandle = 0 then InvalidIcon;
    Image := TMemoryStream.Create;
    try
      if GetHandle = StockIcon then
      begin
        FillChar(CI, SizeOf(CI), 0);
        Image.WriteBuffer(CI, SizeOf(CI));
      end
      else
        WriteIcon(Image, Handle, False);
    except
      Image.Free;
      raise;
    end;
    FMemoryImage := Image;
  end;
end;

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

procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
var
  Image: TIconImage;
begin
  Image := TIconImage.Create;
  try
    Image.FHandle := NewHandle;
    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(CopyIcon(FHandle), nil);
    Result := FHandle;
    FHandle := 0;
  end;
  Changed(Self);
end;

procedure TIcon.SetHandle(Value: HICON);
begin
  NewImage(Value, nil);
  Changed(Self);
end;

procedure TIcon.SetHeight(Value: Integer);
begin
  if FImage.FHandle = 0 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 FImage.FHandle = 0 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 Format: Word; var Data: 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 PFileFormat(FileFormats[I])^.GraphicClass.ClassName = GraphicClass.ClassName then
    begin
      Result := PFileFormat(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 := 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
  Charset: TFontCharset;
begin
  DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  if not SysLocale.FarEast then Exit;
  Charset := GetDefFontCharset;
  case Charset of
    SHIFTJIS_CHARSET:
      begin
        DefFontData.Name := '俵俽 俹僑僔僢僋';
        DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
        DefFontData.CharSet := CharSet;
      end;
  end;
end;

type
  PPattern = ^TPattern;
  TPattern = record
    Next: PPattern;
    Bitmap: TBitmap;
    BkColorRef: TColorRef;
    FgColorRef: TColorRef;
  end;

  TPatternManager = class(TObject)
  private
    List: PPattern;
    FLock: TRTLCriticalSection;
    function CreateBitmap(BkColor, FgColor: TColor): TBitmap;
  public
    constructor Create;
    destructor Destroy; override;
    function AllocPattern(BkColor, FgColor: TColorRef): PPattern;
    procedure FreePatterns;
    procedure Lock;
    procedure Unlock;
  end;

constructor TPatternManager.Create;
begin
  InitializeCriticalSection(FLock);
end;

destructor TPatternManager.Destroy;
begin
  FreePatterns;
  DeleteCriticalSection(FLock);
end;

procedure TPatternManager.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TPatternManager.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

function TPatternManager.AllocPattern(BkColor, FgColor: TColorRef): PPattern;
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
      GetMem(Result, SizeOf(TPattern));
      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;

procedure TPatternManager.FreePatterns;
var
  P: PPattern;
begin
  while List <> nil do
  begin
    P := List;
    with P^ do
    begin
      Lock;
      try
        List := Next
      finally
        Unlock;
      end;
      if Bitmap <> nil then Bitmap.Free;
    end;
    FreeMem(P);
  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;
  InitializeCriticalSection(BitmapImageLock);
  InitializeCriticalSection(CounterLock);
  StockPen := GetStockObject(BLACK_PEN);
  StockBrush := GetStockObject(HOLLOW_BRUSH);
  StockFont := GetStockObject(SYSTEM_FONT);
  StockIcon := LoadIcon(0, IDI_APPLICATION);
  InitDefFontData;
  FontManager := TResourceManager.Create(SizeOf(TFontData));
  PenManager := TResourceManager.Create(SizeOf(TPenData));
  BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  PatternManager := TPatternManager.Create;
  BitmapCanvasList := TThreadList.Create;
  CanvasList := TThreadList.Create;
  RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
  RegisterIntegerConsts(TypeInfo(TFontCharset), IdentToCharset, CharsetToIdent);
finalization
  PatternManager.Free;
  FileFormats.Free;
  ClipboardFormats.Free;
  FreeMemoryContexts;
  BitmapCanvasList.Free;
  CanvasList.Free;
  FontManager.Free;
  PenManager.Free;
  BrushManager.Free;
  DeleteObject(SystemPalette16);
  DeleteCriticalSection(BitmapImageLock);
  DeleteCriticalSection(CounterLock);
end.




总数:1 页次:1/1 首页 尾页  
总数:1 页次:1/1 首页 尾页  


该采集也在以下书单中



发表评论:
文本/html模式切换 插入图片 文本/html模式切换


附件:



NEWBT官方QQ群1: 276678893
可求档连环画,漫画;询问文本处理大师等软件使用技巧;求档softhub软件下载及使用技巧.
但不可"开车",严禁国家敏感话题,不可求档涉及版权的文档软件.
验证问题说明申请入群原因即可.

Copyright © 2005-2017 clq, All Rights Reserved
CLQ工作室 版权所有