{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit Graphics;

{$P+,S-,W-,R-}
{$C PRELOAD}

interface

uses WinTypes, WinProcs, SysUtils, Classes;

{ Graphics Objects }

type
  TColor = -(COLOR_ENDCOLORS + 1)..$2FFFFFF;

const
  clScrollBar = TColor(-COLOR_SCROLLBAR - 1);
  clBackground = TColor(-COLOR_BACKGROUND - 1);
  clActiveCaption = TColor(-COLOR_ACTIVECAPTION - 1);
  clInactiveCaption = TColor(-COLOR_INACTIVECAPTION - 1);
  clMenu = TColor(-COLOR_MENU - 1);
  clWindow = TColor(-COLOR_WINDOW - 1);
  clWindowFrame = TColor(-COLOR_WINDOWFRAME - 1);
  clMenuText = TColor(-COLOR_MENUTEXT - 1);
  clWindowText = TColor(-COLOR_WINDOWTEXT - 1);
  clCaptionText = TColor(-COLOR_CAPTIONTEXT - 1);
  clActiveBorder = TColor(-COLOR_ACTIVEBORDER - 1);
  clInactiveBorder = TColor(-COLOR_INACTIVEBORDER - 1);
  clAppWorkSpace = TColor(-COLOR_APPWORKSPACE - 1);
  clHighlight = TColor(-COLOR_HIGHLIGHT - 1);
  clHighlightText = TColor(-COLOR_HIGHLIGHTTEXT - 1);
  clBtnFace = TColor(-COLOR_BTNFACE - 1);
  clBtnShadow = TColor(-COLOR_BTNSHADOW - 1);
  clGrayText = TColor(-COLOR_GRAYTEXT - 1);
  clBtnText = TColor(-COLOR_BTNTEXT - 1);
  clInactiveCaptionText = TColor(-COLOR_INACTIVECAPTIONTEXT - 1);
  clBtnHighlight = TColor(-COLOR_BTNHIGHLIGHT - 1);

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

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;

type
  HMETAFILE = THandle;
  TExtension = string[3];

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

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

  TResData = record
    Handle: THandle;
  end;

  TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  TFontStyles = set of TFontStyle;
  TFontPitch = (fpDefault, fpVariable, fpFixed);
  TFontName = string[LF_FACESIZE - 1];

  TFontData = record
    Handle: HFont;
    Height: Integer;
    Pitch: TFontPitch;
    Style: TFontStyles;
    Name: TFontName;
  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;
  protected
    procedure Changed; dynamic;
  public
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TFont = class(TGraphicsObject)
  private
    FColor: TColor;
    FPixelsPerInch: Integer;
    procedure GetData(var FontData: TFontData);
    procedure SetData(const FontData: TFontData);
  protected
    function GetHandle: HFont;
    function GetHeight: Integer;
    function GetName: TFontName;
    function GetPitch: TFontPitch;
    function GetSize: Integer;
    function GetStyle: TFontStyles;
    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);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Handle: HFont read GetHandle write SetHandle;
    property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  published
    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;

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

  TCopyMode = Longint;

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

  TCanvas = class(TPersistent)
  private
    FHandle: HDC;
    State: TCanvasState;
    FFont: TFont;
    FPen: TPen;
    FBrush: TBrush;
    FPenPos: TPoint;
    FCopyMode: TCopyMode;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure CreateBrush;
    procedure CreateFont;
    procedure CreatePen;
    procedure BrushChanged(ABrush: TObject);
    procedure DeselectHandles;
    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);
    procedure RequiredState(ReqState: TCanvasState);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    procedure CreateHandle; virtual;
  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);
    procedure FillRect(const Rect: TRect);
    procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
    procedure FrameRect(const Rect: TRect);
    procedure LineTo(X, Y: Integer);
    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 Rectangle(X1, Y1, X2, Y2: Integer);
    procedure Refresh;
    procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
    procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
    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;
    property ClipRect: TRect read GetClipRect;
    property Handle: HDC read GetHandle write SetHandle;
    property PenPos: TPoint read GetPenPos write SetPenPos;
    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
    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;

  { The TGraphic class is a abstract base class for dealing with graphic images
    such as metafile, bitmaps and icons; but is not limited to such.
      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.
      Width - The native, unstretched, width of the graphic.
      OnChange - Called whenever the graphic changes }

  TGraphic = class(TPersistent)
  private
    FOnChange: TNotifyEvent;
    FModified: Boolean;
    FReserved: Byte;
    procedure SetModified(Value: Boolean);
  protected
    constructor Create; virtual;
    procedure Changed(Sender: TObject);
    procedure DefineProperties(Filer: TFiler); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
    function GetEmpty: Boolean; virtual; abstract;
    function GetHeight: Integer; virtual; abstract;
    function GetWidth: Integer; virtual; abstract;
    procedure ReadData(Stream: TStream); virtual;
    procedure SetHeight(Value: Integer); virtual; abstract;
    procedure SetWidth(Value: Integer); virtual; abstract;
    procedure WriteData(Stream: TStream); virtual;
  public
    procedure Assign(Source: TPersistent); override;
    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 Width: Integer read GetWidth write SetWidth;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  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.
      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 bitmap,
        the contents are thrown away and a blank metafile is returned. }
  TPicture = class(TPersistent)
  private
    FGraphic: TGraphic;
    FOnChange: TNotifyEvent;
    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 Changed(Sender: TObject);
    procedure DefineProperties(Filer: TFiler); override;
  public
    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 RegisterClipboardFormat(AFormat: Word;
      AGraphicClass: TGraphicClass);
    property Bitmap: TBitmap read GetBitmap write SetBitmap;
    property Graphic: TGraphic read FGraphic write SetGraphic;
    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;
  end;

  { TMetafile }
  { TMetafile is an encapsulation of Windows metafile rendering.
      Handle - The metafile handle.
      Inch - The units per inch assumed by the metafile.  Changing this
        value changes the coordinate system and, therefore, the width
        and height of the metafile.  New metafiles default to the device
        LOGPIXELSPERINCH value given by Windows GDI. }

  TMetafileImage = class
  private
    FRefCount: Integer;
    FHandle: HMETAFILE;
    FWidth: Integer;
    FHeight: Integer;
    FInch: Word;
    FReserved: Word;
    procedure Reference;
    procedure Release;
  end;

  TMetafile = class(TGraphic)
  private
    FImage: TMetafileImage;
    function GetHandle: HMETAFILE;
    function GetInch: Word;
    procedure NewImage;
    procedure SetHandle(Value: HMETAFILE);
    procedure SetInch(Value: Word);
    procedure UniqueImage;
  protected
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); 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;
    property Handle: HMETAFILE read GetHandle write SetHandle;
    property Inch: Word read GetInch write SetInch;
  end;

  { TBitmap }
  { TBitmap is an encapuslation of a Windows HBITMAP and HPALETTE.  It manages
    the palette realizing automatically as well as having a Canvas to allow
    modifications to the palette.  Creating copies of a TBitmap is very fast
    since the handles 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 }

  TInternalImage = class
  private
    FRefCount: Integer;
    FMemoryImage: TMemoryStream;
    procedure Reference;
    procedure Release;
    procedure FreeHandle; virtual; abstract;
  end;

  TBitmapImage = class(TInternalImage)
  private
    FHandle: HBITMAP;
    FPalette: HBITMAP;
    FWidth: Integer;
    FHeight: Integer;
    FMonochrome: Boolean;
    FReserved: Byte;
    procedure FreeHandle; override;
  end;

  TBitmap = class(TGraphic)
  private
    FImage: TBitmapImage;
    FCanvas: TCanvas;
    procedure Changing(Sender: TObject);
    procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; AWidth,
      AHeight: Integer; AMonochrome: Boolean);
    procedure FreeContext;
    function GetCanvas: TCanvas;
    function GetHandle: HBITMAP;
    function GetMonochrome: Boolean;
    function GetPalette: HPALETTE;
    function GetTransparentColor: TColor;
    procedure HandleNeeded;
    procedure ReadStream(Size: Longint; Stream: TStream);
    procedure SetHandle(Value: HBITMAP);
    procedure SetMonochrome(Value: Boolean);
    procedure SetPalette(Value: HPALETTE);
    procedure MemoryImageNeeded;
    procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE; NewWidth,
      NewHeight: Integer; NewMonochrome: Boolean; NewImage: TMemoryStream);
    procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure ReadData(Stream: TStream); override;
    procedure SetWidth(Value: Integer); override;
    procedure SetHeight(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Dormant;
    procedure FreeImage;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromStream(Stream: TStream); override;
    function ReleaseHandle: 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 Monochrome: Boolean read GetMonochrome write SetMonochrome;
    property Palette: HPALETTE read GetPalette write SetPalette;
    property TransparentColor: TColor read GetTransparentColor;
  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(TInternalImage)
  private
    FHandle: HICON;
    procedure FreeHandle; override;
  end;

  TIcon = class(TGraphic)
  private
    FImage: TIconImage;
    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 SetWidth(Value: Integer); override;
    procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
      var APalette: HPALETTE); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromStream(Stream: TStream); override;
    function ReleaseHandle: HICON;
    procedure SaveToStream(Stream: TStream); override;
    property Handle: HICON read GetHandle write SetHandle;
  end;

  { TImageList }

  TImageList = class
  private
    FWidth: Integer;
    FHeight: Integer;
    FUsed: Longint;
    FDelta: Integer;
    FImage: TBitmap;
    FMask: TBitmap;
    FInfo: TList;
    function AllocateSpace: Integer;
    procedure CheckImage(Image: TBitmap);
    function GetCount: Integer;
  public
    constructor Create(AWidth, AHeight: Integer);
    destructor Destroy; override;
    function Add(Image, Mask: TBitmap): Integer;
    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
    procedure Replace(Index: Integer; Image, Mask: TBitmap);
    procedure ReplaceMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
    procedure Draw(Canvas: TCanvas; X, Y: Integer; Index: Integer);
    procedure Delete(Index: Integer);
    property Count: Integer read GetCount;
    property Delta: Integer read FDelta write FDelta;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
  end;

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

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

function MemAlloc(Size: Longint): Pointer;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  var ImageSize: Longint);
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;

procedure InitGraphics;
procedure PaletteChanged;
procedure FreeMemoryContexts;

implementation

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

uses Controls, Forms, Consts;

const
  csAllValid = [csHandleValid..csBrushValid];

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

{ Resource managers }

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

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

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

function GetHashCode(const Buffer; Count: Word): Word; assembler;
asm
        LES     DI,Buffer
        MOV     CX,Count
        XOR     AX,AX
@@1:    ROL     AX,5
        XOR     AL,ES:[DI]
        INC     DI
        LOOP    @@1
end;

function BlockCompare(const Buf1, Buf2; Count: Word): Boolean; assembler;
asm
        PUSH    DS
        LDS     SI,Buf1
        LES     DI,Buf2
        MOV     CX,Count
        XOR     AX,AX
        CLD
        REPE    CMPSB
        JNE     @@1
        INC     AX
@@1:    POP     DS
end;

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

function TResourceManager.AllocResource(const ResData): PResource;
var
  ResHash: Word;
begin
  ResHash := GetHashCode(ResData, ResDataSize);
  Result := ResList;
  while (Result <> nil) and ((Result^.HashCode <> ResHash) or
    not BlockCompare(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);
end;

procedure TResourceManager.FreeResource(Resource: PResource);
var
  P: PResource;
begin
  if Resource <> nil then
    with Resource^ do
    begin
      Dec(RefCount);
      if RefCount = 0 then
      begin
        if Handle <> 0 then DeleteObject(Handle);
        if Resource = ResList then ResList := Resource^.Next else
        begin
          P := ResList;
          while P^.Next <> Resource do P := P^.Next;
          P^.Next := Resource^.Next;
        end;
        FreeMem(Resource, ResDataSize + ResInfoSize);
      end;
    end;
end;

procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  const ResData);
var
  P: PResource;
begin
  P := GraphicsObject.FResource;
  GraphicsObject.FResource := AllocResource(ResData);
  if GraphicsObject.FResource <> P then GraphicsObject.Changed;
  FreeResource(P);
end;

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

{ Color mapping routines }

var
  CanvasList: TList;

function ColorToRGB(Color: TColor): Longint;
begin
  Result := Color;
  if Color < 0 then Result := GetSysColor(-Color - 1);
end;

procedure PaletteChanged;
var
  I: Integer;

  procedure ClearColor(Resource: PResource);
  begin
    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;
  end;

begin
  { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  for I := 0 to CanvasList.Count - 1 do
    TCanvas(CanvasList[I]).DeselectHandles;
  ClearColor(PenManager.ResList);
  ClearColor(BrushManager.ResList);
end;

type
  TColorEntry = record
    Value: TColor;
    Name: PChar;
  end;

const
  Colors: array[0..36] of TColorEntry = (
    (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: clScrollBar; Name: 'clScrollBar'),
    (Value: clBackground; Name: 'clBackground'),
    (Value: clActiveCaption; Name: 'clActiveCaption'),
    (Value: clInactiveCaption; Name: 'clInactiveCaption'),
    (Value: clMenu; Name: 'clMenu'),
    (Value: clWindow; Name: 'clWindow'),
    (Value: clWindowFrame; Name: 'clWindowFrame'),
    (Value: clMenuText; Name: 'clMenuText'),
    (Value: clWindowText; Name: 'clWindowText'),
    (Value: clCaptionText; Name: 'clCaptionText'),
    (Value: clActiveBorder; Name: 'clActiveBorder'),
    (Value: clInactiveBorder; Name: 'clInactiveBorder'),
    (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
    (Value: clHighlight; Name: 'clHighlight'),
    (Value: clHighlightText; Name: 'clHighlightText'),
    (Value: clBtnFace; Name: 'clBtnFace'),
    (Value: clBtnShadow; Name: 'clBtnShadow'),
    (Value: clGrayText; Name: 'clGrayText'),
    (Value: clBtnText; Name: 'clBtnText'),
    (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
    (Value: clBtnHighlight; Name: 'clBtnHighlight'));

function ColorToString(Color: TColor): string;
begin
  if not ColorToIdent(Color, Result) then
    FmtStr(Result, '$%.8x', [Color]);
end;

function StringToColor(S: string): TColor;
var
  L: Longint;
  E: Integer;
begin
  if not IdentToColor(S, Longint(Result)) then
  begin
    Val(S, L, E);
    if E <> 0 then raise Exception.Create(LoadStr(SInvalidInteger));
    if (L < Low(TColor)) or (L > High(TColor)) then
      raise Exception.Create(
        FmtLoadStr(SOutOfRange, [Low(TColor), High(TColor)]));
    Result := TColor(L);
  end;
end;

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

function ColorToIdent(Color: Longint; var Ident: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := Low(Colors) to High(Colors) do
    if Colors[I].Value = Color then
    begin
      Result := True;
      Ident := StrPas(Colors[I].Name);
      Exit;
    end;
end;

function IdentToColor(const Ident: string; var Color: Longint): Boolean;
var
  I: Integer;
  Text: array[0..63] of Char;
begin
  Result := False;
  StrPLCopy(Text, Ident, SizeOf(Text) - 1);
  for I := Low(Colors) to High(Colors) do
    if StrIComp(Colors[I].Name, Text) = 0 then
    begin
      Result := True;
      Color := Colors[I].Value;
      Exit;
    end;
end;

{ TGraphicsObject }

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

{ TFont }

const
  DefFontData: TFontData = (
    Handle: 0;
    Height: 0;
    Pitch: fpDefault;
    Style: [];
    Name: 'System');

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

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

procedure TFont.Assign(Source: TPersistent);
begin
  if Source is TFont then
  begin
    FontManager.AssignResource(Self, TFont(Source).FResource);
    Color := TFont(Source).Color;
    if PixelsPerInch <> TFont(Source).PixelsPerInch then
      Size := TFont(Source).Size;
    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
  FontManager.ChangeResource(Self, FontData);
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
      with LogFont do
      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 := DEFAULT_CHARSET;
        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;
      end;
      Handle := CreateFontIndirect(LogFont);
    end;
    Result := Handle;
  end;
end;

procedure TFont.SetHandle(Value: HFont);
var
  FontData: TFontData;
begin
  FontData := DefFontData;
  FontData.Handle := Value;
  SetData(FontData);
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;

{ 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
    PenManager.AssignResource(Self, TPen(Source).FResource);
    SetMode(TPen(Source).FMode);
    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
  PenManager.ChangeResource(Self, PenData);
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
      with LogPen do
      begin
        lopnStyle := PenStyles[Pen.Style];
        lopnWidth.X := Pen.Width;
        lopnColor := ColorToRGB(Pen.Color);
      end;
      Handle := CreatePenIndirect(LogPen);
    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
    BrushManager.AssignResource(Self, TBrush(Source).FResource);
    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
  BrushManager.ChangeResource(Self, BrushData);
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
      with LogBrush do
      begin
        if Brush.Bitmap <> nil then
        begin
          lbStyle := BS_PATTERN;
          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;
    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;

{ TCanvas }

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

destructor TCanvas.Destroy;
begin
  CanvasList.Remove(Self);
  SetHandle(0);
  FFont.Free;
  FPen.Free;
  FBrush.Free;
  inherited Destroy;
end;

procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid]);
  WinProcs.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
  MonoBmp: TBitmap;
  crBack, crText: TColorRef;
begin
  if Bitmap = nil then Exit;
  Changing;
  MonoBmp := TBitmap.Create;
  try
    MonoBmp.Assign(Bitmap);
    MonoBmp.Canvas.Brush.Color := Color;
    MonoBmp.Monochrome := False;
    MonoBmp.Monochrome := True;
    Bitmap.Canvas.RequiredState([csHandleValid]);
    MonoBmp.Canvas.RequiredState([csHandleValid]);
    RequiredState([csHandleValid, csBrushValid]);
    StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
      Dest.Bottom - Dest.Top, Bitmap.Canvas.FHandle, Source.Left, Source.Top,
      Source.Right - Source.Left, Source.Bottom - Source.Top, SrcCopy);
    crText := SetTextColor(FHandle, 0);
    crBack := SetBkColor(FHandle, $FFFFFF);
    StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
      Dest.Bottom - Dest.Top, MonoBmp.Canvas.FHandle, Source.Left, Source.Top,
      Source.Right - Source.Left, Source.Bottom - Source.Top, ROP_DSPDxax);
    SetTextColor(FHandle, crText);
    SetBkColor(FHandle, crBack);
  finally
    MonoBmp.Free;
  end;
  Changed;
end;

procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  WinProcs.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]);
  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]);
  WinProcs.DrawFocusRect(FHandle, Rect);
  Changed;
end;

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

procedure TCanvas.FillRect(const Rect: TRect);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid]);
  WinProcs.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]);
  WinProcs.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  Changed;
end;

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

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

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

procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csPenValid, csBrushValid]);
  WinProcs.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]);
  WinProcs.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
  Changed;
end;

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

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

procedure TCanvas.Refresh;
begin
  DeselectHandles;
end;

procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
  Changing;
  RequiredState([csHandleValid, csBrushValid, csPenValid]);
  WinProcs.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;

procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
begin
  Changing;
  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  WinProcs.TextOut(FHandle, X, Y, @Text[1], Length(Text));
  MoveTo(X + TextWidth(Text), Y);
  Changed;
end;

procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
var
  Options: Integer;
begin
  Changing;
  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  Options := ETO_CLIPPED;
  if Brush.Style <> bsClear then Inc(Options, ETO_OPAQUE);
  WinProcs.ExtTextOut(FHandle, X, Y, Options, @Rect, @Text[1], Length(Text), nil);
  Changed;
end;

function TCanvas.TextWidth(const Text: String): Integer;
var
  Extent: TSize;
begin
  RequiredState([csHandleValid, csFontValid]);
  if WinProcs.GetTextExtentPoint(FHandle, @Text[1], Length(Text), Extent) then
    TextWidth := Extent.cX
  else TextWidth := 0;
end;

function TCanvas.TextHeight(const Text: String): Integer;
var
  Extent: TSize;
begin
  RequiredState([csHandleValid, csFontValid]);
  if WinProcs.GetTextExtentPoint(FHandle, @Text[1], Length(Text), Extent) then
    TextHeight := Extent.cY
  else TextHeight := 0;
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]);
  WinProcs.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 := WinProcs.GetPixel(FHandle, X, Y);
end;

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

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

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

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

procedure TCanvas.CreateHandle;
begin
end;

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

procedure TCanvas.RequiredState(ReqState: TCanvasState);
var
  NeededState: TCanvasState;
begin
  NeededState := ReqState - State;
  if NeededState <> [] then
  begin
    if csHandleValid in NeededState then
    begin
      CreateHandle;
      if FHandle = 0 then
        raise EInvalidOperation.Create(LoadStr(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);
  SetBkColor(FHandle, ColorToRGB(Brush.Color));
  if Brush.Style = bsSolid then
    SetBkMode(FHandle, OPAQUE)
  else
    SetBkMode(FHandle, TRANSPARENT);
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 }

{ Icon and cursor types }

const
  rc3_StockIcon = 0;
  rc3_Icon = 1;
  rc3_Cursor = 2;

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

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

  PIconMem = ^TIconMem;
  TIconMem = record
    HotSpotX: Word;
    HotSpotY: Word;
    Width: Word;
    Height: Word;
    Bits: Word;
    ColorSize: Word;
  end;

{ Metafile types }

const
  WMFKey = $9AC6CDD7;
  WMFWord = $CDD7;

type
  PMetafileHeader = ^TMetafileHeader;
  TMetafileHeader = record
    Key: Longint;
    Handle: THandle;
    Box: TRect;
    Inch: Word;
    Reserved: Longint;
    CheckSum: Word;
  end;

{ Exception routines }

procedure InvalidOperation(Str: Word); near;
begin
  raise EInvalidGraphicOperation.Create(LoadStr(Str));
end;

procedure InvalidGraphic(Str: Word); near;
begin
  raise EInvalidGraphic.Create(LoadStr(Str));
end;

procedure InvalidBitmap; near;
begin
  InvalidGraphic(SInvalidBitmap);
end;

procedure InvalidIcon; near;
begin
  InvalidGraphic(SInvalidIcon);
end;

procedure InvalidMetafile; near;
begin
  InvalidGraphic(SInvalidMetafile);
end;

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

function MemAlloc(Size: Longint): Pointer;
var
  Handle: THandle;
begin
  if Size < 65535 then
    GetMem(Result, Size)
  else
  begin
    Handle := GlobalAlloc(HeapAllocFlags, Size);
    Result := GlobalLock(Handle);
  end;
end;

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

  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 OutOfResources;
    try
      Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
      if Result = 0 then OutOfResources;
    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;
  DeleteDC(Mem1);
  DeleteDC(Mem2);
end;

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

function PaletteFromW3DIB(var BI: TBitmapInfo): HPALETTE;
var
  DstPal: PLogPalette;
  Colors, n: Integer;
  Size: Longint;
  DC: HDC;
  Focus: HWND;
  Pal: array[0..15] of TPaletteEntry;
  SysPalSize: Integer;
  I: Integer;
begin
  Result := 0;

  { If the ClrUsed field of the header is non-zero, it means that we could
    have a short color table }
  with BI.bmiHeader do
    if biClrUsed <> 0 then
      Colors := biClrUsed
    else
      Colors := GetDInColors(biBitCount);

  if Colors <= 2 then Exit;

  Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
  DstPal := MemAlloc(Size);
  try
    FillChar(DstPal^, Size, 0);
    with DstPal^ do
    begin
      palNumEntries := Colors;
      palVersion := $300;
      Focus := GetFocus;
      DC := GetDC(Focus);
      try
        SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
        if (Colors = 16) and (SysPalSize >= 16) then
        begin
          { Ignore the disk image of the palette for 16 color bitmaps use
            instead the first 8 and last 8 of the current system palette }
          GetSystemPaletteEntries(DC, 0, 8, palPalEntry);
          I := 8;
          GetSystemPaletteEntries(DC, SysPalSize - I, I, palPalEntry[I]);
        end
        else
          { Copy the palette for all others (i.e. 256 colors) }
          for N := 0 to Colors - 1 do
          begin
            palPalEntry[N].peRed := BI.bmiColors[N].rgbRed;
            palPalEntry[N].peGreen := BI.bmiColors[N].rgbGreen;
            palPalEntry[N].peBlue := BI.bmiColors[N].rgbBlue;
            palPalEntry[N].peFlags := 0;
          end;
      finally
        ReleaseDC(Focus, DC);
      end;
    end;
    Result := CreatePalette(DstPal^);
  finally
    FreeMem(DstPal, Size);
  end;
end;

procedure ReadWin3DIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  HeaderSize: Longint; ImageSize: Longint);
var
  Size: Word;
  Focus: HWND;
  DC: HDC;
  BitsMem: Pointer;
  BitmapHeader: TBitmapInfoHeader;
  BitmapInfo: PBitmapInfo;
  OldPal: HPALETTE;
  MaxSize: Longint;
begin
  Stream.Read(Pointer(Longint(@BitmapHeader) + SizeOf(Longint))^,
    SizeOf(TBitmapInfoHeader) - SizeOf(Longint));
  BitmapHeader.biSize := HeaderSize;

  { check number of planes. Windows 3.x supports only 1 plane DIBS }
  if BitmapHeader.biPlanes <> 1 then InvalidBitmap;

  with BitmapHeader do
  begin
    if biClrUsed = 0 then
      biClrUsed := GetDInColors(biBitCount);
    Size := biClrUsed * SizeOf(TRgbQuad);
  end;

  BitmapInfo := MemAlloc(Size + SizeOf(TBitmapInfoHeader));
  try
    with BitmapInfo^ do
    begin
      bmiHeader := BitmapHeader;
      Stream.Read(bmiColors, Size);

      { now we've got the color table. Create a pallete from it }
      Pal := PaletteFromW3DIB(BitmapInfo^);

      { some applications do not fill in the SizeImage field in the header.
        (Actually the truth is more likely that some drivers do not fill the field
        in and the apps do not compensate for these buggy drivers.) Therefore, if
        this field is 0, we will compute the size. }
      with bmiHeader do
      begin
        Dec(ImageSize, SizeOf(TBitmapInfoHeader) + Size);
        if biSizeImage <> 0 then
          if biSizeImage < ImageSize then ImageSize := biSizeImage;
        BitsMem := MemAlloc(ImageSize);
        try
          Stream.Read(BitsMem^, ImageSize);

          { we use the handle of the window with the focus (which, if this routine
            is called from a menu command, will be this window) in order to guarantee
            that the realized palette will have first priority on the system palette }
          Focus := GetFocus;
          DC := GetDC(Focus);
          if DC = 0 then OutOfResources;
          try
            if Pal <> 0 then
            begin
              { select and realize our palette we have gotten the DC of the focus
                window just to make sure that all our colors are mapped }
              OldPal := SelectPalette(DC, Pal, False);
              RealizePalette(DC);
            end
            else
              OldPal := 0;

            try
              Bits := CreateDIBitmap(DC, BitmapInfo^.bmiHeader,  CBM_INIT, BitsMem,
                BitmapInfo^, DIB_RGB_COLORS);
              if Bits = 0 then OutOfResources;
            finally
              if OldPal <> 0 then
                SelectPalette(DC, OldPal, False);
            end;
          finally
            ReleaseDC(Focus, DC);
          end;
        finally
          FreeMem(BitsMem, ImageSize);
        end;
      end;
    end;
  finally
    FreeMem(BitmapInfo, Size + SizeOf(TBitmapInfoHeader));
  end;
end;

{ This routine accepts a pointer to a BITMAPCORE structure and creates a GDI
  logical palette from the color table which follows it, for 2, 16 and 256
  color bitmaps. It returns 0 for all others, including 24-bit DIB's

  It differs from the windows DIB routine in two respects:
  1) The PM 1.x DIB must have complete color tables, since there is no ClrUsed
     field in the header
  2) The size of the color table entries is 3 bytes, not 4 bytes. }

function PaletteFromPM1DIB(var BC: TBitmapCoreInfo): HPALETTE;
var
  DstPal: PLogPalette;
  Colors, N: Integer;
  Size: Longint;
begin
  Result := 0;
  Colors := GetDInColors(BC.bmciHeader.bcBitCount);
  if Colors = 0 then Exit;

  Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
  DstPal := MemAlloc(Size);
  FillChar(DstPal^, Size, 0);
  try
    with DstPal^ do
    begin
      palNumEntries := Colors;
      palVersion := $300;
      for N := 0 to Colors - 1 do
      begin
        palPalEntry[N].peRed := BC.bmciColors[N].rgbtRed;
        palPalEntry[N].peGreen := BC.bmciColors[N].rgbtGreen;
        palPalEntry[N].peBlue := BC.bmciColors[N].rgbtBlue;
        palPalEntry[N].peFlags := 0;
      end;
    end;
    Result := CreatePalette(DstPal^);
  finally
    FreeMem(DstPal, Size);
  end;
end;

{ Read a PM 1.x device independent bitmap. }

procedure ReadPM1DIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  HeaderSize: Longint; ImageSize: Longint);
var
  Size: Word;
  Focus: HWND;
  DC: HDC;
  BitsMem: Pointer;
  BitmapHeader: TBitmapCoreHeader;
  BitmapInfo: PBitmapCoreInfo;
  OldPal: HPALETTE;
  MaxSize: Longint;
begin
  Stream.Read(Pointer(Longint(@BitmapHeader) + SizeOf(HeaderSize))^,
    SizeOf(BitmapHeader) - SizeOf(Longint));
  BitmapHeader.bcSize := HeaderSize;
  if BitmapHeader.bcPlanes <> 1 then InvalidBitmap;

  Size := GetDInColors(BitmapHeader.bcBitCount) * SizeOf(TRGBTriple);
  BitmapInfo := MemAlloc(Size + SizeOf(TBitmapCoreInfo));
  try
    with BitmapInfo^ do
    begin
      bmciHeader := BitmapHeader;
      Stream.Read(bmciColors, Size);

      Pal := PaletteFromPM1DIB(BitmapInfo^);

      { size of image = Width of a scan line * number of scan lines Width = Pixel
        Width * bits per pixel rounded to a DWORD boundary }
      with bmciHeader do
        MaxSize := ((((bcWidth * bcBitCount) + 31) div 32) * 4) * bcHeight;

      BitsMem := MemAlloc(MaxSize);
      try
        Stream.Read(BitsMem^, MaxSize);

        Focus := GetFocus;
        DC := GetDC(Focus);
        if DC = 0 then OutOfResources;
        try
          OldPal := 0;
          if Pal <> 0 then
          begin
            OldPal := SelectPalette(DC, Pal, False);
            RealizePalette(DC);
          end;
          try
            Bits := CreateDIBitmap(DC, PBitmapInfoHeader(@bmciHeader)^, CBM_INIT,
              BitsMem, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS);
            if Bits = 0 then OutOfResources;
          finally
            if OldPal <> 0 then
              SelectPalette(DC, OldPal, False);
          end;
        finally
          ReleaseDC(Focus, DC);
        end;
      finally
        FreeMem(BitsMem, MaxSize);
      end;
    end;
  finally
    FreeMem(BitmapInfo, Size + SizeOf(TBitmapCoreInfo));
  end;
end;

procedure ReadDIB(Stream: TStream; var Bits: HBITMAP; var Pal: HPALETTE;
  Size: Longint);
var
  HeaderSize: Longint;
begin
  Stream.Read(HeaderSize, SizeOf(HeaderSize));
  if HeaderSize = SizeOf(TBitmapInfoHeader) then
    ReadWin3DIB(Stream, Bits, Pal, HeaderSize, Size)
  else if HeaderSize = SizeOf(TBitmapCoreHeader) then
    ReadPM1DIB(Stream, Bits, Pal, HeaderSize, Size)
  else
    InvalidBitmap;
end;

function WidthBytes(I: Longint): Longint;
begin
  Result := ((I + 31) div 32) * 4;
end;

function MonoWidthBytes(I: Longint): Longint;
begin
  Result := ((I + 15) div 16) * 2;
end;

procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);
type
  PLongArray = ^TLongArray;
  TLongArray = array[0..1] of Longint;
var
  Temp: HBITMAP;
  NumColors: Integer;
  DC: HDC;
  Bits: Pointer;
  Colors: PLongArray;
  IconSize: TPoint;
begin
  IconSize.X := GetSystemMetrics(SM_CXICON);
  IconSize.Y := GetSystemMetrics(SM_CYICON);
  with BI do
  begin
    biHeight := biHeight shr 1; { Size in record is doubled }
    biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
    NumColors := GetDInColors(biBitCount);
  end;
  DC := GetDC(0);
  if DC = 0 then OutOfResources;
  try
    Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
    Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
    if Temp = 0 then OutOfResources;
    try
      XorBits := DupBits(Temp, IconSize, False);
    finally
      DeleteObject(Temp);
    end;
    with BI do
    begin
      Inc(Longint(Bits), biSizeImage);
      biBitCount := 1;
      biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
      biClrUsed := 2;
      biClrImportant := 2;
    end;
    Colors := Pointer(Longint(@BI) + SizeOf(BI));
    Colors^[0] := 0;
    Colors^[1] := $FFFFFF;
    Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
    if Temp = 0 then OutOfResources;
    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);
type
  PIconRecArray = ^TIconRecArray;
  TIconRecArray = array[0..300] of TIconRec;
var
  List: PIconRecArray;
  HeaderLen, Length: Integer;
  Colors, BitsPerPixel: Word;
  C1, C2, N, Index: Integer;
  IconSize: TPoint;
  DC: HDC;
  BI: PBitmapInfoHeader;
  ResData: Pointer;
  XorBits, AndBits: HBITMAP;
  XorInfo, AndInfo: WinTypes.TBitmap;
  XorMem, AndMem: Pointer;
  XorLen, AndLen: Integer;
begin
  HeaderLen := SizeOf(TIconRec) * ImageCount;
  List := MemAlloc(HeaderLen);
  try
    Stream.Read(List^, HeaderLen);
    IconSize.X := GetSystemMetrics(SM_CXICON);
    IconSize.Y := GetSystemMetrics(SM_CYICON);
    DC := GetDC(0);
    if DC = 0 then OutOfResources;
    try
      BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
      if BitsPerPixel = 24 then
        Colors := 0
      else
        Colors := 1 shl BitsPerPixel;
    finally
      ReleaseDC(0, DC);
    end;
    Index := -1;

    { 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;
        Break;
      end
      else if Index = -1 then
      begin
        if C1 <= Colors then
        begin
          Index := N;
          C2 := List^[N].Colors;
        end;
      end
      else
        if C1 > C2 then
          Index := N;
    end;
    if Index = -1 then Index := 0;
    with List^[Index] do
    begin
      if DIBSize >= 65535 then InvalidIcon;
      BI := MemAlloc(DIBSize);
      try
        Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
        Stream.Read(BI^, DIBSize);
        TwoBitsFromDIB(BI^, XorBits, AndBits);
        GetObject(AndBits, SizeOf(WinTypes.TBitmap), @AndInfo);
        GetObject(XorBits, SizeOf(WinTypes.TBitmap), @XorInfo);
        with AndInfo do
          AndLen := bmWidthBytes * bmHeight * bmPlanes;
        with XorInfo do
          XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
        Length := AndLen + XorLen;
        ResData := MemAlloc(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 OutOfResources;
        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 ReadMetafile(Stream: TStream; var Metafile: HMETAFILE; Length: Longint;
  var Width, Height: Integer; var Inch: Word);
var
  WMF: TMetafileHeader;
  Bits: THANDLE;
  BitMem: Pointer;
begin
  Stream.Read(WMF, SizeOf(WMF));
  if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
    InvalidMetafile;
  Dec(Length, SizeOf(WMF));
  Bits := GlobalAlloc(GMEM_MOVEABLE, Length);
  try
    BitMem := GlobalLock(Bits);
    Stream.Read(BitMem^, Length);
    Metafile := SetMetaFileBitsBetter(Bits);
    if Metafile = 0 then InvalidMetafile;
    Width := WMF.Box.right - WMF.Box.left;
    Height := WMF.Box.bottom - WMF.Box.top;
    Inch := WMF.Inch;
  except
    GlobalUnlock(Bits);
    GlobalFree(Bits);
    raise;
  end;
end;

procedure LoadMetafile(const Name: string; var Metafile: HMETAFILE;
  var Width, Height: Integer; var Inch: Word );
var
  Stream: TStream;
  Reader: TReader;
  Length: Longint;
begin
  Stream := TFileStream.Create(Name, fmOpenRead);
  try
    Length := Stream.Size;
    ReadMetafile(Stream, Metafile, Length, Width, Height, Inch);
  finally
    Stream.Free;
  end;
end;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  Colors: Integer);
var
  BM: WinTypes.TBitmap;
begin
  GetObject(Bitmap, SizeOf(BM), @BM);
  with BI do
  begin
    biSize := SizeOf(BI);
    biWidth := BM.bmWidth;
    biHeight := BM.bmHeight;
    if Colors <> 0 then
      case Colors of
        2: biBitCount := 1;
        16: biBitCount := 4;
        256: biBitCount := 8;
      end
    else biBitCount := BM.bmBitsPixel * BM.bmPlanes;
    biPlanes := 1;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
    biCompression := BI_RGB;
    if biBitCount in [16, 32] then biBitCount := 24;
    biSizeImage := WidthBytes(biWidth * biBitCount) * biHeight;
  end;
end;

procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  var ImageSize: Longint; Colors: Integer);
var
  BI: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  with BI do
  begin
    case biBitCount of
      24: InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    else
      InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
       (1 shl biBitCount);
    end;
  end;
  ImageSize := BI.biSizeImage;
end;

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

function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
  OldPal: HPALETTE;
  Focus: HWND;
  DC: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  OldPal := 0;
  Focus := GetFocus;
  DC := GetDC(Focus);
  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);
    ReleaseDC(Focus, DC);
  end;
end;

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

function DIBFromBit(Src: HBITMAP; Pal: HPALETTE; Colors: Integer;
  var Length: Longint): Pointer;
var
  HeaderSize: Integer;
  ImageSize: Longint;
  FileHeader: PBitmapFileHeader;
  BI: PBitmapInfoHeader;
  Bits: Pointer;
begin
  if Src = 0 then InvalidBitmap;
  InternalGetDIBSizes(Src, HeaderSize, ImageSize, Colors);
  Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize;
  Result := MemAlloc(Length);
  try
    FillChar(Result^, Length, 0);
    FileHeader := Result;
    with FileHeader^ do
    begin
      bfType := $4D42;
      bfSize := Length;
      bfOffBits := SizeOf(FileHeader^) + HeaderSize;
    end;
    BI := PBitmapInfoHeader(Longint(FileHeader) + SizeOf(FileHeader^));
    Bits := Pointer(Longint(BI) + HeaderSize);
    InternalGetDIB(Src, Pal, BI^, Bits^, Colors);
  except
    FreeMem(Result, Length);
    raise;
  end;
end;

procedure WriteBitmap(Stream: TStream; Bitmap: HBITMAP; Pal: HPALETTE;
  WriteLength: Boolean);
var
  Length: Longint;
  Data: Pointer;
begin
  Data := DIBFromBit(Bitmap, Pal, 0, Length);
  try
    if WriteLength then Stream.Write(Length, SizeOf(Length));
    Stream.Write(Data^, Length);
  finally
    FreeMem(Data, Length);
  end;
end;

procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
var
  Length: Longint;
  MonoLength, ColorLength: Longint;
  CI: TCursorOrIcon;
  List: TIconRec;
  IconMem: PIconMem;
  Mono, Color: HBITMAP;
  MonoMem, ColorMem: Pointer;
  MonoSkip, ColorSkip: Integer;
  Planes, Bits: Word;
  IconSize: TPoint;
  IconColors: Integer;
  DC: HDC;
begin
  FillChar(CI, SizeOf(CI), 0);
  FillChar(List, SizeOf(List), 0);
  IconMem := PIconMem(LockResource(Icon));
  if IconMem = nil then InvalidIcon;
  DC := GetDC(0);
  if DC = 0 then OutOfResources;
  try
    Bits := GetDeviceCaps(DC, BITSPIXEL);
    Planes := GetDeviceCaps(DC, WinTypes.PLANES);
  finally
    ReleaseDC(0, DC);
  end;
  IconSize.X := IconMem^.Width;
  IconSize.Y := IconMem^.Height;
  MonoMem := Pointer(Longint(IconMem) + SizeOf(IconMem^));
  ColorMem := Pointer(Longint(MonoMem) + MonoWidthBytes(IconSize.X) * IconSize.Y);
  Color := CreateBitmap(IconSize.X, IconSize.Y, Planes, Bits, ColorMem);
  try
    Mono := CreateBitmap(IconSize.X, IconSize.Y, 1, 1, MonoMem);
    try
      IconColors := 16;
      if (Bits = 1) and (Planes = 1) then IconColors := 2;
      ColorMem := DIBFromBit(Color, 0, IconColors, ColorLength);
      try
        MonoMem := DIBFromBit(Mono, 0, 2, MonoLength);
        try
          { Skip the header information in mono bitmaps }
          MonoSkip := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
            SizeOf(TRGBQuad) * 2;
          { Skip the file header for color bitmaps }
          ColorSkip := SizeOf(TBitmapFileHeader);
          Length := SizeOf(CI) + SizeOf(List) + ColorLength - ColorSkip +
            MonoLength - MonoSkip;
          if WriteLength then Stream.Write(Length, SizeOf(Length));
          with CI do
          begin
            CI.wType := RC3_ICON;
            CI.Count := 1;
          end;
          Stream.Write(CI, SizeOf(CI));
          with List do
          begin
            Width := IconSize.X;
            Height := IconSize.Y;
            Colors := IconColors;
            DIBSize := MonoLength - MonoSkip + ColorLength - ColorSkip;
            DIBOffset := SizeOf(CI) + SizeOf(List);
          end;
          Stream.Write(List, SizeOf(List));
          with PBitmapInfoHeader(Longint(ColorMem) + ColorSkip)^ do
            Inc(biHeight, biHeight); { color height includes mono bits }
          Stream.Write(Pointer(Longint(ColorMem) + ColorSkip)^,
            ColorLength - ColorSkip);
          Stream.Write(Pointer(Longint(MonoMem) + MonoSkip)^, MonoLength -
            MonoSkip);
        finally
          FreeMem(MonoMem, MonoLength);
        end;
      finally
        FreeMem(ColorMem, ColorLength);
      end;
    finally
      DeleteObject(Mono);
    end;
  finally
    DeleteObject(Color);
  end;
end;

procedure WriteMetafile(Stream: TStream; Metafile: HMETAFILE; WriteLength: Boolean;
  AWidth, AHeight: Integer; AInch: Word);
var
  WMF: TMetafileHeader;
  MetafileCopy: HMETAFILE;
  MetaMemHandle: HMETAFILE;
  MetaMem: Pointer;
  Length: Longint;
begin
  FillChar(WMF, SizeOf(WMF), 0);
  with WMF do
  begin
    Key := WMFKEY;
    Box := Rect(0, 0, AWidth, AHeight);
    Inch := AInch;
    CheckSum := ComputeAldusChecksum(WMF);
  end;
  MetafileCopy := CopyMetafile(Metafile, nil);
  if MetafileCopy = 0 then OutOfResources;
  try
    MetaMemHandle := GetMetaFileBits(MetafileCopy);
  except
    DeleteMetaFile(MetafileCopy);
    raise;
  end;
  try
    MetaMem := GlobalLock(MetaMemHandle);
    try
      Length := GlobalSize(MetaMemHandle) + SizeOf(WMF);
      if WriteLength then Stream.Write(Length, SizeOf(Length));
      Stream.Write(WMF, SizeOf(WMF));
      Stream.Write(MetaMem^, Length - SizeOf(WMF));
    finally
      GlobalUnlock(MetaMemHandle);
    end;
  finally
    GlobalFree(MetaMemHandle);
  end;
end;

{ THandleCache }

type
  THandleCache = class(TList)
  private
    procedure IndexOfRef(Handle: Word; var Index: Integer);
  public
    procedure Reference(Handle: Word);
    function Release(Handle: Word): Boolean;
    function RefCount(Handle: Word): Word;
  end;

{ Scans the TList's List property for a entry with the low word matching Handle,
  the high word is the reference count }
procedure THandleCache.IndexOfRef(Handle: Word; var Index: Integer);
var
  I: Integer;
begin
  Index := -1;
  for I := 0 to Count - 1 do
    if LongRec(List^[I]).Lo = Handle then
    begin
      Index := I;
      Exit;
    end;
end;

procedure THandleCache.Reference(Handle: Word);
var
  I: Integer;
begin
  if Handle = 0 then Exit;
  IndexOfRef(Handle, I);
  if I < 0 then Add(Pointer(Longint(Handle) + $10000))
  else Inc(LongRec(List^[I]).Hi);
end;

{ Returns true if the reference count goes to zero }
function THandleCache.Release(Handle: Word): Boolean;
var
  I: Integer;
begin
  Result := False;
  IndexOfRef(Handle, I);
  if I < 0 then Exit;
  Dec(LongRec(List^[I]).Hi);
  if (LongRec(List^[I]).Hi) = 0 then
  begin
    Delete(I);
    Result := True;
  end;
end;

function THandleCache.RefCount(Handle: Word): Word;
var
  I: Integer;
begin
  IndexOfRef(Handle, I);
  Result := 0;
  if I >= 0 then Result := LongRec(List^[I]).Hi;
end;

{ Maintain handle caches for the Bitmaps, Palettes, Metafile handles, and
  Icons. }
var
  BitmapHandles: THandleCache;
  PaletteHandles: THandleCache;
  MetafileHandles: THandleCache;
  IconHandles: THandleCache;

{ TGraphic }

constructor TGraphic.Create;
begin
  inherited Create;
end;

procedure TGraphic.Assign(Source: TPersistent);
begin
  if (Source is TPicture) and (TPicture(Source).Graphic is ClassType) then
    Assign(TPicture(Source).Graphic)
  else
    inherited Assign(Source);
end;

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

procedure TGraphic.DefineProperties(Filer: TFiler);
begin
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, not Empty);
end;

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

procedure TGraphic.LoadFromFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
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.ReadData(Stream: TStream);
begin
  LoadFromStream(Stream);
end;

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

{ TPicture }

type
  PFileFormat = ^TFileFormat;
  TFileFormat = record
    GraphicClass: TGraphicClass;
    Extension: TExtension;
    Description: PString;
    Next: PFileFormat;
  end;

var
  SMetafiles, SIcons, SBitmaps: string[15]; 

{ Pre-registered file formats }
const
  MetafileFormat: TFileFormat = (
    GraphicClass: TMetafile;
    Extension: 'WMF';
    Description: @SMetafiles);
  IconFormat: TFileFormat = (
    GraphicClass: TIcon;
    Extension: 'ICO';
    Description: @SIcons;
    Next: @MetafileFormat);
  BitmapFormat: TFileFormat = (
    GraphicClass: TBitmap;
    Extension: 'BMP';
    Description: @SBitmaps;
    Next: @IconFormat);
  FileFormatList: PFileFormat = @BitmapFormat;

type
  PClipboardFormat = ^TClipboardFormat;
  TClipboardFormat = record
    GraphicClass: TGraphicClass;
    Format: Word;
    Next: PClipboardFormat;
  end;

const
  MetafileClipFormat: TClipboardFormat = (
    GraphicClass: TMetafile;
    Format: CF_METAFILEPICT);
  BitmapClipFormat: TClipboardFormat = (
    GraphicClass: TBitmap;
    Format: CF_BITMAP;
    Next: @MetafileClipFormat);
  ClipboardFormatList: PClipboardFormat = @BitmapClipFormat;

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

procedure TPicture.ForceType(GraphicType: TGraphicClass);
begin
  if not (Graphic is GraphicType) then
  begin
    FGraphic.Free;
    FGraphic := nil;
    FGraphic := GraphicType.Create;
    FGraphic.OnChange := Changed;
    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 := TGraphic(Value.ClassType.Create);
    NewGraphic.Assign(Value);
    NewGraphic.OnChange := Changed;
  end;
  try
    FGraphic.Free;
    FGraphic := NewGraphic;
    Changed(Self);
  except
    NewGraphic.Free;
    raise;
  end;
end;

{ Based on the extension of Filename, create the cooresponding TGraphic class
  and call its LoadFromFile method. }
procedure TPicture.LoadFromFile(const Filename: string);
var
  Ext: TExtension;
  Graphic: PFileFormat;
  I, L: Integer;
  NewGraphic: TGraphic;
begin
  L := Length(Filename);
  while (L > 0) and (Filename[L] <> '.') do Dec(L);
  Ext := '';
  if (Filename[L] = '.') and (Length(Filename) - L <= 3) then
    Ext := UpperCase(Copy(Filename, L + 1, 3));
  Graphic := FileFormatList;
  while Graphic <> nil do
    with Graphic^ do
    begin
      if Extension <> Ext then
        Graphic := Next
      else
      begin
        NewGraphic := GraphicClass.Create;
        try
          NewGraphic.LoadFromFile(Filename);
        except
          NewGraphic.Free;
          raise;
        end;
        FGraphic.Free;
        FGraphic := NewGraphic;
        FGraphic.OnChange := Changed;
        Changed(Self);
        Exit;
      end;
    end;
  raise EInvalidGraphic.Create(FmtLoadStr(SUnknownExtension, [Ext]));
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;
  Graphic: PClipboardFormat;
begin
  Graphic := ClipboardFormatList;
  while Graphic <> nil do
    with Graphic^ do
    begin
      if AFormat <> Format then
        Graphic := Next
      else
      begin
        NewGraphic := GraphicClass.Create;
        try
          NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
        except
          NewGraphic.Free;
          raise;
        end;
        FGraphic.Free;
        FGraphic := NewGraphic;
        FGraphic.OnChange := Changed;
        Changed(Self);
        Exit;
      end;
    end;
  InvalidGraphic(SUnknownClipboardFormat);
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;
var
  Graphic: PClipboardFormat;
begin
  Result := True;
  Graphic := ClipboardFormatList;
  while Graphic <> nil do
    with Graphic^ do
      if AFormat = Format then Exit
      else Graphic := Next;
  Result := False;
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;

{ Add AGraphicClass to the list of registered TGraphic classes. }

class procedure TPicture.RegisterFileFormat(const AExtension,
  ADescription: string; AGraphicClass: TGraphicClass);
var
  NewRec: PFileFormat;
begin
  New(NewRec);
  with NewRec^ do
  begin
    Extension := UpperCase(AExtension);
    GraphicClass := AGraphicClass;
    Description := NewStr(ADescription);
    Next := FileFormatList;
  end;
  FileFormatList := NewRec;
end;

class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  AGraphicClass: TGraphicClass);
var
  NewRec: PClipboardFormat;
begin
  New(NewRec);
  with NewRec^ do
  begin
    GraphicClass := AGraphicClass;
    Format := AFormat;
    Next := ClipboardFormatList;
  end;
  ClipboardFormatList := NewRec;
end;

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

procedure TPicture.ReadData(Stream: TStream);
var
  CName: string[63];
  Format: PFileFormat;
  NewGraphic: TGraphic;
begin
  with Stream do
  begin
    Read(CName[0], 1);
    Read(CName[1], Integer(CName[0]));
    Format := FileFormatList;
    while Format <> nil do
      with Format^ do
        if GraphicClass.ClassName <> CName then Format := Next
        else
        begin
          NewGraphic := GraphicClass.Create;
          try
            NewGraphic.ReadData(Stream);
          except
            NewGraphic.Free;
            raise;
          end;
          FGraphic.Free;
          FGraphic := NewGraphic;
          FGraphic.OnChange := Changed;
          Changed(Self);
          Exit;
        end;
  end;
end;

procedure TPicture.WriteData(Stream: TStream);
var
  CName: string[63];
begin
  with Stream do
  begin
    CName := Graphic.ClassName;
    Write(CName, Length(CName) + 1);
    Graphic.WriteData(Stream);
  end;
end;

procedure TPicture.DefineProperties(Filer: TFiler);
begin
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, Graphic <> nil);
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 }

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

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

{ TMetafile }

constructor TMetafile.Create;
begin
  inherited Create;
  Assign(nil);
end;

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

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

procedure TMetafile.UniqueImage;
var
  NewImage: TMetafileImage;
begin
  if FImage.FRefCount > 1 then
  begin
    NewImage:= TMetafileImage.Create;
    NewImage.FHandle := CopyMetafile(FImage.FHandle, nil);
    NewImage.FHeight := FImage.FHeight;
    NewImage.FWidth := FImage.FWidth;
    NewImage.FInch := FImage.FInch;
    FImage.Release;
    FImage := NewImage;
    FImage.Reference;
  end;
end;

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

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

function TMetafile.GetHandle: HMETAFILE;
begin
  Result := FImage.FHandle;
end;

function TMetafile.GetHeight: Integer;
begin
  Result := 0;
  if FImage <> nil then
    with FImage do
    begin
      Result := FHeight;
      if FInch <> 0 then
        { FHeight stored in FInch units per inch, convert to pixels }
        Result := MulDiv(FHeight, Screen.PixelsPerInch, FInch);
    end;
end;

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

function TMetafile.GetWidth: Integer;
begin
  Result := 0;
  if FImage <> nil then
    with FImage do
    begin
      Result := FWidth;
      if FInch <> 0 then
        { FWidth stored in FInch units per inch, convert to pixels }
        Result := MulDiv(FWidth, Screen.PixelsPerInch, FInch);
    end;
end;

procedure TMetafile.SetHandle(Value: HMETAFILE);
begin
  NewImage;
  FImage.FHandle := Value;
  Changed(Self);
end;

procedure TMetafile.SetHeight(Value: Integer);
begin
  if FImage = nil then NewImage;
  with FImage do
    if FInch <> 0 then
      { FHeight stored in FInch units per inch, conver Value to FInch units }
      Value := MulDiv(Value, FInch, Screen.PixelsPerInch);
  if FImage.FHeight <> Value then
  begin
    UniqueImage;
    FImage.FHeight := Value;
    Changed(Self);
  end;
end;

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

procedure TMetafile.SetWidth(Value: Integer);
begin
  if FImage = nil then NewImage;
  with FImage do
    if FInch <> 0 then
      { FWidth stored in FInch units per inch, Value to FInch units }
      Value := MulDiv(Value, FInch, 96);
  if FImage.FWidth <> Value then
  begin
    UniqueImage;
    FImage.FWidth := Value;
    Changed(Self);
  end;
end;

procedure TMetafile.ReadData(Stream: TStream);
var
  Length: Longint;
begin
  NewImage;
  Stream.Read(Length, SizeOf(Longint));
  with FImage do
    ReadMetafile(Stream, FHandle, Length, FWidth, FHeight, FInch);
  Changed(Self);
end;

procedure TMetafile.WriteData(Stream: TStream);
begin
  if FImage <> nil then
    with FImage do
      WriteMetafile(Stream, FHandle, True, FWidth, FHeight, FInch);
end;

{ Draw the metafile adjusting the coordinate space of the Canvas to scale the
  drawing properly }
procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  SavedDC: Integer;
  DC: HDC;
  ViewOrg: TPoint;
begin
  if FImage <> nil then
  begin
    DC := ACanvas.Handle;
    SavedDC := SaveDC(DC);
    { Set mapping mode to MM_ANISOTROPIC since we want the coordinate space the
      allow a non-1 by 1 mapping. Note the order of these calls is essential.
      The mapping mode must be set to MM_ANISOTROPIC or Windows will ignore
      the WindowExt change which must preceed a ViewportExt change. }
    SetMapMode(DC, MM_ANISOTROPIC);
    { Set the logical size of the DC to be the maximum X and maximum Y used in
      the metafile's drawing }
    with FImage do SetWindowExtEx(DC, FWidth, FHeight, nil);
    { Set the DC 'window' (logical coordinate extent) to map on to the entire
      rectangle provided.  }
    SetViewportExtEx(DC, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, nil);
    { Get the original viewport origin since we are relative to that }
    GetViewPortOrgEx(DC, @ViewOrg);
    { Move the viewport origin to match the top left of the rectangle }
    with Rect.TopLeft do SetViewportOrgEx(DC, ViewOrg.X + X, ViewOrg.Y + Y, nil);
    { Now that the metafile's coordinate space has been setup, play the
      metafile }
    PlayMetafile(DC, FImage.FHandle);
    { Reset everything back the way it came. }
    RestoreDC(DC, SavedDC);
  end;
end;

procedure TMetafile.LoadFromStream(Stream: TStream);
begin
  NewImage;
  with FImage do
    ReadMetafile(Stream, FHandle, Stream.Size - Stream.Position, FWidth,
      FHeight, FInch);
  Changed(Self);
end;

procedure TMetafile.SaveToStream(Stream: TStream);
begin
  if FImage <> nil then
    with FImage do
      WriteMetafile(Stream, FHandle, False, FWidth, FHeight, FInch);
end;

procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  MetafilePict: PMetaFilePict;
begin
  if (AFormat <> CF_METAFILEPICT) or (AData = 0) then
    InvalidGraphic(SUnknownClipboardFormat);
  MetafilePict := GlobalLock(AData);
  try
    NewImage;
    with MetafilePict^, FImage do
    begin
      if (xExt < 1) or (yExt < 1) then
        { Metafiles that don't have a recommended size are not supported }
        InvalidGraphic(SUnknownClipboardFormat);
      case mm of
        MM_HIMETRIC, MM_ISOTROPIC, MM_ANISOTROPIC: FInch := 2540;
        MM_HIENGLISH: FInch := 1000;
        MM_LOMETRIC: FInch := 254;
        MM_LOENGLISH: FInch := 100;
        MM_TEXT: FInch := Screen.PixelsPerInch;
        MM_TWIPS: FInch := 1440;
      end;
      FWidth := xExt;
      FHeight := yExt;
      FHandle := CopyMetafile(hMF, nil);
    end;
  finally
    GlobalUnlock(AData);
  end;
  Changed(Self);
end;

procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
const
  InchValues: array[0..4] of Integer = (100, 254, 1000, 1440, 2540);
  MappingModes: array[0..4] of Word = (MM_LOENGLISH, MM_LOMETRIC,
    MM_HIENGLISH, MM_TWIPS, MM_HIMETRIC);
var
  MetafilePict: PMetaFilePict;
  I: Integer;
begin
  if FImage <> nil then
  begin
    AFormat := CF_METAFILEPICT;
    AData := GlobalAlloc(GMEM_MOVEABLE, SizeOf(TMetafilePict));
    APalette := 0;
    try
      MetafilePict := GlobalLock(AData);
      try
        with MetafilePict^, FImage do
        begin
          { TMetafilePict doesn't let us be exact so find something close }
          mm := MM_HIMETRIC;
          if FInch = Screen.PixelsPerInch then
            mm := MM_TEXT
          else
            for I := Low(InchValues) to High(InchValues) do
              if FInch <= InchValues[I] then
              begin
                mm := MappingModes[I];
                Break;
              end;
          xExt := FWidth;
          yExt := FHeight;
          hMF := CopyMetafile(FHandle, nil);
        end;
      finally
        GlobalUnlock(AData);
      end;
    except
      GlobalFree(AData);
      raise;
    end;
  end;
end;

var
  BitmapCanvasList: TList;

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

procedure FreeMemoryContexts;
begin
  while BitmapCanvasList.Count > 0 do
    TBitmapCanvas(BitmapCanvasList[0]).FreeContext;
end;

procedure DeselectBitmap(AHandle: HBITMAP);
var
  I: Integer;
begin
  for I := BitmapCanvasList.Count - 1 downto 0 do
    with TBitmapCanvas(BitmapCanvasList[I]) do
      if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
        FreeContext;
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
    if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
    if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
    H := FHandle;
    Handle := 0;
    DeleteDC(H);
    BitmapCanvasList.Remove(Self);
  end;
end;

procedure TBitmapCanvas.CreateHandle;
var
  H: HBITMAP;
begin
  if FBitmap <> nil then
  begin
    FBitmap.HandleNeeded;
    DeselectBitmap(FBitmap.FImage.FHandle);
    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);
  end;
end;

{ TInternalImage }

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

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

{ TBitmapImage }

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

{ TBitmap }

function CopyBitmap(Handle: HBITMAP; Palette: HPALETTE; NewWidth,
  NewHeight: Integer; Canvas: TCanvas; Monochrome: Boolean): HBITMAP;
var
  BitmapInfo: WinTypes.TBITMAP;
  OldScr, NewScr: HBITMAP;
  ScreenDC, NewImageDC, OldImageDC: HDC;
begin
  Result := 0;
  if (Handle = 0) and ((NewWidth = 0) or (NewHeight = 0)) then Exit;
  ScreenDC := GetDC(0);
  NewImageDC := CreateCompatibleDC(ScreenDC);
  try
    if Monochrome then
      Result := CreateBitmap(NewWidth, NewHeight, 1, 1, nil)
    else
      Result := CreateCompatibleBitmap(ScreenDC, NewWidth, NewHeight);
    if Result = 0 then OutOfResources;
    try
      NewScr := SelectObject(NewImageDC, Result);
      if Canvas <> nil then
      begin
        FillRect(NewImageDC, Rect(0, 0, NewWidth, NewHeight),
          Canvas.Brush.Handle);
        SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
        SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
      end
      else
        PatBlt(NewImageDC, 0, 0, NewWidth, NewHeight, WHITENESS);
      if Handle <> 0 then
      begin
        OldImageDC := CreateCompatibleDC(ScreenDC);
        if OldImageDC = 0 then OutOfResources;
        try
          DeselectBitmap(Handle);
          OldScr := SelectObject(OldImageDC, Handle);
          if Palette <> 0 then
          begin
            SelectPalette(OldImageDC, Palette, True);
            RealizePalette(OldImageDC);
            SelectPalette(NewImageDC, Palette, True);
            RealizePalette(NewImageDC);
          end;
          if Canvas <> nil then
          begin
            SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
            SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
          end;
          BitBlt(NewImageDC, 0, 0, NewWidth, NewHeight, OldImageDC, 0, 0, SRCCOPY);
          SelectObject(OldImageDC, OldScr);
        finally
          DeleteDC(OldImageDC);
        end;
      end;
    except
      SelectObject(NewImageDC, NewScr);
      DeleteObject(Result);
      raise;
    end;
  finally
    DeleteDC(NewImageDC);
    ReleaseDC(0, ScreenDC);
  end;
end;

function CopyPalette(Palette: HPALETTE): HPALETTE;
var
  PaletteSize: Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
begin
  Result := 0;
  if Palette = 0 then Exit;
  GetObject(Palette, SizeOf(PaletteSize), @PaletteSize);
  LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    with LogPalette^ do
    begin
      palVersion := $0300;
      palNumEntries := PaletteSize;
      GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
    end;
    Result := CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
  end;
end;

constructor TBitmap.Create;
begin
  inherited Create;
  FImage := TBitmapImage.Create;
  FImage.Reference;
end;

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

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

procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE;
  AWidth, AHeight: Integer; AMonochrome: Boolean);
begin
  FreeContext;
  AHandle := CopyBitmap(AHandle, APalette, AWidth, AHeight, FCanvas, AMonochrome);
  try
    APalette := CopyPalette(APalette);
    try
      NewImage(AHandle, APalette, AWidth, AHeight, AMonochrome, nil);
    except
      DeleteObject(APalette);
      raise;
    end;
  except
    DeleteObject(AHandle);
    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;
end;

procedure TBitmap.Dormant;
begin
  MemoryImageNeeded;
  FImage.FreeHandle;
end;

procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
  Canvas.RequiredState(csAllValid);
  if not Monochrome then SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
  with Rect, FImage do
    StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
      Canvas.FHandle, 0, 0, FWidth, FHeight, ACanvas.CopyMode);
end;

procedure TBitmap.FreeImage;
begin
  with FImage do
    if FRefCount > 1 then
      CopyImage(FHandle, FPalette, FWidth, FHeight, FMonochrome)
    else
    begin
      FMemoryImage.Free;
      FMemoryImage := nil;
    end;
end;

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

function TBitmap.GetCanvas: TCanvas;
begin
  if FCanvas = nil then
  begin
    HandleNeeded;
    FCanvas := TBitmapCanvas.Create(Self);
    FCanvas.OnChange := Changed;
    FCanvas.OnChanging := Changing;
  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.GetHeight: Integer;
begin
  Result := FImage.FHeight;
end;

function TBitmap.GetMonochrome: Boolean;
begin
  Result := FImage.FMonochrome;
end;

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

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

function TBitmap.GetWidth: Integer;
begin
  Result := FImage.FWidth;
end;

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

procedure TBitmap.HandleNeeded;
var
  Bmf: TBitmapFileHeader;
begin
  with FImage do
  begin
    if FHandle <> 0 then Exit;
    if FMemoryImage = nil then Exit;
    FMemoryImage.Position := 0;
    if FMemoryImage.Size <> 0 then
    begin
      FMemoryImage.Read(Bmf, SizeOf(Bmf));
      ReadDIB(FMemoryImage, FHandle, FPalette, FMemoryImage.Size - SizeOf(Bmf));
    end;
  end;
end;

procedure TBitmap.MemoryImageNeeded;
var
  Image: TMemoryStream;
begin
  with FImage do
  begin
    if FMemoryImage = nil then
    begin
      Image := TMemoryStream.Create;
      try
        if FHandle <> 0 then
          WriteBitmap(Image, FHandle, FPalette, False);
        Image.Position := 0;
      except
        Image.Free;
        raise;
      end;
      FMemoryImage := Image;
    end;
  end;
end;

procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  ABitmap: HBITMAP;
  BitmapInfo: Wintypes.TBitmap;
begin
  if (AFormat <> CF_BITMAP) or (AData = 0) then
    InvalidGraphic(SUnknownClipboardFormat);
  FreeContext;
  GetObject(AData, SizeOf(BitmapInfo), @BitmapInfo);
  ABitmap := CopyBitmap(AData, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
    nil, (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1));
  try
    APalette := CopyPalette(APalette);
    try
      NewImage(ABitmap, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
        (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1), nil);
    except
      DeleteObject(APalette);
      raise;
    end;
  except
    DeleteObject(ABitmap);
    raise;
  end;
  Changed(Self);
end;

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

procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  NewWidth, NewHeight: Integer; NewMonochrome: Boolean; NewImage: TMemoryStream);
var
  Image: TBitmapImage;
begin
  Image := TBitmapImage.Create;
  try
    Image.FHandle := NewHandle;
    Image.FPalette := NewPalette;
    Image.FWidth := NewWidth;
    Image.FHeight := NewHeight;
    Image.FMonochrome := NewMonochrome;
    Image.FMemoryImage := NewImage;
  except
    Image.Free;
    raise;
  end;
  FImage.Release;
  FImage := Image;
  FImage.Reference;
end;

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

procedure TBitmap.ReadStream(Size: Longint; Stream: TStream);
var
  Bmf: TBitmapFileHeader;
  BC: TBitmapCoreHeader;
  BI: TBitmapInfoHeader;
  Image: TMemoryStream;
  IWidth, IHeight: Integer;
  IMonochrome: Boolean;
begin
  FreeContext;
  if Size = 0 then
    NewImage(0, 0, 0, 0, False, nil)
  else
  begin
    Image := TMemoryStream.Create;
    try
      Image.SetSize(Size);
      Stream.ReadBuffer(Image.Memory^, Size);
      Image.Read(Bmf, SizeOf(Bmf));
      if Bmf.bfType <> $4D42 then InvalidBitmap;
      Image.Read(Size, SizeOf(Size));
      Image.Seek(-SizeOf(Size), 1);
      if Size = SizeOf(BC) then
      begin
        Image.Read(BC, SizeOf(BC));
        IHeight := BC.bcHeight;
        IWidth := BC.bcWidth;
        IMonochrome := (BC.bcPlanes = 1) and (BC.bcBitCount = 1);
      end
      else if Size = SizeOf(BI) then
      begin
        Image.Read(BI, SizeOf(BI));
        IHeight := BI.biHeight;
        IWidth := BI.biWidth;
        IMonochrome := (BI.biPlanes = 1) and (BI.biBitCount = 1);
      end
      else InvalidBitmap;
      Image.Position := 0;
      NewImage(0, 0, IWidth, IHeight, IMonochrome, Image);
    except
      Image.Free;
      raise;
    end;
  end;
end;

procedure TBitmap.SetHandle(Value: HBITMAP);
var
  BitmapInfo: WinTypes.TBitmap;
  APalette: HPALETTE;
begin
  with FImage do
    if FHandle <> Value then
    begin
      FreeContext;
      if Value <> 0 then
        GetObject(Value, SizeOf(BitmapInfo), @BitmapInfo) else
        FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
      if FRefCount = 1 then
      begin
        APalette := FPalette;
        FPalette := 0;
      end
      else
        APalette := CopyPalette(FPalette);
      try
        NewImage(Value, APalette, BitmapInfo.bmWidth, BitmapInfo.bmHeight,
          (BitmapInfo.bmPlanes = 1) and (BitmapInfo.bmBitsPixel = 1), nil);
      except
        DeleteObject(APalette);
        raise;
      end;
      Changed(Self);
    end;
end;

procedure TBitmap.SetPalette(Value: HPALETTE);
var
  AHandle: HBITMAP;
begin
  with FImage do
    if FPalette <> Value then
    begin
      FreeContext;
      if FRefCount = 1 then
      begin
        AHandle := FHandle;
        FHandle := 0;
      end
      else
        AHandle := CopyBitmap(FHandle, FPalette, FWidth, FHeight, nil, FMonochrome);
      try
        NewImage(AHandle, Value, FWidth, FHeight, FMonochrome, nil);
      except
        DeleteObject(AHandle);
        raise;
      end;
      Changed(Self);
    end;
end;

procedure TBitmap.SetHeight(Value: Integer);
begin
  with FImage do
    if FHeight <> Value then
    begin
      CopyImage(FHandle, FPalette, FWidth, Value, FMonochrome);
      Changed(Self);
    end;
end;

procedure TBitmap.SetMonochrome(Value: Boolean);
begin
  with FImage do
    if Value <> FMonochrome then
    begin
      CopyImage(FHandle, FPalette, FWidth, FHeight, Value);
      Changed(Self);
    end;
end;

procedure TBitmap.SetWidth(Value: Integer);
begin
  with FImage do
    if FWidth <> Value then
    begin
      CopyImage(FHandle, FPalette, Value, FHeight, FMonochrome);
      Changed(Self);
    end;
end;

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

procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
var
  Size: Longint;
begin
  with FImage do
  begin
    MemoryImageNeeded;
    Size := FMemoryImage.Size;
    if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
    if Size <> 0 then
      Stream.WriteBuffer(FMemoryImage.Memory^, Size);
  end;
end;

function TBitmap.ReleaseHandle: HBITMAP;
begin
  HandleNeeded;
  Changing(Self);
  Result := FImage.FHandle;
  FImage.FHandle := 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
  BitmapCopy: HBITMAP;
begin
  Format := CF_BITMAP;
  with FImage do
    BitmapCopy := CopyBitmap(FHandle, FPalette, FWidth, FHeight, FCanvas,
      FMonochrome);
  Data := BitmapCopy;
  try
    APalette := CopyPalette(FImage.FPalette);
  except
    DeleteObject(BitmapCopy);
    raise;
  end;
end;

{ TIconImage }

procedure TIconImage.FreeHandle;
begin
  if FHandle <> 0 then DestroyIcon(FHandle);
  FHandle := 0;
end;

{ TIcon }

constructor TIcon.Create;
begin
  inherited Create;
  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]);
    DrawIcon(ACanvas.FHandle, X, Y, Handle);
  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.GetHeight: Integer;
begin
  Result := GetSystemMetrics(SM_CYICON);
end;

function TIcon.GetWidth: Integer;
begin
  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));
    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(hInstance, 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
  InvalidOperation(SChangeIconSize);
end;

procedure TIcon.SetWidth(Value: Integer);
begin
  InvalidOperation(SChangeIconSize);
end;

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

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

{ 16 bit implemenation only, Win32 should be based on the ImageList
  implemented in COMMCTL.DLL }

type
  TImageInfo = record
    Offset: SmallInt;
    Masked: Boolean;
    Reserved: Boolean;
  end;

constructor TImageList.Create(AWidth, AHeight: Integer);
begin
  inherited Create;
  if (AHeight < 1) or (AWidth < 1) then InvalidOperation(SInvalidImageSize);
  FImage := TBitmap.Create;
  FImage.Height := AHeight;
  FMask := TBitmap.Create;
  FInfo := TList.Create;
  FHeight := AHeight;
  FWidth := AWidth;
  FDelta := 4;
end;

destructor TImageList.Destroy;
begin
  FImage.Free;
  FMask.Free;
  FInfo.Free;
  inherited Destroy;
end;

function TImageList.AllocateSpace: Integer;
var
  NewWidth: Longint;
  Offset: Integer;
begin
  Offset := FUsed;
  Inc(FUsed, FWidth);
  if FUsed > FImage.Width then
  begin
    NewWidth := Longint(FImage.Width) + Longint(FDelta) * FWidth;
    if NewWidth > 32768 then InvalidOperation(STooManyImages);
    FImage.Width := NewWidth;
  end;
  Result := FInfo.Count;
  FInfo.Add(Pointer(Offset));
end;

procedure TImageList.CheckImage(Image: TBitmap);
begin
  if Image = nil then Exit;
  with Image do
    if (Height <> FHeight) or (Width <> FWidth) then
      InvalidOperation(SDimsDoNotMatch);
end;

function TImageList.GetCount: Integer;
begin
  Result := FInfo.Count;
end;

function TImageList.Add(Image, Mask: TBitmap): Integer;
begin
  CheckImage(Image);
  CheckImage(Mask);
  Result := AllocateSpace;
  Replace(Result, Image, Mask);
end;

function TImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
  CheckImage(Image);
  Result := AllocateSpace;
  ReplaceMasked(Result, Image, MaskColor);
end;

procedure TImageList.Replace(Index: Integer; Image, Mask: TBitmap);
var
  Info: TImageInfo;
begin
  CheckImage(Image);
  CheckImage(Mask);
  Pointer(Info) := FInfo[Index];
  with Info do
  begin
    if Assigned(Image) then FImage.Canvas.Draw(Offset, 0, Image);
    Masked := Assigned(Mask);
    if Masked then
    begin
      FMask.Monochrome := True;
      FMask.Height := FImage.Height;
      FMask.Width := FImage.Width;
      FMask.Canvas.Draw(Offset, 0, Mask);
    end;
  end;
  FInfo[Index] := Pointer(Info);
end;

procedure TImageList.ReplaceMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
var
  Mask: TBitmap;
  NImage: TBitmap;
begin
  CheckImage(Image);
  Mask := TBitmap.Create;
  try
    Mask.Assign(Image);
    Mask.Canvas.Brush.Color := MaskColor;
    Mask.Monochrome := True;
    NImage := TBitmap.Create;
    try
      NImage.Assign(Image);
      with NImage.Canvas do
      begin
        CopyMode := cmSrcAnd;
        Brush.Color := clBlack;
        Font.Color := clWhite;
        Draw(0, 0, Mask);
      end;
      Replace(Index, NImage, Mask);
    finally
      NImage.Free;
    end;
  finally
    Mask.Free;
  end;
end;

procedure TImageList.Draw(Canvas: TCanvas; X, Y: Integer; Index: Integer);
var
  ImageRect, CanvasRect, DrawRect: TRect;
  Info: TImageInfo;
  OldMode: TCopyMode;
  OldTextColor, OldBkColor: Longint;
begin
  Pointer(Info) := FInfo[Index];
  with Info do
  begin
    with CanvasRect do
      begin Left := X; Top := Y; Right := X + Width; Bottom := Y + Height end;
    with ImageRect do
      begin Left := Offset; Top := 0; Right := Offset + Width; Bottom := Height end;
    with Canvas do
      if not Masked then
      begin
        OldMode := CopyMode;
        CopyRect(CanvasRect, FImage.Canvas, ImageRect);
        CopyMode := OldMode;
      end
      else
      begin
        OldMode := CopyMode;
        CopyMode := cmSrcAnd;
        OldTextColor := SetTextColor(Handle, clBlack);
        OldBkColor := SetBkColor(Handle, clWhite);
        CopyRect(CanvasRect, FMask.Canvas, ImageRect);
        CopyMode := cmSrcInvert;
        CopyRect(CanvasRect, FImage.Canvas, ImageRect);
        CopyMode := OldMode;
        SetTextColor(Handle, OldTextColor);
        SetBkColor(Handle, OldBkColor);
      end;
  end;
end;

procedure TImageList.Delete(Index: Integer);
var
  Dest, Src: TRect;
  Info: TImageInfo;
begin
  Pointer(Info) := FInfo[Index];
  with Info do
  begin
    Dec(FUsed, FWidth);
    with Dest do
      begin Left := Offset; Right := Left + Width; Top := 0; Bottom := Height; end;
    with Src do
      begin Left := Dest.Right; Right := Left + Width; Top := 0; Bottom := Height; end;
    FImage.Canvas.CopyRect(Dest, FImage.Canvas, Src);
    FMask.Canvas.CopyRect(Dest, FImage.Canvas, Src);
  end;
  FInfo.Delete(Index);
end;

function GraphicFilter(GraphicClass: TGraphicClass): string;
var
  Graphic: PFileFormat;
  Count: Integer;
  Filters: string;
begin
  Result := '';
  Filters := '';
  Count := 0;
  Graphic := FileFormatList;
  while Graphic <> nil do
  begin
    if Graphic^.GraphicClass.InheritsFrom(GraphicClass) then
      with Graphic^ do
      begin
        Inc(Count);
        Result := Result + Format('%s (*.%s)|*.%s|', [Description^,
          Extension, Extension]);
        Filters := Filters + Format('*.%s;', [Extension]);
      end;
    Graphic := Graphic^.Next;
  end;
  if Result[Length(Result)] = '|' then Dec(Result[0]);
  if Filters[Length(Filters)] = ';' then Dec(Filters[0]);
  if Count > 1 then Result := LoadStr(sAllFilter) + ' (' + Filters + ')|' +
    Filters + '|' + Result;
end;

function GraphicExtension(GraphicClass: TGraphicClass): string;
var
  Graphic: PFileFormat;
begin
  Result := '';
  Graphic := FileFormatList;
  while Graphic <> nil do
    if Graphic^.GraphicClass.InheritsFrom(GraphicClass) then
    begin
      Result := Graphic^.Extension;
      Exit;
    end
    else Graphic := Graphic^.Next;
end;

procedure InitGraphics;
var
  DC: HDC;
begin
  DC := CreateCompatibleDC(0);
  ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  DeleteDC(DC);
  DefFontData.Height := -MulDiv(10, ScreenLogPixels, 72);
  StockPen := GetStockObject(BLACK_PEN);
  StockBrush := GetStockObject(HOLLOW_BRUSH);
  StockFont := GetStockObject(SYSTEM_FONT);
  StockIcon := LoadIcon(0, IDI_APPLICATION);
  FontManager := TResourceManager.Create(SizeOf(TFontData));
  PenManager := TResourceManager.Create(SizeOf(TPenData));
  BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  BitmapCanvasList := TList.Create;
  BitmapHandles := THandleCache.Create;
  PaletteHandles := THandleCache.Create;
  MetafileHandles := THandleCache.Create;
  IconHandles := THandleCache.Create;
  IconHandles.Reference(StockIcon);
  CanvasList := TList.Create;
  SMetafiles := LoadStr(SVMetafiles);
  SIcons := LoadStr(SVIcons);
  SBitmaps := LoadStr(SVBitmaps);
  RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
end;

end.

