{ @abstract(This unit provides an advanced Windows icon management
    i.e. replacement for the Graphics.TIcon component)
  @author(Tomas Krysl (tomkrysl@tkweb.eu))
  @created(9 Jan 2005)
  @lastmod(20 Jun 2010)

  Copyright © 2005 Tomas Krysl (tomkrysl@@tkweb.eu)<BR><BR>

  The purpose of the TKIcon component is to replace and expand the standard
  TIcon component provided by VCL. The TKIcon component is not based on Windows
  icon functions, but manages the icon structures by itself.
  <UL>
    <LH>Major features are:</LH>
    <LI>32-bit icons/cursors with alpha channel supported</LI>
    <LI>correct rendering in all 32-bit Windows platforms</LI>
    <LI>optional rendering of all icon/ cursors subimages</LI>
    <LI>icons/cursors can be stretched when drawn</LI>
    <LI>multiple rendering styles</LI>
    <LI>loading from file/stream, HICON, module resources, file associations</LI>
    <LI>saving to file/stream</LI>
    <LI>icon image manipulation (inserting/deleting/cropping/enlarging)</LI>
    <LI>full TPicture integration (only TPicture.Icon can't be used)</LI>
  </UL>

  <B>License:</B><BR>
  This code is distributed as a freeware. You are free to use it as part
  of your application for any purpose including freeware, commercial and
  shareware applications. The origin of this source code must not be
  misrepresented; you must not claim your authorship. You may modify this code
  solely for your own purpose. Please feel free to contact the author if you
  think your changes might be useful for other users. You may distribute only
  the original package. The author accepts no liability for any damage
  that may result from using this code. }
  
unit KIcon;

{$include kcontrols.inc}
{$IFNDEF TKICON_REGISTER}
  {$WEAKPACKAGEUNIT ON}
{$ENDIF}

interface

{$IFDEF USE_WINAPI}

uses
  Windows, SysUtils, Classes, Graphics, KGraphics
{$IFDEF USE_PNG_SUPPORT}
 {$IFDEF FPC}
  , fpImage, GraphType, IntfGraphics
 {$ELSE}
  , PngImage  
 {$ENDIF}
{$ENDIF};

resourcestring
  { @exclude }
  SVIcons = 'Icons';
  { @exclude }
  SVCursors = 'Cursors';
  { @exclude }
  SIconAllocationError = 'Error while allocating icon data';
  { @exclude }
  SIconBitmapError = 'Invalid icon bitmap handles';
  { @exclude }
  SIconFormatError = 'Invalid icon format';
  { @exclude }
  SIconResourceError = 'Invalid icon resource';
  { @exclude }
  SIconIndexError = 'Invalid icon resource index';
  { @exclude }
  SIconInvalidModule = 'Invalid module or no icon resources';
  { @exclude }
  SIconResizingError = 'Error while resizing icon';
  { @exclude }
  SIconAssocResolveError = 'Error while resolving associated icon';

type
{$IFDEF USE_PNG_SUPPORT}
  { @exclude }
  TKIconPngObject = TKPngImage;
{$ELSE}
  { @exclude }
  TKIconPngObject = TMemoryStream; //used to store compressed PNG stream
{$ENDIF}

  { @abstract(Icon file header)
    <UL>
    <LH>Members:</LH>
    <LI><I>idReserved</I> - always 0</LI>
    <LI><I>idType</I> - 1=icon, 2=cursor</LI>
    <LI><I>idCount</I> - total number of icon images in file</LI>
    </UL>
  }
  TKIconHeader = packed record
    idReserved: Word;
    idType: Word;
    idCount: Word;
  end;

  { Pointer to the icon file header structure }
  PKIconHeader = ^TKIconHeader;

  { @abstract(Helper structure identifying attributes that are different for
    icons and cursors)
    <UL>
    <LH>Members:</LH>
    <LI><I>wPlanes</I> - for icons: amount of image planes - I think that this is always 1</LI>
    <LI><I>wBitCount</I> - for icons: image color resolution</LI>
    <LI><I>wX</I> - for cursors: hot spot horizontal coordinate</LI>
    <LI><I>wY</I> - for cursors: hot spot vertical coordinate</LI>
    </UL>
  }
  TKIconCursorDirInfo = packed record
    case Integer of
    0: (
      wPlanes: Word;
      wBitCount: Word;
      );
    1: (
      wX: Word;
      wY: Word;
      );
  end;

  { @abstract(Icon/cursor directory entry. This structure decribes each
    icon/cursor image. These structures describing all images immediately follow
    the @link(TKIconHeader) structure in the icon file. After these the bitmap data
    for all images are stored (TBitmapInfoHeader, palette data, bitmap bits - XOR, AND).)
    <UL>
    <LH>Members:</LH>
    <LI><I>Width</I> - image width</LI>
    <LI><I>Height</I> - image height</LI>
    <LI><I>ColorCount</I> - number of entries in palette table</LI>
    <LI><I>Reserved</I> - not used</LI>
    <LI><I>Info</I> - different for icons/cursors</LI>
    <LI><I>dwBytesInRes</I> - total number bytes in the image including
      pallette data, XOR bits, AND bits and bitmap info header</LI>
    <LI><I>dwImageOffset</I> - position of image as offset from the beginning of file</LI>
    </UL>
  }
  TKIconCursorDirEntry = packed record
    Width: Byte;
    Height: Byte;
    ColorCount: Byte;
    Reserved: Byte;
    Info: TKIconCursorDirInfo;
    dwBytesInRes: Longint;
    dwImageOffset: Longint;
  end;

  { Pointer to the icon/cursor directory entry }
  PKIconCursorDirEntry = ^TKIconCursorDirEntry;

  { Helper structure to typecast cursor hot spot coordinates }
  TKCursorHotSpot = packed record
    xHotSpot: Word;
    yHotSpot: Word;
  end;

  { Pointer to the cursor hot spot structure }
  PKCursorHotSpot = ^TKCursorHotSpot;

  { Helper structure for cursor specific data in resource file }
  TKCursorDir = packed record
    Width: Word;
    Height: Word;
  end;

  { Helper structure for icon specific data in resource file }
  TKIconResdir = packed record
    Width: Byte;
    Height: Byte;
    ColorCount: Byte;
    Reserved: Byte;
  end;

  { Helper structure merging icon and cursor specific data }
  TKIconCursorInfo = packed record
    case Integer of
      0: (Icon: TKIconResdir);
      1: (Cursor: TKCursorDir);
  end;

  { @abstract(Icon/cursor directory entry as found in resource files)
    <UL>
    <LH>Members:</LH>
    <LI><I>Info</I> - structure that merges icon/cursor specific data</LI>
    <LI><I>wPlanes</I> - not used = 0</LI>
    <LI><I>wBitCount</I> - not used = 0</LI>
    <LI><I>dwBytesInRes</I> - total number of bytes in the image including
      pallette data, XOR bits, AND bits and bitmap info header</LI>
    <LI><I>wEntryName</I> - icon/cursor entry name. This number identifies the
      particular icon image in a resource file (images are stored under ICONENTRY
      key)</LI>
    </UL>
  }
  TKIconCursorDirEntryInRes = packed record
    Info: TKIconCursorInfo;
    wPlanes: Word;
    wBitCount: Word;
    dwBytesInRes: Longint;
    wEntryName: Word;
  end;

  { Pointer to the icon/cursor resource file directory entry }
  PKIconCursorDirEntryInRes = ^TKIconCursorDirEntryInRes;

  { Helper structure to access resource data }
  TKIconCursorInRes = packed record
    IH: TKIconHeader;
    Entries: array [0..MaxInt div SizeOf(TKIconCursorDirEntryInRes) - 2] of TKIconCursorDirEntryInRes;
  end;

  { Pointer to the helper structure }
  PKIconCursorInRes = ^TKIconCursorInRes;

  { Controls how the image should be aligned when they are beeing resized }
  TKIconAlignStyle = (
    { image remains aligned to the top-left corner }
    asNone,
    { image will be centered within the new boundary rectangle }
    asCenter
  );

  { Specifies the width and height of an icon or cursor image }
  TKIconDimension = record
    Width,
    Height: Integer;
  end;

  { @abstract(Specifies the GDI handles for one icon/cursor image)
    <UL>
    <LH>Members:</LH>
    <LI><I>hXOR</I> - handle to the color bitmap - icon image</LI>
    <LI><I>hAND</I> - handle to the monochrome bitmap - icon image mask</LI>
    </UL>
  }
  TKIconHandles = record
    hXOR,
    hAND: HBITMAP;
  end;

  { @abstract(Represents the internal data structure describing each icon/cursor image)
    <UL>
    <LH>Members:</LH>
    <LI><I>Width</I> - image width</LI>
    <LI><I>Height</I> - image height</LI>
    <LI><I>Bpp</I> - image color resolution</LI>
    <LI><I>BytesInRes</I> - total image data size</LI>
    <LI><I>HotSpot</I> - hot spot for a cursor</LI>
    <LI><I>iXOR</I> - pointer to the color bitmap info header + palette</LI>
    <LI><I>iXORSize</I> - size of iXOR data</LI>
    <LI><I>pXOR</I> - pointer to the color bitmap bits</LI>
    <LI><I>pXORSize</I> - size of pXOR data</LI>
    <LI><I>hXOR</I> - handle to the color bitmap - is always a DIB section</LI>
    <LI><I>pAND</I> - pointer to the monochrome (mask) bitmap bits</LI>
    <LI><I>pANDSize</I> - size of pAND data</LI>
    <LI><I>hAND</I> - handle to the monochrome bitmap - is always a DIB section</LI>
    <LI><I>PNG</I> - holds the PNG image</LI>
    </UL>
  }
  TKIconData = record
    Width: Integer;
    Height: Integer;
    Bpp: Integer;
    BytesInRes: Integer;
    Offset: Integer;
    HotSpot: TPoint;
    iXOR: PBitmapInfo;
    iXORSize: Integer;
    pXOR: Pointer;
    pXORSize: Integer;
    hXOR: HBITMAP;
    pAND: Pointer;
    pANDSize: Integer;
    hAND: HBITMAP;
    IsPNG: Boolean;
    PNG: TKIconPngObject;
  end;

  { Pointer to the internal image description structure }
  PKIconData = ^TKIconData;

  { Specifies how the icon image(s) should be rendered. This feature can be used
    along with the MaskFromColor method to implement a ‘color picker’ for a new mask construction. }
  TKIconDrawStyle = (
    { paint normally }
    idsNormal,
    { paint without applying the mask - color bitmap only }
    idsNoMask,
    { paint only the mask - monochrome bitmap only }
    idsMaskOnly,
    { paint only the alpha channel as grayscale image - only for 32 bit icon bitmaps else paint as with idsNoMask style }
    idsAlphaChannel
  );

  { KIcon main class. }
  TKIcon = class(TGraphic)
  private
    FAlignStyle: TKIconAlignStyle;
    FBpp: Integer;
    FCreating: Boolean;
    FCurrentIndex: Integer;
    FCursor: Boolean;
    FDisplayAll: Boolean;
    FDisplayHorz: Boolean;
    FIconCount: Integer;
    FIconData: array of TKIconData;
    FIconDrawStyle: TKIconDrawStyle;
    FInHandleBpp: Integer;
    FInHandleFullAlpha: Boolean;
    FMaxHeight: Integer;
    FMaxWidth: Integer;
    FOptimalIcon: Boolean;
    FOverSizeWeight: Single;
    FRequestedSize: TKIconDimension;
    FSpacing: Integer;
    FStretchEnabled: Boolean;
    function GetDimensions(Index: Integer): TKIconDimension;
    function GetHandles(Index: Integer): TKIconHandles;
    function GetHeights(Index: Integer): Integer;
    function GetHotSpot(Index: Integer): TPoint;
    function GetIconData(Index: Integer): TKIconData;
    function GetWidths(Index: Integer): Integer;
    procedure SetCurrentIndex(Value: Integer);
    procedure SetDimensions(Index: Integer; Value: TKIconDimension);
    procedure SetDisplayAll(Value: Boolean);
    procedure SetDisplayHorz(Value: Boolean);
    procedure SetHandles(Index: Integer; Value: TKIconHandles);
    procedure SetHeights(Index: Integer; Value: Integer);
    procedure SetHotSpot(Index: Integer; Value: TPoint);
    procedure SetInHandleBpp(Value: Integer);
    procedure SetIconDrawStyle(Value: TKIconDrawStyle);
    procedure SetOptimalIcon(Value: Boolean);
    procedure SetOverSizeWeight(Value: Single);
    procedure SetRequestedSize(Value: TKIconDimension);
    procedure SetSpacing(Value: Integer);
    procedure SetStretchEnabled(Value: Boolean);
    procedure SetWidths(Index: Integer; Value: Integer);
  protected
    { Overriden method - see Delphi help. Calls @link(Update) method. }
    procedure Changed(Sender: TObject); override;
    { Overriden method - see Delphi help. }
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    { Overriden method - see Delphi help. }
    function GetEmpty: Boolean; override;
    { Overriden method - see Delphi help. }
    function GetHeight: Integer; override;
    { Overriden method - see Delphi help. }
    function GetTransparent: Boolean; override;
    { Overriden method - see Delphi help. }
    function GetWidth: Integer; override;
    { Copies the bitmaps stored in Handles to the icon image identified by Index.
      If OrigBpp is True, the color resolution for the color bitmap remains unchanged,
      otherwise the value of InHandleBpp will be used. }
    procedure LoadHandles(Index: Integer; const Handles: TKIconHandles; OrigBpp: Boolean);
    { Overriden method - see Delphi help. }
    procedure SetHeight(Value: Integer); override;
    { Overriden method - see Delphi help. }
    procedure SetTransparent(Value: Boolean); override;
    { Overriden method - see Delphi help. }
    procedure SetWidth(Value: Integer); override;
    { Updates @link(MaxWidth), @link(MaxHeight) and @link(CurrentIndex)
      properties accordingly. }
    procedure Update; dynamic;
    { Resizes an icon image identified by Index to new dimensions stored in Value.
      The AlignStyle property controls the image alignment within the new rectangle. }
    procedure UpdateDim(Index: Integer; Value: TKIconDimension);
  public
    { Overriden method - see Delphi help. }
    constructor Create; override;
    { Overriden method - see Delphi help. }
    destructor Destroy; override;
    { Adds a new image to the end of the internal image list. You should always
      specify valid color and mask bitmap handles else an exception will occur. }
    procedure Add(const Handles: TKIconHandles);
    { Overriden method - see Delphi help. }
    procedure Assign(Source: TPersistent); override;
    { Clears all images so that the instance contains no icon/cursor. }
    procedure Clear; {$IFDEF FPC}override{$ELSE}dynamic{$ENDIF};
    { Copies the icon image into an alpha bitmap identified by Bitmap.
      Icon image is copied to the alpha bitmap. It icon has alpha channel
      it is copied as well.
      Bitmap size will always be matched to the icon image. }
    procedure CopyToAlphaBitmap(Index: Integer; Bitmap: TKAlphaBitmap);
    { Copies the icon image into a bitmap identified by Bitmap. Both color
      and mask image is copied to preserve true transparency. You can use this
      to pass to Glyph properties (e.g. TSpeedButton). Bitmap properties will
      always be matched to the icon image. For 32bpp icon images,
      alpha channel is copied as well. }
    procedure CopyToBitmap(Index: Integer; Bitmap: TBitmap);
  {$IFDEF USE_PNG_SUPPORT}
    { Copies the icon image into a png image identified by Png.
      It is saved always in truecolor format with alpha channel (32bpp).
      Png size will always be matched to the icon image. }
    procedure CopyToPng(Index: Integer; Png: TKPngImage);
  {$ENDIF}  
    { Creates an icon handle for use with Win32 API icon functions. The image
      identified by Index will be used for this handle. If DisplayAll is False
      and Index is out of range, CurrentIndex will be used instead. }
    function CreateHandle(Index: Integer): HICON;
    { Deletes an image identified by Index from the internal image list. }
    procedure Delete(Index: Integer);
    { Inserts an image at the position identified by Index into the internal
      image list. The existing images will be preserved and shifted accordingly. }
    procedure Insert(Index: Integer; const Handles: TKIconHandles);
  {$IFNDEF FPC}
    { Overriden method - see Delphi help. Does nothing for icons/cursors. }
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    { Loads the icon from the module associated with the file identified by FileName
      (DefaultIcon registry key). If no association can be found for the file,
      an exception will be raised and the function will try to load FileName
      as if it was a module itself. }
  {$ENDIF}
    procedure LoadFromAssocFile(const FileName: string);
    { Loads the icon from the module associated with the file extension identified
      by Extension (DefaultIcon registry key). The Extension parameter should
      contain the leading period ('.'). If no association can be found for that
      extension, an exception will be triggered. }
    procedure LoadFromAssocExtension(const Extension: string);
    { Loads the icon from Win32 API icon handle. Please keep in mind that icon bitmaps
      can't be loaded as DIBs because they are already converted to DDBs when
      accessible through HICON. So it is impossible to load the icon in it's
      native format (e.g. as stored in an *.ico file) from HICON. This function
      has been introduced only to complete the loading schemes of this class
      and you should rather use another LoadFrom... methods. The behavior of this
      function can be controlled via the InHandleBpp and InHandleFullAlpha properties.
      It is not recommended to use this function in new projects. }
    procedure LoadFromHandle(Handle: HICON);
    { Loads the icon from resources of a module identified by ModuleName.
      A valid icon resource must be specified by ID, otherwise
      an exception occurs. This function uses the LoadLibrary API function, so
      it is recommended to use the LoadFromResourceX functions to load multiple
      icons from the same module. ID is of type Word so it can’t exceed 65535. }
    procedure LoadFromModule(const ModuleName: string; ID: Word); overload;
    { Does the same thing, but with resource ID specified as string. Let's suppose
      ID = 123. Here you can pass it as a string '#123'. }
    procedure LoadFromModule(const ModuleName, ResName: string); overload;
    { This function does the same as @link(LoadFromModule), but the icon resource
      is specified by index here. The index stands for the n-th icon stored
      in the module resources. So, LoadFromModule('dummy.exe', 'MAINICON') would
      produce the same results as LoadFromModuleByIndex('dummy.exe', 0),
      provided 'MAINICON' is the first icon resource in 'dummy.exe'. }
    procedure LoadFromModuleByIndex(const ModuleName: string; Index: Integer);
    { Loads the icon from resources of a module instance identified by Instance.
      Further behavior corresponds to @link(LoadFromModule) with resource ID
      specified as integer. }
    procedure LoadFromResource(Instance: HINST; ID: Word); overload;
    { Loads the icon from resources of a module instance identified by Instance.
      Further behavior corresponds to @link(LoadFromModule) with resource ID
      specified as string. }
    procedure LoadFromResource(Instance: HINST; const ResName: string); overload;
    { Loads the icon from resources of a module instance identified by Instance.
      Further behavior corresponds to @link(LoadFromModuleByIndex). }
    procedure LoadFromResourceByIndex(Instance: HINST; Index: Integer);
    { Loads the icon from the stream. Parses the *.ico file structure.
      An overriden method. }
    procedure LoadFromStream(Stream: TStream); override;
    { Makes it possible to create a new mask bitmap for the image identified by Index.
      The new monochrome mask bitmap will be created from the color bitmap.
      Pixels of the color bitmap that match Color will be masked by the new mask,
      other pixels will be unmasked. If the Color parameter contains alpha channel,
      you should set HasAlpha to True to perform comparison with the alpha channel.
      Otherwise, only the red, green and blue channels will be compared. }
    procedure MaskFromColor(Index: Integer; Color: TColor; HasAlpha: Boolean = False);
  {$IFNDEF FPC}
    { Overriden method - see Delphi help. Does nothing for icons/cursors. }
    procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
      var APalette: HPALETTE); override;
  {$ENDIF}
    { Saves the icon to the stream. Assembles the *.ico file structure. An overriden method. }
    procedure SaveToStream(Stream: TStream); override;
    { Controls the icon image resizing which is performed by the UpdateDim method. }
    property AlignStyle: TKIconAlignStyle read FAlignStyle write FAlignStyle;
    { Specifies the index of the currently displayed icon image.
      If no image is loaded (no icon), the value of CurrentIndex is -1. }
    property CurrentIndex: Integer read FCurrentIndex write SetCurrentIndex;
    { Indicates whether the instance of this class represents a cursor (True) or an icon (False). }
    property Cursor: Boolean read FCursor write FCursor;
    { Specifies whether all icon images (True) or a single subimage should be
      drawn (False). When True, all available icon images will be rendered. }
    property DisplayAll: Boolean read FDisplayAll write SetDisplayAll;
    { Specifies how the images should be drawn when @link(DisplayAll) is True.
      If True, the images will be drawn horizontally aligned. If False,
      the images will be drawn vertically aligned. }
    property DisplayHorz: Boolean read FDisplayHorz write SetDisplayHorz;
    { Makes it possible to read/modify the size of an icon image. }
    property Dimensions[Index: Integer]: TKIconDimension read GetDimensions write SetDimensions;
    { Makes it possible to read/modify icon image bitmaps (color and mask bitmap).
      Bitmaps that you pass will be copied and remain unchanged. When reading
      original bitmap handles are returned and thus must not be modified or released. }
    property Handles[Index: Integer]: TKIconHandles read GetHandles write SetHandles;
    { Makes it possible to read/modify the height of an icon image. }
    property Heights[Index: Integer]: Integer read GetHeights write SetHeights;
    { For a cursor, this property contains the hot spots for all cursor images. }
    property HotSpot[Index: Integer]: TPoint read GetHotSpot write SetHotSpot;
    { Returns the number of images found in this instance. }
    property IconCount: Integer read FIconCount;
    { Makes it possible to read the internal data structure of each icon image.
      A copy of the structure is returned but the pointers or handles are original
      (no copies are created) and thus must not be modified or released. }
    property IconData[Index: Integer]: TKIconData read GetIconData;
    { Affects the icon image rendering. }
    property IconDrawStyle: TKIconDrawStyle read FIconDrawStyle write SetIconDrawStyle;
    { Specifies the color resolution a DIB should have after converted from a DDB
      that has been passed to the LoadHandles method. }
    property InHandleBpp: Integer read FInHandleBpp write SetInHandleBpp;
    { Determines whether a DIB with 32 bits per pixel should have full visibility
      (alpha channel of each pixel set to 0xFF) after converted from a DDB
      that has been passed to the LoadHandles method. The alpha channel values will
      be only set to 0xFF when the current alpha channel of every pixel is zero. }
    property InHandleFullAlpha: Boolean read FInHandleFullAlpha write FInHandleFullAlpha;
    { Returns the height of the image that has the maximum height of all icon images.
      When @link(DisplayAll) is True and @link(DisplayHorz) is False, returns the
      total height of all images and spaces between them (specified by @link(Spacing)). }
    property MaxHeight: Integer read FMaxHeight;
    { Returns the width of the image that has the maximum width of all icon images.
      When both @link(DisplayAll) and @link(DisplayHorz) is True, returns the
      total width of all images and spaces between them (specified by @link(Spacing)). }
    property MaxWidth: Integer read FMaxWidth;
    { This property applies only when DisplayAll is False. It determines whether
      the icon image corresponding to the RequestedSize property and the current
      display mode color resolution (True) or the subimage specified by CurrentIndex
      (False) should be displayed. }
    property OptimalIcon: Boolean read FOptimalIcon write SetOptimalIcon;
    { Controls the decision threshold for the optimal image when OptimalIcon is True.
      The bigger the value is, the less is the probability a subimage greater than
      RequestedSize will be selected. This value is big enough by default so that
      almost always a smaller image will be selected if none with the exact size is found. }
    property OverSizeWeight: Single read FOverSizeWeight write SetOverSizeWeight;
    { Specifies the preferred image size when OptimalIcon is True.
      When OverSizeWeight is small, a greater subimage may be often selected. }
    property RequestedSize: TKIconDimension read FRequestedSize write SetRequestedSize;
    { Specifies the spacing between icon images when @link(DisplayAll) is True. }
    property Spacing: Integer read FSpacing write SetSpacing;
    { Specifies whether icon images can be stretched when drawn. This property
      was introduced perhaps only for backward compatibility with Graphics.TIcon. }
    property StretchEnabled: Boolean read FStretchEnabled write SetStretchEnabled;
    { Makes it possible to read/modify the width of an icon image. }
    property Widths[Index: Integer]: Integer read GetWidths write SetWidths;
  end;

  { This class is necessary because of the TPicture streaming. }
  TIcon = class(TKIcon);

{ Creates a bitmap from an icon object stored in application resources. }
function CreateBitmapFromResIcon(const ResName: string; ResType: PChar = RT_ICON): TBitmap;

{ Creates an alpha bitmap from an icon object stored in application resources. }
function CreateAlphaBitmapFromResIcon(const ResName: string; ResType: PChar): TKAlphaBitmap;

{ Returns the str1ucture containing hXOR and hAND bitmaps. }
function MakeHandles(hXOR, hAND: HBITMAP): TKIconHandles;

{ Returns the total number of resources of a type specified by ResType
  in a module identified by Instance. }
function GetModuleResourceCount(Instance: HINST; ResType: PChar): Integer;

{ Returns the total number of HW-independent icon resources
  in a module identified by Instance. }
function GetModuleIconCount(Instance: HINST): Integer; overload;

{ Returns the total number of HW-independent icon resources
  in a module identified by ModuleName. }
function GetModuleIconCount(const ModuleName: string): Integer; overload;

{ Integrates KIcon into TPicture. }
procedure RegisterKIcon;

{ Removes KIcon from TPicture. }
procedure UnregisterKIcon;

{$ENDIF}

implementation

{$IFDEF USE_WINAPI}

uses
  Math, Registry, KFunctions;

type
  TKMaskBitmapInfo = packed record
    Header: TBitmapInfoHeader;
    Black,
    White: TRGBQuad;
  end;

procedure FreeSubimage(PID: PKIconData);
begin
  FreeMem(PID.iXOR);
  if PID.hXOR <> 0 then DeleteObject(PID.hXOR);
  if PID.hAND <> 0 then DeleteObject(PID.hAND);
  PID.PNG.Free;
  FillChar(PID^, SizeOf(TKIconData), 0);
end;

function CalcByteWidth(Width, Bpp: Integer): Integer;
begin
  Result := DivUp(Width * Bpp, SizeOf(LongWord) shl 3) * SizeOf(LongWord);
end;

function CalcBitmapSize(Width, Height, Bpp: Integer): Integer;
begin
  Result := CalcByteWidth(Width, Bpp) * Height;
end;

procedure CalcByteWidths(Width, Bpp: Integer; out XORWidth, ANDWidth: Integer);
begin
  XORWidth := CalcByteWidth(Width, Bpp);
  ANDWidth := CalcByteWidth(Width, 1);
end;

procedure CalcBitmapSizes(Width, Height, Bpp: Integer; out XORSize, ANDSize: Integer);
begin
  XORSize := CalcBitmapSize(Width, Height, Bpp);
  ANDSize := CalcBitmapSize(Width, Height, 1);
end;

function GetPaletteSize(Bpp: Integer): Integer;
begin
  if Bpp <= 8 then
    Result := 1 shl Bpp
  else
    Result := 0;
end;

procedure QueryBitmapBits(DC: HDC; hBmp: HBITMAP; var Bits: Pointer; var Size: Integer);
var
  BInfo: Windows.TBitmap;
  BI: TBitmapInfo;
begin
  GetObject(hBmp, SizeOf(Windows.TBitmap), @BInfo);
  Size := CalcBitmapSize(BInfo.bmWidth, BInfo.bmHeight, BInfo.bmBitsPixel);
  GetMem(Bits, Size);
  FillChar(BI, SizeOf(TBitmapInfo), 0);
  with BI.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := BInfo.bmWidth;
    biHeight := BInfo.bmHeight;
    biPlanes := 1;
    biBitCount := BInfo.bmBitsPixel;
    biCompression := BI_RGB;
  end;
  GetDIBits(DC, hBmp, 0, BInfo.bmHeight, Bits, BI, DIB_RGB_COLORS);
end;

procedure CreateColorInfo(Width, Height, Bpp: Integer; var BI: PBitmapInfo; var InfoSize: Integer);
begin
  InfoSize := SizeOf(TBitmapInfoHeader) + GetPaletteSize(Bpp) * SizeOf(TRGBQuad);
  GetMem(BI, InfoSize);
  FillChar(BI^, InfoSize, 0);
  with BI.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := Width;
    biHeight := Height;
    biPlanes := 1;
    biBitCount := Bpp;
  end;
end;

procedure CreateMaskInfo(Width, Height: Integer; var BIMask: TKMaskBitmapInfo);
begin
  FillChar(BIMask, SizeOf(TKMaskBitmapInfo), 0);
  with BIMask.Header do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := Width;
    biHeight := Height;
    biPlanes := 1;
    biBitCount := 1;
  end;
  Cardinal(BIMask.Black) := clBlack;
  Cardinal(BIMask.White) := clWhite;
end;

function CreateMonochromeBitmap(Width, Height: Integer): HBITMAP;
begin
  Result := GDICheck(CreateBitmap(Width, Height, 1, 1, nil));
end;

procedure MaskOrBitBlt(ACanvas: TCanvas; X, Y, Width, Height: Integer;
  DC_XOR, DC_AND: HDC; BM_XOR, BM_AND: HBITMAP;
  XORBits: PKColorRecs; XORSize: Integer;
  ANDBits: PBytes; ANDSize: Integer;
  Bpp: Integer; Style: TKIconDrawStyle);
var
  I, J, K, LAnd: Integer;
  Alpha, ByteMask: Byte;
  FreeBits: Boolean;
  Q: PBytes;
  Ps, Pd: PKColorRecs;
  BMSrc, BMDest: TKAlphaBitmap;
  R: TRect;
begin
  if Style <> idsMaskOnly then
  begin
    BMSrc := TKAlphaBitmap.Create;
    try
      BMDest := TKAlphaBitmap.Create;
      try
        R := Rect(X, Y, X + Width, Y + Height);
        BMSrc.SetSize(Width, Height);
        if Bpp = 32 then
        begin // perform alphablend
          if XORBits = nil then
          begin
            QueryBitmapBits(DC_XOR, BM_XOR, Pointer(XORBits), XORSize);
            FreeBits := True;
          end else
            FreeBits := False;
          try
            if Style = idsAlphaChannel then
            begin
              for I := 0 to Height - 1 do
              begin
                Ps := BMSrc.ScanLine[I];
                K := I * Width;
                for J := 0 to Width - 1 do
                begin
                  Alpha := 255 - XORBits[K + J].A;
                  Ps[J].R := Alpha;
                  Ps[J].G := Alpha;
                  Ps[J].B := Alpha;
                end;
              end;
            end else
            begin
              BMSrc.DrawFrom(ACanvas, R);
              for I := 0 to Height - 1 do
              begin
                Ps := @XORBits[I * Width];
                Pd := BMSrc.ScanLine[I];
                BlendLine(Ps, Pd, Width);
              end
            end
          finally
            if FreeBits then FreeMem(XORBits);
          end;
        end else
          BitBlt(BMSrc.Canvas.Handle, 0, 0, Width, Height, DC_XOR, 0, 0, SRCCOPY);
        if Style = idsNormal then
        begin
          BMDest.SetSize(Width, Height);
          BMDest.DrawFrom(ACanvas, R);
          if ANDBits = nil then
          begin
            QueryBitmapBits(DC_XOR, BM_AND, Pointer(ANDBits), ANDSize);
            FreeBits := True;
          end else
            FreeBits := False;
          if ANDBits <> nil then
          begin
            try
              LAnd := CalcByteWidth(Width, 1);
              Q := ANDBits;
              for I := 0 to Height - 1 do
              begin
                Ps := BMSrc.ScanLine[I];
                Pd := BMDest.ScanLine[I];
                ByteMask := $80;
                for J := 0 to Width - 1 do
                begin
                  if Q[J shr 3] and ByteMask <> 0 then
                    Ps[J] := Pd[J];
                  asm
                    ror ByteMask, 1
                  end;
                end;
                Inc(Cardinal(Q), LAnd);
              end;
            finally
              if FreeBits then FreeMem(ANDBits);
            end;
          end;
        end;
        BMSrc.DrawTo(ACanvas, R);
      finally
        BMDest.Free;
      end;
    finally
      BMSrc.Free;
    end;
  end else
  begin
    if DC_AND = 0 then
    begin
      DC_AND := CreateCompatibleDC(ACanvas.Handle);
      try
        SelectObject(DC_AND, BM_AND);
        BitBlt(ACanvas.Handle, X, Y, Width, Height, DC_AND, 0, 0, SrcCopy);
      finally
        DeleteDC(DC_AND);
      end;
    end else
      BitBlt(ACanvas.Handle, X, Y, Width, Height, DC_AND, 0, 0, SrcCopy);
  end;
end;

procedure FillAlphaIfNone(Pixels: PKColorRecs; Size: Integer; Alpha: Byte);
var
  I: Integer;
begin
  Size := Size shr 2;
  for I := 0 to Size - 1 do
    if Pixels[I].A <> 0 then
      Exit; // bitmap has a nonempty alpha channel, don't fill
  for I := 0 to Size - 1 do
    Pixels[I].A := Alpha;
end;

function CreateBitmapFromResIcon(const ResName: string; ResType: PChar): TBitmap;
var
  Icon: TKIcon;
  Stream: TResourceStream;
begin
  Result := TBitmap.Create;
  Icon := TKIcon.Create;
  try
    Stream := TResourceStream.Create(HInstance, ResName, ResType);
    try
      Icon.LoadFromStream(Stream);
      Icon.CopyToBitmap(Icon.CurrentIndex, Result);
    finally
      Stream.Free;
    end;
  finally
    Icon.Free;
  end;
end;

function CreateAlphaBitmapFromResIcon(const ResName: string; ResType: PChar): TKAlphaBitmap;
var
  Icon: TKIcon;
  Stream: TResourceStream;
begin
  Result := TKAlphaBitmap.Create;
  Icon := TKIcon.Create;
  try
    Stream := TResourceStream.Create(HInstance, ResName, ResType);
    try
      Icon.LoadFromStream(Stream);
      Icon.CopyToAlphaBitmap(Icon.CurrentIndex, Result);
    finally
      Stream.Free;
    end;
  finally
    Icon.Free;
  end;
end;

procedure InternalCopyToAlphaBitmap(ABitmap: TKAlphaBitmap;
  BM_XOR: HBITMAP; AndBits: PBytes; Bpp: Integer);
var
  I, J, LAnd: Integer;
  ByteMask: Byte;
  Q: PBytes;
  Ps: PKColorRecs;
  DC: HDC;
begin
  if (ABitmap <> nil) and (AndBits <> nil) and (BM_XOR <> 0) then
  begin
    DC := CreateCompatibleDC(0);
    try
      SelectObject(DC, BM_XOR);
      BitBlt(ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height, DC, 0, 0, SRCCOPY);
      LAnd := CalcByteWidth(ABitmap.Width, 1);
      Q := ANDBits;
      for I := 0 to ABitmap.Height - 1 do
      begin
        Ps := ABitmap.ScanLine[I];
        ByteMask := $80;
        for J := 0 to ABitmap.Width - 1 do
        begin
          if Q[J shr 3] and ByteMask <> 0 then
            Ps[J].A := 0
          else if Bpp < 32 then
            Ps[J].A := 255;    
          asm
            ror ByteMask, 1
          end;
        end;
        Inc(Cardinal(Q), LAnd);
      end;
    finally
      DeleteDC(DC);
    end;
  end;
end;

function MakeHandles(hXOR, hAND: HBITMAP): TKIconHandles;
begin
  Result.hXOR := hXOR;
  Result.hAND := hAND;
end;

function GetModuleResourceCount(Instance: HINST; ResType: PChar): Integer;

  function EnumIcons(hModule: HINST; lpType, lpName: PChar; dwParam: DWORD): BOOL; stdcall;
  begin
    Inc(PInteger(dwParam)^);
    Result := True;
  end;

begin
  Result := 0;
  EnumResourceNames(Instance, ResType, @EnumIcons, DWORD(@Result));
end;

function GetModuleIconCount(Instance: HINST): Integer;
begin
  Result := GetModuleResourceCount(Instance, RT_GROUP_ICON);
end;

function GetModuleIconCount(const ModuleName: string): Integer;
var
  Module: HINST;
begin
  Result := 0;
  Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if Module <> 0 then
  begin
    try
      Result := GetModuleIconCount(Module);
    finally
      FreeLibrary(Module);
    end;
  end;
end;

{ TKIcon }

constructor TKIcon.Create;
begin
  inherited Create;
  FCreating := True;
  try
    Transparent := True; // we are not in Graphics.pas...
  finally
    FCreating := False;
  end;
  FAlignStyle := asCenter;
  FCursor := False;
  FDisplayAll := False;
  FIconDrawStyle := idsNormal;
  FInHandleBpp := 0;
  FInHandleFullAlpha := True;
  FIconData := nil;
  FOptimalIcon := True;
  FOverSizeWeight := 1000.0; // virtually always selects a lower resolution image
  FRequestedSize.Width := 32;
  FRequestedSize.Height := 32;
  FSpacing := 2;
  FStretchEnabled := True;
  Clear;
end;

destructor TKIcon.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TKIcon.Add(const Handles: TKIconHandles);
begin
  Inc(FIconCount);
  SetLength(FIconData, FIconCount);
  FillChar(FIconData[FIconCount - 1], SizeOf(TKIconData), 0);
  LoadHandles(FIconCount - 1, Handles, True);
end;

procedure TKIcon.Assign(Source: TPersistent);
var
  MS: TMemoryStream;
begin
  if (Source = nil) or (Source is TKIcon) then
  begin
    Clear;
    if Source <> nil then
    begin
      FAlignStyle := TKIcon(Source).AlignStyle;
      FCursor := TKIcon(Source).Cursor;
      FDisplayAll := TKIcon(Source).DisplayAll;
      FIconDrawStyle := TKIcon(Source).IconDrawStyle;
      FInHandleBpp := TKIcon(Source).InHandleBpp;
      FInHandleFullAlpha := TKIcon(Source).InHandleFullAlpha;
      FOptimalIcon := TKIcon(Source).OptimalIcon;
      FOverSizeWeight := TKIcon(Source).OverSizeWeight;
      FRequestedSize := TKIcon(Source).RequestedSize;
      FSpacing := TKIcon(Source).Spacing;
      FStretchEnabled := TKIcon(Source).StretchEnabled;
      if not TKIcon(Source).Empty then
      begin
        MS := TMemoryStream.Create;
        try
          TKIcon(Source).SaveToStream(MS);
          MS.Position := 0;
          LoadFromStream(MS);
          FCurrentIndex := TKIcon(Source).CurrentIndex;
        finally
          MS.Free;
        end;
      end else
        Changed(Self);
    end else
      Changed(Self);
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TKIcon.Changed(Sender: TObject);
begin
  Update;
  inherited;
end;

procedure TKIcon.Clear;
var
  I: Integer;
begin
  if FIconData <> nil then
  begin
    for I := 0 to FIconCount - 1 do
      FreeSubimage(@FIconData[I]);
    FIconData := nil;
  end;
  FIconCount := 0;
  Update;
end;

procedure TKIcon.CopyToAlphaBitmap(Index: Integer; Bitmap: TKAlphaBitmap);
var
  ID: TKIconData;
{$IFDEF USE_PNG_SUPPORT}
  I, J: Integer;
  C: TKColorRec;
 {$IFDEF FPC}
  IM: TLazIntfImage;
  FC: TFPColor;
 {$ENDIF}
{$ENDIF}
begin
  if (Index >= 0) and (Index < FIconCount) and (Bitmap <> nil) then
  begin
    ID := FIconData[Index];
    Bitmap.SetSize(ID.Width, ID.Height);
    Bitmap.DirectCopy := True;
    try
      if ID.IsPng then
      begin
    {$IFDEF USE_PNG_SUPPORT}
      {$IFDEF FPC}
        IM := ID.PNG.CreateIntfImage;
        try
          for I := 0 to ID.Width - 1 do
            for J := 0 to ID.Height - 1 do
            begin
              FC := IM.Colors[I, J];
              C.A := FC.alpha; C.B := FC.blue; C.R := FC.red; C.G := FC.green;
              Bitmap.Pixel[I, J] := C;
            end;
        finally
          IM.Free;
        end;
      {$ELSE}
        for I := 0 to ID.Width - 1 do
          for J := 0 to ID.Height - 1 do
          begin
            C.Value := ID.PNG.Pixels[I, J];
            C.A := ID.PNG.AlphaScanline[J][I];
            Bitmap.Pixel[I, J] := C;
          end;
      {$ENDIF}
    {$ENDIF}
      end else
        InternalCopyToAlphaBitmap(Bitmap, ID.hXOR, ID.pAND, ID.Bpp);
    finally
      Bitmap.DirectCopy := False;
    end;
  end;
end;

procedure TKIcon.CopyToBitmap(Index: Integer; Bitmap: TBitmap);
var
  DC: HDC;
  ID: TKIconData;
  Mask: TBitmap;
begin
  if (Index >= 0) and (Index < FIconCount) and (Bitmap <> nil) then
  begin
    ID := FIconData[Index];
  {$IFDEF FPC}
    Bitmap.PixelFormat := PixelFormatFromBpp(ID.Bpp);
  {$ELSE}
    Bitmap.PixelFormat := pf32bit;
  {$ENDIF}
    Bitmap.Width := ID.Width; // SetSize not supported prior Delphi 2006
    Bitmap.Height := ID.Height;
    if ID.IsPng then
  {$IFDEF USE_PNG_SUPPORT}
      Bitmap.Canvas.Draw(0, 0, ID.PNG)
  {$ENDIF}
    else
    begin
      Mask := TBitmap.Create;
      try
        Mask.MonoChrome := True;
        Mask.Width := ID.Width;
        Mask.Height := ID.Height;
        DC := CreateCompatibleDC(0);
        try
          SelectObject(DC, ID.hXOR);
          BitBlt(Bitmap.Canvas.Handle, 0, 0, ID.Width, ID.Height, DC, 0, 0, SRCCOPY);
          SelectObject(DC, ID.hAND);
          BitBlt(Mask.Canvas.Handle, 0, 0, ID.Width, ID.Height, DC, 0, 0, SRCCOPY);
          Bitmap.MaskHandle := Mask.ReleaseHandle;
        finally
          DeleteDC(DC);
        end;
      finally
        Mask.Free;
      end;
    end;
  end;
end;

{$IFDEF USE_PNG_SUPPORT}
procedure TKIcon.CopyToPng(Index: Integer; Png: TKPngImage);
var
  ID: TKIconData;
{$IFNDEF FPC}
  I, J: Integer;
  C: TKColorRec;
  Bitmap: TKAlphaBitmap;
{$ENDIF}
begin
  if (Index >= 0) and (Index < FIconCount) and (Png <> nil) then
  begin
    ID := FIconData[Index];
    if ID.IsPNG then
      Png.Assign(ID.PNG)
    else
    begin
    {$IFDEF FPC}
      Png.LoadFromBitmapHandles(ID.hXOR, ID.hAND);
    {$ELSE}
      Bitmap := TKAlphaBitmap.Create;
      try
        Bitmap.SetSize(ID.Width, ID.Height);
        Bitmap.DirectCopy := True;
        InternalCopyToAlphaBitmap(Bitmap, ID.hXOR, ID.pAND, ID.Bpp);
        Png.CreateBlank(COLOR_RGBALPHA, 8, ID.Width, ID.Height);
        for I := 0 to ID.Width - 1 do
          for J := 0 to ID.Height - 1 do
          begin
            C := Bitmap.Pixel[I, J];
            Png.Pixels[I, J] := C.Value;
            Png.AlphaScanline[J][I] := C.A;
          end;
      finally
        Bitmap.Free;
      end;
    {$ENDIF}
    end;
  end;  
end;
{$ENDIF}

function TKIcon.CreateHandle(Index: Integer): HICON;
var
  ABpp, ANDSize, XORSize: Integer;
  PID: PKIconData;
  PBI: PBitmapInfo;
  DC: HDC;
  hBmp: HBITMAP;
  ANDBits, XORBits: Pointer;
begin
  Result := 0;
  if FIconData <> nil then
  begin
    DC := GetDC(0);
    try
      ABpp := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
      if ABpp <> FBpp then
        Update;
      if FDisplayAll then
      begin
        if (Index < 0) or (Index >= FIconCount) then
          Index := 0;
      end
      else if (Index < 0) or (Index >= FIconCount) then
        Index := FCurrentIndex;
      PID := @FIconData[Index];
      CalcBitmapSizes(PID.Width, PID.Height, FBpp, XORSize, ANDSize);
      GetMem(XORBits, XORSize);
      try
        GetMem(ANDBits, XORSize);
        try
          PBI := PID.iXOR;
          hBmp := GDICheck(CreateDIBitmap(DC, PBI.bmiHeader, CBM_INIT, PID.pXOR, PBI^, DIB_RGB_COLORS));
          try
            GetBitmapBits(hBmp, XORSize, XORBits); // obsolete, but the only that works fine...
            GetBitmapBits(PID.hAND, ANDSize, ANDbits);
            Result := CreateIcon(HInstance, PID.Width, PID.Height, 1, FBpp, ANDBits, XORBits);
          finally
            if hBmp <> 0 then DeleteObject(hBmp);
          end;
        finally
          FreeMem(ANDBits);
        end;
      finally
        FreeMem(XORBits);
      end;
    finally
      ReleaseDC(0, DC);
    end;
  end
end;

procedure TKIcon.Delete(Index: Integer);
var
  I: Integer;
begin
  if (Index >= 0) and (Index < FIconCount) then
  begin
    FreeSubimage(@FIconData[Index]);
    for I := Index + 1 to FIconCount - 1 do
      FIconData[I - 1] := FIconData[I];
    Dec(FIconCount);
    SetLength(FIconData, FIconCount);
    Changed(Self);
  end;
end;

procedure TKIcon.Draw(ACanvas: TCanvas; const Rect: TRect);

  procedure Display(const P, WH: TPoint; Index: Integer);
  var
    ID: TKIconData;
    Stretch: Boolean;
    DC, DC_XOR, DC_AND: HDC;
    BM_XOR, BM_AND: HBITMAP;
    Obj, Obj_XOR, Obj_AND: HGDIObj;
  begin
    if (Index >= 0) and (Index < FIconCount) then
    begin
      ID := FIconData[Index];
      if ID.IsPNG then
      begin
      {$IFDEF USE_PNG_SUPPORT}
        ACanvas.StretchDraw(Classes.Rect(P.X, P.Y, P.X + WH.X, P.Y + WH.Y), ID.PNG);
      {$ENDIF}
      end else
      begin
        Stretch := FStretchEnabled and ((WH.X <> ID.Width) or (WH.Y <> ID.Height));
        DC := GDICheck(CreateCompatibleDC(0));
        try
          Obj := SelectObject(DC, ID.hXOR);
          if Stretch then
          begin
            DC_XOR := GDICheck(CreateCompatibleDC(DC));
            try
              BM_XOR := GDICheck(CreateCompatibleBitmap(DC, WH.X, WH.Y));
              try
                DC_AND := GDICheck(CreateCompatibleDC(DC));
                try
                  BM_AND := GDICheck(CreateMonochromeBitmap(WH.X, WH.Y));
                  try
                    Obj_XOR := SelectObject(DC_XOR, BM_XOR);
                    Obj_AND := SelectObject(DC_AND, BM_AND);
                    //SetStretchBltMode(DC_XOR, HALFTONE); //does not distribute alpha channel etc.
                    StretchBlt(DC_XOR, 0, 0, WH.X, WH.Y, DC, 0, 0, ID.Width, ID.Height, SRCCOPY);
                    SelectObject(DC, ID.hAND);
                    StretchBlt(DC_AND, 0, 0, WH.X, WH.Y, DC, 0, 0, ID.Width, ID.Height, SRCCOPY);
                    MaskOrBitBlt(ACanvas, P.X, P.Y, WH.X, WH.Y, DC_XOR, DC_AND, BM_XOR, BM_AND,
                      nil, 0, nil, 0, ID.Bpp, FIconDrawStyle);
                    SelectObject(DC_XOR, Obj_XOR);
                    SelectObject(DC_AND, Obj_AND);           
                  finally
                    DeleteObject(BM_AND);
                  end;
                finally
                  DeleteDC(DC_AND);
                end;
              finally
                DeleteObject(BM_XOR);
              end;
            finally
              DeleteDC(DC_XOR);
            end;
          end else
            MaskOrBitBlt(ACanvas, P.X, P.Y, ID.Width, ID.Height, DC, 0, ID.hXOR, ID.hAND,
              ID.pXOR, ID.pXORSize, ID.pAND, ID.pANDSize, ID.Bpp, FIconDrawStyle);
          SelectObject(DC, Obj);
        finally
          DeleteDC(DC);
        end;
      end;
    end;
  end;

var
  ABpp, AWidth, AHeight, I: Integer;
  P, WH, WH_S: TPoint;
begin
  with ACanvas do if FIconData <> nil then
  begin
    P := Rect.TopLeft;
    WH := Point(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
    if not FStretchEnabled then
    begin
      Inc(P.X, (WH.X - Width) div 2);
      Inc(P.Y, (WH.Y - Height) div 2);
    end;
    if FDisplayAll then
    begin
      AWidth := Width;
      AHeight := Height;
      WH_S := WH;
      for I := 0 to FIconCount - 1 do
      begin
        WH_S.X := FIconData[I].Width * WH.X div AWidth;
        WH_S.Y := FIconData[I].Height * WH.Y div AHeight;
        Display(P, WH_S, I);
        if FDisplayHorz then
          Inc(P.X, (FIconData[I].Width + FSpacing) * WH.X div AWidth)
        else
          Inc(P.Y, (FIconData[I].Height + FSpacing) * WH.Y div AHeight)
      end;
    end else
    begin
      ABpp := GetDeviceCaps(Handle, PLANES) * GetDeviceCaps(Handle, BITSPIXEL);
      if ABpp <> FBpp then
        Update;
      Display(P, WH, FCurrentIndex);
    end;
  end;
end;

function TKIcon.GetDimensions(Index: Integer): TKIconDimension;
begin
  Result.Width := 0; Result.Height := 0;
  if (Index >= 0) and (Index < FIconCount) then
  begin
    Result.Width := FIconData[Index].Width;
    Result.Height := FIconData[Index].Height;
  end;
end;

function TKIcon.GetEmpty: Boolean;
begin
  Result := FIconData = nil;
end;

function TKIcon.GetHandles(Index: Integer): TKIconHandles;
begin
  if (Index >= 0) and (Index < FIconCount) then
  begin
    Result.hXOR := FIconData[Index].hXOR;
    Result.hAND := FIconData[Index].hAND;
  end else
  begin
    Result.hXOR := 0;
    Result.hAND := 0;
  end;
end;

function TKIcon.GetHeight: Integer;
begin
  if FDisplayAll and (FIconCount > 0) then
    Result := FMaxHeight
  else
    Result := Heights[FCurrentIndex];
end;

function TKIcon.GetTransparent: Boolean;
begin
  Result := True;
end;

function TKIcon.GetHeights(Index: Integer): Integer;
begin
  Result := 0;
  if (Index >= 0) and (Index < FIconCount) then
    Result := FIconData[Index].Height;
end;

function TKIcon.GetHotSpot(Index: Integer): TPoint;
begin
  Result.X := 0; Result.Y := 0;
  if (Index >= 0) and (Index < FIconCount) then
    Result := FIconData[Index].HotSpot;
end;

function TKIcon.GetIconData(Index: Integer): TKIconData;
begin
  FillChar(Result, SizeOf(TKIconData), #0);
  if (Index >= 0) and (Index < FIconCount) then
    Result := FIconData[Index];
end;

function TKIcon.GetWidth: Integer;
begin
  if FDisplayAll and (FIconCount > 0) then
    Result := FMaxWidth
  else
    Result := Widths[FCurrentIndex];
end;

function TKIcon.GetWidths(Index: Integer): Integer;
begin
  Result := 0;
  if (Index >= 0) and (Index < FIconCount) then
    Result := FIconData[Index].Width;
end;

procedure TKIcon.Insert(Index: Integer; const Handles: TKIconHandles);
var
  I: Integer;
begin
  if Index >= 0 then
    if Index < FIconCount then
    begin
      Inc(FIconCount);
      SetLength(FIconData, FIconCount);
      for I := FIconCount - 2 downto Index do
        FIconData[I + 1] := FIconData[I];
      FillChar(FIconData[Index], SizeOf(TKIconData), 0);
      LoadHandles(Index, Handles, True);
    end else
      Add(Handles);
end;

{$IFNDEF FPC}
procedure TKIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
begin
  // does nothing
end;
{$ENDIF}

procedure TKIcon.LoadFromHandle(Handle: HICON);
var
  Handles: TKIconHandles;
  Info: TIconInfo;
begin
  if (Handle <> 0) and GetIconInfo(Handle, Info) then
  try
    Clear;
    SetLength(FIconData, 1);
    FillChar(FIconData[0], SizeOf(TKIconData), 0);
    FIconCount := 1;
    Handles.hXOR := Info.hbmColor;
    Handles.hAND := Info.hbmMask;
    LoadHandles(0, Handles, False);
  finally
    DeleteObject(Info.hbmColor);
    DeleteObject(Info.hbmMask);
  end;
end;

procedure TKIcon.LoadFromAssocFile(const FileName: string);
begin
  try
    LoadFromAssocExtension(ExtractFileExt(FileName));
  except
    LoadFromModuleByIndex(FileName, 0);
  end;
end;

procedure TKIcon.LoadFromAssocExtension(const Extension: string);
const
  IconKey = 'DefaultIcon';
var
  Code, DashPos, I: Integer;
  Module, S, T: string;
  Reg: TRegistry;
begin
  if Extension = '' then Error(SIconAssocResolveError);
  Reg := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    if not Reg.KeyExists(Extension) then Error(SIconAssocResolveError);
    Reg.OpenKeyReadOnly(Extension);
    try
      S := Reg.ReadString('');
    finally
      Reg.CloseKey;
    end;
    if S = '' then Error(SIconAssocResolveError);
    S := Format('%s\%s', [S, IconKey]);
    if not Reg.KeyExists(S) then Error(SIconAssocResolveError);
    Reg.OpenKeyReadOnly(S);
    try
      S := Reg.ReadString('');
      if S = '' then Error(SIconAssocResolveError);
    finally
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  DashPos := Pos(',', S);
  if DashPos > 1 then
    Module := Copy(S, 1, DashPos - 1)
  else
    Module := S;
  while CharInSetEx(Module[1], [#9, #32, '''', '"']) do System.Delete(Module, 1, 1);
  while CharInSetEx(Module[Length(Module)], [#9, #32, '''', '"']) do System.Delete(Module, Length(Module), 1);
  if Module[1] = '%' then
  begin
    System.Delete(Module, 1, 1);
    I := Pos('%', Module);
    if I >= 1 then
    begin
      T := GetEnvironmentVariable(Copy(Module, 1, I - 1));
      if T <> '' then
      begin
        System.Delete(Module, 1, I);
        Module := T + Module;
      end;
    end;
  end;
  if not FileExists(Module) then Error(SIconAssocResolveError);
  T := LowerCase(ExtractFileExt(Module));
  if T = '.ico' then
    LoadFromFile(Module)
  else
  begin
    if DashPos > 0 then
    begin
      T := Copy(S, DashPos + 1, Length(S));
      while CharInSetEx(T[1], [#9, #32]) do System.Delete(T, 1, 1);
      Val(T, I, Code);
    end else
    begin
      I := 0;
      Code := 0;
    end;
    if (Code = 0) and (I >= 0) then
      LoadFromModuleByIndex(Module, I)
    else
    begin
      if Code = 0 then
        T[1] := '#';
      LoadFromModule(Module, T);
    end;
  end;
end;

procedure TKIcon.LoadFromModule(const ModuleName: string; ID: Word);
begin
  LoadFromModule(ModuleName, Format('#%d', [ID]));
end;

procedure TKIcon.LoadFromModule(const ModuleName, ResName: string);
var
  Module: HINST;
begin
  Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if Module = 0 then Error(SIconInvalidModule);
  try
    LoadFromResource(Module, ResName);
  finally
    FreeLibrary(Module);
  end;
end;

procedure TKIcon.LoadFromModuleByIndex(const ModuleName: string; Index: Integer);
var
  Module: HINST;
begin
  Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if Module = 0 then Error(SIconInvalidModule);
  try
    LoadFromResourceByIndex(Module, Index);
  finally
    FreeLibrary(Module);
  end;
end;

procedure TKIcon.LoadFromResource(Instance: HINST; ID: Word);
begin
  LoadFromResource(Instance, Format('#%d', [ID]));
end;

procedure TKIcon.LoadFromResource(Instance: HINST; const ResName: string);
const
  ResGroup: array[Boolean] of PChar = (RT_GROUP_ICON, RT_GROUP_CURSOR);
  ResItem: array[Boolean] of PChar = (RT_ICON, RT_CURSOR);
var
  I, L, IconName, ANDSize, PalSize, XORInfoSize, XORSize: Integer;
  Masked: Boolean;
  PIC: PKIconCursorInRes;
  PBIn: PBitmapInfo;
  PID: PKIcondata;
  BIMask: TKMaskBitmapInfo;
  hGroup, hItem: HRSRC;
  hMemGroup, hMem: HGLOBAL;
  DC: HDC;
  HSign: TKImageHeaderString;
{$IFDEF USE_PNG_SUPPORT}
  Stream: TMemoryStream;
{$ENDIF}

  function GetResSize(Instance: HINST; Entry : PKIconCursorDirEntryInRes) : integer;
  var
    Rsrc: HRSRC;
    C: Cardinal;
  begin
    Result := Entry.dwBytesInRes;
    Rsrc := FindResource(Instance, Pointer(Entry.wEntryName), RT_ICON);
    if Rsrc <> 0 then
    begin
      C := SizeofResource(Instance,Rsrc);
      if C <> 0 then      // maybe if C > Result ??
        Result := C;
    end;
  end;

begin
  hGroup := FindResource(Instance, PChar(ResName), ResGroup[FCursor]);
  if hGroup = 0 then Error(SIconResourceError);
  hMemGroup := LoadResource(Instance, hGroup);
  if hMemGroup = 0 then Error(SIconResourceError);
  PIC := LockResource(hMemGroup);
  if (PIC.IH.idType = 1) and FCursor or (PIC.IH.idType = 2) and not FCursor then
    Error(SIconResourceError);
  DC := GetDC(0);
  try
    Clear;
    FIconCount := PIC.IH.idCount;
    SetLength(FIconData, FIconCount);
    FillChar(FIconData[0], SizeOf(TKIconData) * FIconCount, 0);
    for I := 0 to PIC.IH.idCount - 1 do
    begin
      IconName := PIC.Entries[I].wEntryName;
      hItem := FindResource(Instance, PChar(IconName), ResItem[FCursor]);
      if hItem = 0 then Error(SIconResourceError);
      hMem := LoadResource(Instance, hItem);
      if hMem = 0 then Error(SIconResourceError);
      PBIn := LockResource(hMem);
      try
        PID := @FIconData[I];
        try
          if FCursor then
          begin
            PID.Width := PIC.Entries[I].Info.Cursor.Width;
            PID.Height := PIC.Entries[I].Info.Cursor.Height;
            PID.HotSpot.X := PKCursorHotSpot(PBIn).xHotSpot;
            PID.HotSpot.Y := PKCursorHotSpot(PBIn).yHotSpot;
            Inc(Integer(PBIn), SizeOf(TKCursorHotSpot));
          end else
          begin
            PID.Width := PIC.Entries[I].Info.Icon.Width;
            PID.Height := PIC.Entries[I].Info.Icon.Height;
          end;
          if PID.Width = 0 then PID.Width := 256;
          if PID.Height = 0 then PID.Height := 256;
//          PID.BytesInRes := PIC.Entries[I].dwBytesInRes;    // gigo
          PID.BytesInRes := GetResSize(Instance,@PIC.Entries[I]);
          PID.Bpp := PIC.Entries[I].wBitCount;
          L := Min(8, PID.BytesInRes);
          Byte(HSign[0]) := L;
          Move(PBIn^, HSign[1], L);
          if (HSign = PNGHeader) or (HSign = MNGHeader) then
          begin
            PID.IsPNG := True;
            PID.PNG := TKIconPngObject.Create;
          {$IFDEF USE_PNG_SUPPORT}
            Stream := TMemoryStream.Create;
            try
              Stream.Write(PBIn^, PID.BytesInRes);
              Stream.Seek(0, soFromBeginning);
              PID.PNG.LoadFromStream(Stream);
            finally
              Stream.Free;
            end;
          {$ELSE}
            PID.PNG.Write(PBIn^, PID.BytesInRes);
          {$ENDIF}
          end else
          begin
            //PID.Bpp := PIC.Entries[I].wBitCount; // this is wrong in some icons
            PID.Bpp := PBIn.bmiHeader.biBitCount;
            PID.Width := PBIn.bmiHeader.biWidth;         // gigo
            PID.Height := PBIn.bmiHeader.biHeight shr 1;       // gigo
            CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize);
            PalSize := GetPaletteSize(PID.Bpp);
            XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad);
            Masked := PID.BytesInRes = XORInfoSize + XORSize + ANDSize;
            if not Masked then Error(SIconFormatError);
            GetMem(PID.iXOR, XORInfoSize);
            PID.iXORSize := XORInfoSize;
            Move(PBIn^, PID.iXOR^, XORInfoSize);
            PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight div 2;
            PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^,
              DIB_RGB_COLORS, PID.pXOR, 0, 0));
            if PID.pXOR <> nil then
            begin
              Move(Pointer(Cardinal(PBIn) + Cardinal(XORInfoSize))^, PID.pXOR^, XORSize);
              PID.pXORSize := XORSize;
            end else
              Error(SIconAllocationError);
            CreateMaskInfo(PID.Width, PID.Height, BIMask);
            PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^,
              DIB_RGB_COLORS, PID.pAND, 0, 0));
            if PID.pAND <> nil then
            begin
              Move(Pointer(Cardinal(PBIn) + Cardinal(XORInfoSize + XORSize))^, PID.pAND^, ANDSize);
              PID.pANDSize := ANDSize;
            end else
              Error(SIconAllocationError);
          end;
        except
          FreeSubimage(PID);
          raise;
        end;
      finally
        UnlockResource(hMem); // this is not necessary, but...
        FreeResource(hMem);
      end;
    end;
  finally
    ReleaseDC(0, DC);
    UnlockResource(hMemGroup); // this is not necessary, but...
    FreeResource(hMemGroup);
  end;
  Changed(Self);
end;

type
  PCallBack = ^TCallBack;
  TCallBack = record
    I,
    Index: Integer;
    S: string;
  end;

  function EnumIcons(hModule: HINST; lpType: DWORD; lpName: PChar; dwParam: DWORD): BOOL; stdcall;
  var
    CB: PCallBack;
  begin
    CB := PCallBack(dwParam);
    if CB.I = CB.Index then
    begin
      if HiWord(Cardinal(lpName)) = 0 then
        CB.S := Format('#%d', [Cardinal(lpName)])
      else
        CB.S := lpName;
      Result := False;
    end else
      Result := True;
    Inc(CB.I);
  end;

procedure TKIcon.LoadFromResourceByIndex(Instance: HINST; Index: Integer);
var
  CB: TCallBack;
begin
  CB.I := 0;
  CB.Index := Index;
  CB.S := '';
  EnumResourceNames(Instance, RT_GROUP_ICON, @EnumIcons, DWORD(@CB));
  if CB.S <> '' then
    LoadFromResource(Instance, CB.S)
  else if CB.I = 0 then
    Error(SIconInvalidModule)
  else
    Error(SIconIndexError);
end;

procedure TKIcon.LoadFromStream(Stream: TStream);
var
  I, ANDSize, PalSize, XORInfoSize, XORSize: Integer;
  Masked: Boolean;
  PID: PKIconData;
  IH: TKIconHeader;
  II: TKIconCursorDirEntry;
  BI: TBitmapInfoHeader;
  BIMask: TKMaskBitmapInfo;
  DC: HDC;
  HSign: TKImageHeaderString;
{$IFDEF USE_PNG_SUPPORT}
  MS: TMemoryStream;
{$ENDIF}
begin
  if Stream <> nil then
  begin
    DC := GetDC(0);
    try
      Clear;
      Stream.Read(IH, SizeOf(TKIconHeader));
      FCursor := IH.idType = 2;
      FIconCount := IH.idCount;
      SetLength(FIconData, FIconCount);
      FillChar(FIconData[0], SizeOf(TKIconData) * FIconCount, 0);
      for I := 0 to FIconCount - 1 do
      begin
        PID := @FIconData[I];
        Stream.Read(II, SizeOf(TKIconCursorDirEntry));
        // for PNG read icon size here, otherwise this is overwritten when XOR bitmap is read
        PID.Width := II.Width;
        if PID.Width = 0 then PID.Width := 256;
        PID.Height := II.Height;
        if PID.Height = 0 then PID.Height := 256;
        if FCursor then
        begin
          PID.HotSpot.X := II.Info.wX;
          PID.HotSpot.Y := II.Info.wY;
        end;
        PID.BytesInRes := II.dwBytesInRes;
        PID.Offset := II.dwImageOffset;
        PID.Bpp := II.Info.wBitCount; // for PNG icons bpp is stored here
      end;
      for I := 0 to FIconCount - 1 do
      begin
        PID := @FIconData[I];
        try
          Byte(HSign[0]) := Stream.Read(HSign[1], 8);
          Stream.Seek(-8, soFromCurrent);
          if (HSign = PNGHeader) or (HSign = MNGHeader) then
          begin
            PID.IsPNG := True;
            PID.PNG := TKIconPngObject.Create;
          {$IFDEF USE_PNG_SUPPORT}
            MS := TMemoryStream.Create;
            try
              MS.CopyFrom(Stream, PID.BytesInRes); // secure icon integrity
              MS.Seek(0, soFromBeginning);
              PID.PNG.LoadFromStream(MS);
            finally
              MS.Free;
            end;
          {$ELSE}
            PID.PNG.CopyFrom(Stream, PID.BytesInRes);
          {$ENDIF}
          end else
          begin
            Stream.Read(BI, SizeOf(TBitmapInfoHeader));
            PID.Bpp := BI.biBitCount;
            PID.Width := BI.biWidth;
            PID.Height := BI.biHeight shr 1;
            PalSize := GetPaletteSize(PID.Bpp);
            CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize);
            XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad);
            Masked := PID.BytesInRes = XORInfoSize + XORSize + ANDSize;
            if not Masked then Error(SIconFormatError);
            BI.biHeight := BI.biHeight div 2;
            GetMem(PID.iXOR, XORInfoSize);
            PID.iXORSize := XORInfoSize;
            PID.iXOR.bmiHeader := BI;
            PID.iXOR.bmiHeader.biSizeImage := 0;
            Stream.Read(PID.iXOR.bmiColors, PalSize * SizeOf(TRGBQuad));
            PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^,
              DIB_RGB_COLORS, PID.pXOR, 0, 0));
            if PID.pXOR <> nil then
            begin
              Stream.Read(PID.pXOR^, XORSize);
              PID.pXORSize := XORSize;
            end else
              Error(SIconAllocationError);
            CreateMaskInfo(PID.Width, PID.Height, BIMask);
            PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^,
              DIB_RGB_COLORS, PID.pAND, 0, 0));
            if PID.pAND <> nil then
            begin
              Stream.Read(PID.pAND^, ANDSize);
              PID.pANDSize := ANDSize;
            end else
              Error(SIconAllocationError);
          end;
        except
          FreeSubimage(PID);
          raise;
        end;
      end;
    finally
      ReleaseDC(0, DC);
    end;
    Changed(Self);
  end;
end;

procedure TKIcon.LoadHandles(Index: Integer; const Handles: TKIconHandles; OrigBpp: Boolean);
var
  ANDSize, PalSize, XORSize, XORInfoSize: Integer;
  PID: PKIconData;
  BInfo: Windows.TBitmap;
  BIMask: TKMaskBitmapInfo;
  P: Pointer;
  DC: HDC;
  hBmp: HBITMAP;
begin
  if (Index >= 0) and (Index < FIconCount) then
  begin
    PID := @FIconData[Index];
    if (Handles.hAND = 0) or
      (Handles.hXOR = PID.hXOR) or (Handles.hAND = PID.hXOR) or
      (Handles.hXOR = PID.hAND) or (Handles.hAND = PID.hAND) then
      Error(SIconBitmapError);
    FreeSubimage(PID);
    DC := GetDC(0);
    try
      try
        if Handles.hXOR <> 0 then
        begin
          GetObject(Handles.hXOR, SizeOf(Windows.TBitmap), @BInfo);
          PID.Height := BInfo.bmHeight;
          if OrigBpp or (FInHandleBpp = 0) then
            PID.Bpp := BInfo.bmPlanes * BInfo.bmBitsPixel
          else
            PID.Bpp := FInHandleBpp;
        end else
        begin // must be a monochrome icon - not fully tested
          GetObject(Handles.hAND, SizeOf(Windows.TBitmap), @BInfo);
          PID.Height := BInfo.bmHeight div 2;
          PID.Bpp := 1;
        end;
        PID.Width := BInfo.bmWidth;
        CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize);
        PalSize := GetPaletteSize(PID.Bpp);
        XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad);
        GetMem(PID.iXOR, XORInfoSize);
        PID.iXORSize := XORInfoSize;
        FillChar(PID.iXOR^, XORInfoSize, 0);
        PID.BytesInRes := XORInfoSize;
        PID.iXOR.bmiHeader.biSize := SizeOf(TBitmapInfoHeader);
        PID.iXOR.bmiHeader.biWidth := PID.Width;
        PID.iXOR.bmiHeader.biHeight := PID.Height;
        PID.iXOR.bmiHeader.biPlanes := 1;
        PID.iXOR.bmiHeader.biBitCount := PID.Bpp;
        PID.iXOR.bmiHeader.biCompression := BI_RGB;
        if Handles.hXOR <> 0 then hBmp := Handles.hXOR else hBmp := Handles.hAND;
        GetDIBits(DC, hBmp, 0, PID.Height, nil, PID.iXOR^, DIB_RGB_COLORS);
        PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^,
          DIB_RGB_COLORS, PID.pXOR, 0, 0));
        if PID.pXOR <> nil then
        begin
          GetDIBits(DC, hBmp, 0, PID.Height, PID.pXOR,
            PID.iXOR^, DIB_RGB_COLORS);
          PID.pXORSize := XORSize;
          if (PID.Bpp = 32) and FInHandleFullAlpha then
            FillAlphaIfNone(PKColorRecs(PID.pXOR), XORSize, $FF);
          Inc(PID.BytesInRes, XORSize);
        end else
          Error(SIconAllocationError);
        CreateMaskInfo(PID.Width, PID.Height, BIMask);
        PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^,
          DIB_RGB_COLORS, PID.pAND, 0, 0));
        if PID.pAND <> nil then
        begin
          if Handles.hXOR <> 0 then
          begin
            GetDIBits(DC, Handles.hAND, 0, PID.Height, PID.pAND,
              PBitmapInfo(@BIMask)^, DIB_RGB_COLORS);
          end else
          begin
            GetMem(P, ANDSize * 2);
            try
              BIMask.Header.biHeight := 2 * PID.Height;
              GetDIBits(DC, Handles.hAND, 0, PID.Height * 2, P,
                PBitmapInfo(@BIMask)^, DIB_RGB_COLORS);
              Move(P^, PID.pAND^, ANDSize);
            finally
              FreeMem(P);
            end;
          end;
          PID.pANDSize := ANDSize;
          Inc(PID.BytesInRes, ANDSize);
        end else
          Error(SIconAllocationError);
      except
        FreeSubimage(PID);
        raise;
      end;
    finally
      ReleaseDC(0, DC);
    end;
    Changed(Self);
  end;
end;

procedure TKIcon.MaskFromColor(Index: Integer; Color: TColor; HasAlpha: Boolean = False);
var
  PID: PKIconData;
  DC: HDC;
  OldObj: HGDIObj;
  BM: TKAlphaBitmap;
  ByteMask: Byte;
  I, J, L, LAnd: Integer;
  ColorMask: Cardinal;
  P: PKColorRecs;
  Q: PBytes;
begin
  if (Index >= 0) and (Index < FIconCount) then
  begin
    Color := SwitchRGBToBGR(Color);
    PID := @FIconData[Index];
    DC := 0;
    BM := TKAlphaBitmap.Create;
    try
      BM.SetSize(PID.Width, PID.Height);
      DC := GDICheck(CreateCompatibleDC(0));
      OldObj := SelectObject(DC, PID.hXOR);
      BitBlt(BM.Canvas.Handle, 0, 0, PID.Width, PID.Height, DC, 0, 0, SRCCOPY);
      FillChar(PID.pAND^, PID.pANDSize, $FF);
      LAnd := CalcByteWidth(PID.Width, 1);
      Q := PID.pAND;
      Inc(Cardinal(Q), PID.pANDSize - LAnd);
      if HasAlpha then ColorMask := $FFFFFFFF else ColorMask := $00FFFFFF;
      for I := 0 to PID.Height - 1 do
      begin
        ByteMask := $7F;
        P := BM.ScanLine[I];
        for J := 0 to PID.Width - 1 do
        begin
          L := J shr 3;
          if P[J].Value and ColorMask <> Cardinal(Color) then
            Q[L] := Q[L] and ByteMask;
          asm
            ror ByteMask, 1
          end;
        end;
        Dec(Cardinal(Q), LAnd);
      end;
      SelectObject(DC, OldObj);
    finally
      if DC <> 0 then DeleteDC(DC);
      BM.Free;
    end;
    Changed(Self);
  end;
end;

procedure TKIcon.SaveToStream(Stream: TStream);
var
  I, Offset, RSize: Integer;
  IH: TKIconHeader;
  PID: PKIconData;
  II: TKIconCursorDirEntry;
{$IFDEF USE_PNG_SUPPORT}
  J, Delta: Integer;
  MS: TMemoryStream;
{$ENDIF}
begin
  if (Stream <> nil) and (FIconData <> nil) then
  begin
    Offset := SizeOf(TKIconHeader) + FIconCount * SizeOf(TKIconCursorDirEntry);
    IH.idReserved := 0;
    if FCursor then IH.idType := 2 else IH.idType := 1;
    IH.idCount := 0;
    for I := 0 to FIconCount - 1 do
      if (FIconData[I].iXOR <> nil) or FIconData[I].IsPNG then
        Inc(IH.idCount);
    Stream.Write(IH, SizeOf(TKIconHeader));
    for I := 0 to FIconCount - 1 do
    begin
      FillChar(II, SizeOf(TKIconCursorDirEntry), 0);  // gigo
      PID := @FIconData[I];
      if PID.IsPNG then
      begin
        II.Width := PID.Width;
        II.Height := PID.Height;
        II.ColorCount := GetPaletteSize(PID.Bpp);
        II.Info.wPlanes := 1;
        II.Info.wBitCount := PID.Bpp;
        II.dwBytesInRes := PID.BytesInRes;
        II.dwImageOffset := Offset;
        Stream.Write(II, SizeOf(TKIconCursorDirEntry));
        Inc(Offset, PID.BytesInRes);
      end
      else if PID.iXOR <> nil then
      begin
        II.Width := PID.Width;
        II.Height := PID.Height;
        II.ColorCount := GetPaletteSize(PID.Bpp);
        if FCursor then
        begin
          II.Info.wX := PID.HotSpot.X;
          II.Info.wY := PID.HotSpot.Y;
        end else
        begin
          II.Info.wPlanes := 1;
          II.Info.wBitCount := PID.Bpp;
        end;
        RSize := PID.iXORSize + PID.pXORSize + PID.pANDSize;
        II.dwBytesInRes := RSize;
        II.dwImageOffset := Offset;
        Stream.Write(II, SizeOf(TKIconCursorDirEntry));
        Inc(Offset, RSize);
      end;
    end;
    for I := 0 to FIconCount - 1 do
    begin
      PID := @FIconData[I];
      if PID.IsPNG then
      begin
      {$IFDEF USE_PNG_SUPPORT}
        MS := TMemoryStream.Create;
        try
          PID.PNG.SaveToStream(MS);
          MS.Seek(0, soFromBeginning);
          //// gigo
          if Ms.Size <> PID.BytesInRes then
          begin
            Delta := PID.BytesInRes - MS.Size;
            PID.BytesInRes := MS.Size;
            Stream.Seek(SizeOf(TKIconHeader) + I * SizeOf(TKIconCursorDirEntry), soFromBeginning);
            Stream.Read(II, SizeOf(TKIconCursorDirEntry));
            II.dwBytesInRes := PID.BytesInRes;
            Stream.Seek(-1 * SizeOf(TKIconCursorDirEntry), soFromCurrent);
            Stream.Write(II, SizeOf(TKIconCursorDirEntry));
            for J := I + 1 to FIconCount - 1 do
            begin
              Stream.Read(II, SizeOf(TKIconCursorDirEntry));
              II.dwImageOffset := II.dwImageOffset - Delta;
              Stream.Seek(-1 * SizeOf(TKIconCursorDirEntry), soFromCurrent);
              Stream.Write(II, SizeOf(TKIconCursorDirEntry));
            end;
            Stream.Seek(0,soFromEnd);
          end;
          //// end gigo
          Stream.CopyFrom(MS, PID.BytesInRes); // secure icon integrity
        finally
          MS.Free;
        end;
      {$ELSE}
        PID.PNG.Seek(0, soFromBeginning);
        Stream.CopyFrom(PID.PNG, PID.BytesInRes);
      {$ENDIF}
      end else if PID.iXOR <> nil then
      begin
        PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight * 2;
        Stream.Write(PID.iXOR^, PID.iXORSize);
        PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight div 2;
        Stream.Write(PID.pXOR^, PID.pXORSize);
        Stream.Write(PID.pAND^, PID.pANDSize);
      end;
    end;
  end;
end;

{$IFNDEF FPC}
procedure TKIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  var APalette: HPALETTE);
begin
  // does nothing
end;
{$ENDIF}

procedure TKIcon.SetCurrentIndex(Value: Integer);
begin
  if (Value >= 0) and (Value < FIconCount) and (Value <> FCurrentIndex) then
  begin
    FCurrentIndex := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetDisplayAll(Value: Boolean);
begin
  if Value <> FDisplayAll then
  begin
    FDisplayAll := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetDisplayHorz(Value: Boolean);
begin
  if Value <> FDisplayHorz then
  begin
    FDisplayHorz := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetDimensions(Index: Integer; Value: TKIconDimension);
begin
  if (Index >= 0) and (Index < FIconCount) and
    (Value.Width > 0) and (Value.Height > 0) and
    (Value.Width <> Widths[Index]) and (Value.Width <> Heights[Index]) then
  begin
    UpdateDim(Index, Value);
    Changed(Self);
  end;
end;

procedure TKIcon.SetHandles(Index: Integer; Value: TKIconHandles);
begin
  LoadHandles(Index, Value, True);
end;

procedure TKIcon.SetHeight(Value: Integer);
begin
  if not FDisplayAll then
    Heights[FCurrentIndex] := Value;
end;

procedure TKIcon.SetHeights(Index: Integer; Value: Integer);
var
  D: TKIconDimension;
begin
  D.Width := Widths[Index];
  D.Height := Value;
  Dimensions[Index] := D;
end;

procedure TKIcon.SetHotSpot(Index: Integer; Value: TPoint);
var
  PID: PKIconData;
begin
  if (Index >= 0) and (Index < FIconCount) then
  begin
    PID := @FIconData[Index];
    if (PID.HotSpot.X <> Value.X) or (PID.HotSpot.Y <> Value.Y) then
    begin
      PID.HotSpot := Value;
      Changed(Self);
    end;
  end;
end;

procedure TKIcon.SetIconDrawStyle(Value: TKIconDrawStyle);
begin
  if Value <> FIconDrawStyle then
  begin
    FIconDrawStyle := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetInHandleBpp(Value: Integer);
begin
  if Value in [0, 1, 4, 8, 32] then
    FInHandleBpp := Value;
end;

procedure TKIcon.SetOptimalIcon(Value: Boolean);
begin
  if Value <> FOptimalIcon then
  begin
    FOptimalIcon := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetOverSizeWeight(Value: Single);
begin
  if Value <> FOverSizeWeight then
  begin
    FOverSizeWeight := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetRequestedSize(Value: TKIconDimension);
begin
  if (Value.Width > 0) and (Value.Height > 0) then
  begin
    FRequestedSize := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetStretchEnabled(Value: Boolean);
begin
  if Value <> FStretchEnabled then
  begin
    FStretchEnabled := Value;
    Changed(Self);
  end;
end;

procedure TKIcon.SetTransparent(Value: Boolean);
begin
  if FCreating then
    inherited
  else
    // Ignore assignments to this property.
    // Icons are always transparent.
end;

procedure TKIcon.SetWidth(Value: Integer);
begin
  if not FDisplayAll then
    Widths[FCurrentIndex] := Value;
end;

procedure TKIcon.SetWidths(Index: Integer; Value: Integer);
var
  D: TKIconDimension;
begin
  D.Width := Value;
  D.Height := Heights[Index];
  Dimensions[Index] := D;
end;

procedure TKIcon.Update;
var
  dW, dH, BestBpp, I, MaxWeight, Weight: Integer;
  DC: HDC;
  PID: PKIconData;
begin
  FBpp := 0;
  FMaxWidth := 0;
  FMaxHeight := 0;
  if FIconData <> nil then
  begin
    DC := GetDC(0);
    try
      FBpp := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
      MaxWeight := MaxInt;
      for I := 0 to FIconCount - 1 do
      begin
        PID := @FIconData[I];
        if FDisplayAll and FDisplayHorz then
        begin
          Inc(FMaxWidth, PID.Width);
          if I <> 0 then Inc(FMaxWidth, FSpacing);
        end else
          if PID.Width > FMaxWidth then FMaxWidth := PID.Width;
        if FDisplayAll and not FDisplayHorz then
        begin
          Inc(FMaxHeight, PID.Height);
          if I <> 0 then Inc(FMaxHeight, FSpacing);
        end else
          if PID.Height > FMaxHeight then FMaxHeight := PID.Height;
      end;
      if FOptimalIcon and (FIconCount >= 2) then
      begin
        FCurrentIndex := 0;
        BestBpp := FIconData[0].Bpp;
        for I := 0 to FIconCount - 1 do
        begin
          PID := @FIconData[I];
          if (PID.Bpp <= FBpp) and (PID.Bpp >= BestBpp) then
          begin
            BestBpp := PID.Bpp;
            dW := FRequestedSize.Width - PID.Width;
            dH := FRequestedSize.Height - PID.Height;
            if dW < 0 then DW := Round(-DW * FOverSizeWeight);
            if dH < 0 then dH := Round(-DH * FOverSizeWeight);
            Weight := dW + dH;
            if Weight <= MaxWeight then
            begin
              MaxWeight := Weight;
              FCurrentIndex := I;
            end;
          end;
        end;
      end  
      else if (FCurrentIndex < 0) or (FCurrentIndex >= FIconCount) then
        FCurrentIndex := 0;
    finally
      ReleaseDC(0, DC);
    end;
  end else
    FCurrentIndex := -1;
end;

procedure TKIcon.UpdateDim(Index: Integer; Value: TKIconDimension);

  procedure BitMove(const Src, Dest; BitSize, BitOffset: Integer);
  asm
    // eax: Src
    // ecx: BitSize
    // edx: Dest
    // stack: BitOffset
    // push registers that must be preserved
    push esi
    push edi
    push ebx
    // set registers for register adressing
    mov esi, eax
    mov edi, edx
    // test for scroll direction
    mov edx, BitOffset
    cmp edx, 0
    js @left
    // perform move
    mov ebx, edx
    shr ebx, 3
    add edi, ebx
    and edx, $07
    jnz @bitwise_right
    // bytewise move
    mov edx, ecx
    shr ecx, 3
    rep movsb
    and dl, $07
    jz @exit
    mov cl, dl
    mov al, [esi]
    rol eax, cl
    mov al, [edi]
    ror eax, cl
    mov [edi], al
    jmp @exit
  @bitwise_right:
    // bitwise move
    mov ebx, ecx
    mov cl, dl
    xor ch, ch
    mov dl, $7F
    ror dl, cl
    mov dh, dl
    not dh
  @R00:
    mov ah, [esi]
    ror ah, cl
    and ah, dh
    mov al, [edi]
    and al, dl
    or al, ah
    mov [edi], al
    dec ebx
    jz @exit
    inc ch
    and ch, $07
    jnz @R01
    inc esi
  @R01:
    ror dl, 1
    ror dh, 1
    test dh, $80
    jz @R00
    inc edi
    jmp @R00
  @left:
    // perform scroll
    neg edx
    mov ebx, edx
    shr ebx, 3
    add esi, ebx
    and edx, $07
    jnz @bitwise_left
    // bytewise move
    mov edx, ecx
    shr ecx, 3
    rep movsb
    and dl, $07
    jz @exit
    mov cl, dl
    mov al, [esi]
    rol eax, cl
    mov al, [edi]
    ror eax, cl
    mov [edi], al
    jmp @exit
  @bitwise_left:
    // bitwise move
    mov ebx, ecx
    mov cl, dl
    mov ch, cl
    mov dl, $7F
    mov dh, dl
    not dh
  @L00:
    mov ah, [esi]
    rol ah, cl
    and ah, dh
    mov al, [edi]
    and al, dl
    or al, ah
    mov [edi], al
    dec ebx
    jz @exit
    inc ch
    and ch, $07
    jnz @L01
    inc esi
  @L01:
    ror dl, 1
    ror dh, 1
    test dh, $80
    jz @L00
    inc edi
    jmp @L00
  @exit:
    // pop the preserved registers
    pop ebx
    pop edi
    pop esi
  end;

var
  BitOffset, J, Size, XOR1, XOR2, AND1, AND2,
  X, Y, HOffset, VOffset: Integer;
  PID: PKIconData;
  PBI: PBitmapInfoHeader;
  BIMask: TKMaskBitmapInfo;
  P: PByteArray;
  hBmp: HBITMAP;
  DC: HDC;
begin
  PID := @FIconData[Index];
  if PID.iXOR <> nil then
  begin
    PBI := PBitmapInfoHeader(PID.iXOR);
    P := nil;
    DC := GetDC(0);
    try
      try
        CalcByteWidths(PID.Width, PID.Bpp, XOR1, AND1);
        CalcByteWidths(Value.Width, PID.Bpp, XOR2, AND2);
        PBI.biWidth := Value.Width;
        PBI.biHeight := Value.Height;
        PBI.biSizeImage := XOR2 * Value.Height;
        if FAlignStyle = asCenter then
        begin
          HOffset := (Value.Width - PID.Width) div 2;
          VOffset := (Value.Height - PID.Height) div 2;
        end else
        begin
          HOffset := 0;
          VOffset := 0;
        end;
        Y := Min(PID.Height, Value.Height);
        BitOffset := HOffset * PID.Bpp;
        hBmp := GDICheck(CreateDIBSection(DC, PBitmapInfo(PBI)^, DIB_RGB_COLORS, Pointer(P), 0, 0));
        if P = nil then Error(SIconAllocationError);
        X := Min(PID.Width, Value.Width) * PID.Bpp;
        Size := XOR2 * Value.Height;
        FillChar(P^, Size, #0);
        for J := 1 to Y do
        begin
          if VOffset >= 0 then
            BitMove(PByteArray(PID.pXOR)[(PID.Height - J) * XOR1],
              P[(Value.Height - J - VOffset) * XOR2], X, BitOffset)
          else
            BitMove(PByteArray(PID.pXOR)[(PID.Height - J + VOffset) * XOR1],
              P[(Value.Height - J) * XOR2], X, BitOffset);
        end;
        DeleteObject(PID.hXOR);
        PID.pXOR := P;
        PID.pXORSize := Size;
        PID.hXOR := hBmp;
        CreateMaskInfo(PID.Width, PID.Height, BIMask);
        hBmp := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS, Pointer(P), 0, 0));
        if P = nil then Error(SIconAllocationError);
        X := Min(PID.Width, Value.Width);
        Size := AND2 * Value.Height;
        FillChar(P^, Size, #$FF);
        for J := 1 to Y do
        begin
          if VOffset >= 0 then
            BitMove(PByteArray(PID.pAND)[(PID.Height - J) * AND1],
              P[(Value.Height - J - VOffset) * AND2], X, HOffset)
          else
            BitMove(PByteArray(PID.pAND)[(PID.Height - J + VOffset) * AND1],
              P[(Value.Height - J) * AND2], X, HOffset);
        end;
        DeleteObject(PID.hAND);
        PID.pAND := P;
        PID.pANDSize := Size;
        PID.hAND := hBmp;
        PID.Width := Value.Width;
        PID.Height := Value.Height;
      except
        FreeSubimage(PID);
        Error(SIconResizingError);
      end;
    finally
      ReleaseDC(0, DC);
    end;
  end;
end;

procedure RegisterKIcon;
begin
  TPicture.UnregisterGraphicClass(Graphics.TIcon);
  TPicture.RegisterFileFormat('ico', SVIcons, KIcon.TIcon);
  TPicture.RegisterFileFormat('cur', SVCursors, KIcon.TIcon);
end;

procedure UnregisterKIcon;
begin
  TPicture.UnregisterGraphicClass(KIcon.TIcon);
  TPicture.RegisterFileFormat('ico', SVIcons, Graphics.TIcon);
end;

{$IFDEF TKICON_REGISTER}
initialization
  RegisterKIcon;
finalization
  //not necessary, but...
  UnregisterKIcon;
{$ENDIF}

{$ENDIF}
end.
