winscp/source/packages/png/PngImageList.pas

unit PngImageList;

{$IF RTLVersion < 15.0 }
This unit only compiles with Delphi 7 and higher!
{$IFEND}

interface

uses
  Windows, Classes, SysUtils, Controls, Graphics, ImgList,
  {$IF CompilerVersion >= 34.0 Delphi 10.4 }
  System.UITypes,
  {$ENDIF}
  PngImage, PngFunctions;

type
  INameMapping = interface
  ['{38EECDD8-7440-4EA2-BFD0-424E5BB2C1D5}']
    function GetName(Index: Integer): string;
    function IndexOfName(const AName: string): Integer;
    procedure ListNames(Target: TStrings);
    property Name[Index: Integer]: string read GetName;
  end;

type
  TPngImageCollection = class;
  TPngImageCollectionItem = class;
  TPngImageCollectionItems = class;

  TPngImageList = class(TImageList, INameMapping)
    function INameMapping.GetName = GetImageName;
    function INameMapping.IndexOfName = FindIndexByName;
    procedure INameMapping.ListNames = ListImageNames;
  private
    FEnabledImages: Boolean;
    FImageNameAvailable: Boolean;
    FLocked: Integer;
    FOverlayIndex: array[TOverlay] of Integer;
    FPngImages: TPngImageCollectionItems;
    FPngOptions: TPngOptions;
    function ExtractOverlayIndex(Style: Cardinal): Integer;
    function GetHeight: Integer;
    function GetImageName(Index: Integer): string;
    function GetWidth: Integer;
    procedure SetHeight(const Value: Integer);
    procedure SetPngOptions(const Value: TPngOptions);
    procedure SetWidth(const Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure CopyPngs; virtual;
    procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean = True); override;
    procedure InternalInsertPng(Index: Integer; const Png: TPngImage; Background:
        TColor = clNone);
    procedure InternalAddPng(const Png: TPngImage; Background: TColor = clNone);
    function PngToIcon(const Png: TPngImage; Background: TColor = clNone): HICON;
    procedure ReadData(Stream: TStream); override;
    procedure SetEnabledImages(const Value: Boolean); virtual;
    procedure SetPngImages(const Value: TPngImageCollectionItems); virtual;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //Patched methods
    function Add(Image, Mask: TBitmap): Integer; virtual;
    function AddIcon(Image: TIcon): Integer; virtual;
    function AddPng(Image: TPngImage; Background: TColor = clNone): Integer;
    function AddImage(Value: TCustomImageList; Index: Integer): Integer; virtual;
    procedure AddImages(Value: TCustomImageList); virtual;
    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer; virtual;
    {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
    function AddDisabledImage(Value: TCustomImageList; Index: Integer): Integer; virtual;
    procedure AddDisabledImages(Value: TCustomImageList); virtual;
    {$ENDIF}
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure Clear; virtual;
    procedure Delete(Index: Integer); virtual;
    procedure EndUpdate(Update: Boolean = True);
    function FindIndexByName(const AName: string): Integer;
    procedure Insert(Index: Integer; Image, Mask: TBitmap); virtual;
    procedure InsertIcon(Index: Integer; Image: TIcon); virtual;
    procedure InsertPng(Index: Integer; Image: TPngImage; Background: TColor = clNone);
    procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor); virtual;
    procedure ListImageNames(Target: TStrings);
    procedure Move(CurIndex, NewIndex: Integer); virtual;
    function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
    procedure Replace(Index: Integer; Image, Mask: TBitmap); virtual;
    procedure ReplaceIcon(Index: Integer; Image: TIcon); virtual;
    procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor); virtual;
    {$IF CompilerVersion >= 34.0 Delphi 10.4 }
    function IsImageNameAvailable: Boolean; override;
    function GetIndexByName(const AName: TImageName): TImageIndex; override;
    function GetNameByIndex(AIndex: TImageIndex): TImageName; override;
    {$ENDIF}
    property ImageName[Index: Integer]: string read GetImageName;
  published
    property ColorDepth default cd32Bit;
    property EnabledImages: Boolean read FEnabledImages write SetEnabledImages default True;
    property Height read GetHeight write SetHeight default 16;
    property ImageNameAvailable: Boolean read FImageNameAvailable write FImageNameAvailable default False;
    property PngImages: TPngImageCollectionItems read FPngImages write SetPngImages;
    property PngOptions: TPngOptions read FPngOptions write SetPngOptions default [pngBlendOnDisabled];
    property Width read GetWidth write SetWidth default 16;
  end;

  TPngImageCollection = class(TComponent)
  private
    FItems: TPngImageCollectionItems;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Items: TPngImageCollectionItems read FItems write FItems;
  end;

  TPngImageCollectionItems = class(TCollection)
  private
    FOwner: TPersistent;
    function GetItem(Index: Integer): TPngImageCollectionItem;
    procedure SetItem(Index: Integer; const Value: TPngImageCollectionItem);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TPersistent);
    function Add(DontCreatePNG: Boolean = False): TPngImageCollectionItem; reintroduce;
    procedure Assign(Source: TPersistent); override;
    function Insert(Index: Integer; DontCreatePNG: Boolean = False): TPngImageCollectionItem; reintroduce;
    property Items[index: Integer]: TPngImageCollectionItem read GetItem write SetItem; default;
  end;

  TPngImageCollectionItem = class(TCollectionItem)
  private
    FBackground: TColor;
    FName: string;
    FPngImage: TPngImage;
    procedure SetBackground(const Value: TColor);
    procedure SetPngImage(const Value: TPngImage);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); overload; override;
    constructor Create(Collection: TCollection; DontCreatePNG: Boolean = False); reintroduce; overload;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Duplicate: TPngImage;
  published
    property Background: TColor read FBackground write SetBackground default clBtnFace;
    property Name: string read FName write FName;
    property PngImage: TPngImage read FPngImage write SetPngImage;
  end;

procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);

implementation

uses
  Math, Contnrs, CommCtrl, ComCtrls;

var
  ImageListCount: Integer = 0;
  MethodPatches: TObjectList = nil;

type
  TMethodPatch = class
  private
    Name: string;
    OldBody: packed array[0..4] of Byte;
    OldPointer: Pointer;
    NewPointer: Pointer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginInvokeOldMethod;
    procedure FinishInvokeOldMethod;
    function PatchBack: Boolean;
  end;

{ Global }

function FindMethodPatch(const Name: string): TMethodPatch;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to MethodPatches.Count - 1 do begin
    if TMethodPatch(MethodPatches[I]).Name = Name then begin
      Result := TMethodPatch(MethodPatches[I]);
      Break;
    end;
  end;
end;

{$IF RTLVersion > 18.0 }
{$POINTERMATH ON}
{$IFEND}
function PatchPtr(OldPtr, NewPtr: Pointer; const Name: string; Patch: TMethodPatch): Boolean;
var
  Access: Cardinal;
  memSize: Integer;
  opCode: PByte;
  operand: PInteger;
begin
  Result := False;
  Patch.Name := Name;
  if OldPtr <> NewPtr then begin
    Patch.OldPointer := OldPtr;
    Patch.NewPointer := NewPtr;
    opCode := OldPtr;
    operand := OldPtr;
    Inc(PByte(operand));
    memSize := SizeOf(Patch.OldBody);
    Move(opCode^, Patch.OldBody[0], memSize);
    if VirtualProtect(OldPtr, 16, PAGE_EXECUTE_READWRITE, @Access) then begin
      opCode^ := $E9; // Near jump
      {$IF RTLVersion > 18.0 }
      operand^ := PByte(NewPtr) - PByte(OldPtr) - 5;
      {$ELSE}
      operand^ := PChar(NewPtr) - PChar(OldPtr) - 5;
      {$IFEND}
      VirtualProtect(OldPtr, 16, Access, @Access);
//      {$IF not (defined(CPU386) or defined(CPUX86) or defined(CPUX64)) }
//      FlushInstructionCache(GetCurrentProcess, OldPtr, memSize);
//      {$IFEND}
      Result := True;
    end;
  end;
  if not Result then
    Patch.OldPointer := nil;
end;
{$IF RTLVersion > 18.0 }
{$POINTERMATH OFF}
{$IFEND}

procedure ApplyMethodPatches;
type
  TPointerCombo = record
    OldPtr: Pointer;
    NewPtr: Pointer;
    Name: string;
  end;

  function Combo(const OldPtr, NewPtr: Pointer; const Name: string): TPointerCombo;
  begin
    Result.OldPtr := OldPtr;
    Result.NewPtr := NewPtr;
    Result.Name := Name;
  end;

const
  EmptyCombo: TPointerCombo = (OldPtr: nil; NewPtr: nil; Name: '');
var
  Pointers: array of TPointerCombo;
  Patch: TMethodPatch;
  I: Integer;
begin
  if ImageListCount = 0 then begin
    {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
    SetLength(Pointers, 17);
    {$ELSE}
    SetLength(Pointers, 15);
    {$ENDIF}
    Pointers[0] := Combo(@TCustomImageList.Add, @TPngImageList.Add, 'Add');
    Pointers[1] := Combo(@TCustomImageList.AddIcon, @TPngImageList.AddIcon, 'AddIcon');
    Pointers[2] := Combo(@TCustomImageList.AddImage, @TPngImageList.AddImage, 'AddImage');
    Pointers[3] := Combo(@TCustomImageList.AddImages, @TPngImageList.AddImages, 'AddImages');
    Pointers[4] := Combo(@TCustomImageList.AddMasked, @TPngImageList.AddMasked, 'AddMasked');
    Pointers[5] := Combo(@TCustomImageList.Clear, @TPngImageList.Clear, 'Clear');
    Pointers[6] := Combo(@TCustomImageList.Delete, @TPngImageList.Delete, 'Delete');
    Pointers[7] := Combo(@TCustomImageList.Insert, @TPngImageList.Insert, 'Insert');
    Pointers[8] := Combo(@TCustomImageList.InsertIcon, @TPngImageList.InsertIcon, 'InsertIcon');
    Pointers[9] := Combo(@TCustomImageList.InsertMasked, @TPngImageList.InsertMasked, 'InsertMasked');
    Pointers[10] := Combo(@TCustomImageList.Move, @TPngImageList.Move, 'Move');
    Pointers[11] := Combo(@TCustomImageList.Replace, @TPngImageList.Replace, 'Replace');
    Pointers[12] := Combo(@TCustomImageList.ReplaceIcon, @TPngImageList.ReplaceIcon, 'ReplaceIcon');
    Pointers[13] := Combo(@TCustomImageList.ReplaceMasked, @TPngImageList.ReplaceMasked, 'ReplaceMasked');
    Pointers[14] := Combo(@TCustomImageList.Overlay, @TPngImageList.Overlay, 'Overlay');
    {$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
    Pointers[15] := Combo(@TCustomImageList.AddDisabledImage, @TPngImageList.AddDisabledImage, 'AddDisabledImage');
    Pointers[16] := Combo(@TCustomImageList.AddDisabledImages, @TPngImageList.AddDisabledImages, 'AddDisabledImages');
    {$ENDIF}

    MethodPatches := TObjectList.Create;
    for I := Low(Pointers) to High(Pointers) do begin
      if Pointers[I].OldPtr <> nil then begin
        Patch := TMethodPatch.Create;
        if PatchPtr(Pointers[I].OldPtr, Pointers[I].NewPtr, Pointers[I].Name, Patch) then
          MethodPatches.Add(Patch)
        else
          Patch.Free;
      end;
    end;
  end;
end;

procedure RevertPatchedMethods;
begin
  if ImageListCount = 0 then
    FreeAndNil(MethodPatches);
end;

procedure CopyImageFromImageList(Dest: TPngImage; ImageList: TCustomImageList; Index: Integer);
var
  Icon: TIcon;
  IconInfo: TIconInfo;
  ColorBitmap, MaskBitmap: TBitmap;
  X, Y: Integer;
  AlphaLine: pngimage.PByteArray;
  Png: TPngImageCollectionItem;
begin
  if ImageList is TPngImageList then begin
    //This is easy, just copy the PNG object from the imagelist to the PNG object
    //from the button
    Png := TPNGImageList(ImageList).PngImages[Index];
    if Png <> nil then
      Dest.Assign(Png.PngImage);
  end
  else begin
    Icon := TIcon.Create;
    ColorBitmap := TBitmap.Create;
    MaskBitmap := TBitmap.Create;
    try
      //Try to copy an icon to a PNG object, including transparency
      ImageList.GetIcon(Index, Icon);
      if GetIconInfo(Icon.Handle, IconInfo) then begin
        //First, pump the colors into the PNG object
        ColorBitmap.Handle := IconInfo.hbmColor;
        ColorBitmap.PixelFormat := pf24bit;
        Dest.Assign(ColorBitmap);

        //Finally, copy the transparency
        Dest.CreateAlpha;
        MaskBitmap.Handle := IconInfo.hbmMask;
        for Y := 0 to Dest.Height - 1 do begin
          AlphaLine := Dest.AlphaScanline[Y];
          for X := 0 to Dest.Width - 1 do
            AlphaLine^[X] := Integer(GetPixel(MaskBitmap.Canvas.Handle, X, Y) = COLORREF(clBlack)) * $FF;
        end;
      end;
    finally
      MaskBitmap.Free;
      ColorBitmap.Free;
      Icon.Free;
    end;
  end;
end;

{ TMethodPatch }

constructor TMethodPatch.Create;
begin
  inherited Create;
  OldPointer := nil;
end;

destructor TMethodPatch.Destroy;
begin
  if OldPointer <> nil then
    PatchBack;
  inherited Destroy;
end;

procedure TMethodPatch.BeginInvokeOldMethod;
begin
  PatchBack;
end;

procedure TMethodPatch.FinishInvokeOldMethod;
begin
  PatchPtr(OldPointer, NewPointer, Name, Self);
end;

function TMethodPatch.PatchBack: Boolean;
var
  Access: Cardinal;
begin
  Result := False;
  if VirtualProtect(OldPointer, 16, PAGE_EXECUTE_READWRITE, @Access) then begin
    Move(OldBody[0], OldPointer^, SizeOf(OldBody));
    VirtualProtect(OldPointer, 16, Access, @Access);
    Result := True;
  end;
end;

constructor TPngImageList.Create(AOwner: TComponent);
var
  I: Integer;
begin
  for I := Low(FOverlayIndex) to High(FOverlayIndex) do begin
    FOverlayIndex[I] := -1;
  end;
  inherited Create(AOwner);
  {$IF CompilerVersion >= 33.0 Delphi 10.3 Rio }
  StoreBitmap := False;
  {$ENDIF}
  FImageNameAvailable := False;
  ColorDepth := cd32Bit;
  if ImageListCount = 0 then
    ApplyMethodPatches;
  Inc(ImageListCount);
  FEnabledImages := True;
  FPngOptions := [pngBlendOnDisabled];
  FPngImages := TPngImageCollectionItems.Create(Self);
  FLocked := 0;
end;

destructor TPngImageList.Destroy;
begin
  FPngImages.Free;
  Dec(ImageListCount);
  if ImageListCount = 0 then
    RevertPatchedMethods;
  inherited Destroy;
end;

//--- Patched methods ---

function TPngImageList.Add(Image, Mask: TBitmap): Integer;
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    Png := TPngImage.Create;
    try
      CreatePNG(Image, Mask, Png);
      result := AddPng(Png);
    finally
      Png.Free;
    end;
  end
  else begin
    Patch := FindMethodPatch('Add');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        Result := TCustomImageList(Self).Add(Image, Mask);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end
    else
      Result := -1;
  end;
end;

function TPngImageList.AddIcon(Image: TIcon): Integer;
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    Png := TPngImage.Create;
    try
      ConvertToPNG(Image, Png);
      result := AddPng(Png);
    finally
      Png.Free;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddIcon');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        Result := TCustomImageList(Self).AddIcon(Image);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end
    else
      Result := -1;
  end;
end;

function TPngImageList.AddPng(Image: TPngImage; Background: TColor = clNone):
    Integer;
var
  Item: TPngImageCollectionItem;
begin
  Result := -1;
  if Image = nil then Exit;

  BeginUpdate;
  try
    Item := FPngImages.Add(True);
    Item.PngImage := Image;
    Item.Background := Background;
    Result := Item.Index;
    InternalAddPng(Item.PngImage, Item.Background);
    Change;
  finally
    EndUpdate(false);
  end;
end;

function TPngImageList.AddImage(Value: TCustomImageList; Index: Integer): Integer;
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    Png := TPngImage.Create;
    try
      CopyImageFromImageList(Png, Value, Index);
      if RTLVersion < 31.00 then begin
        result := AddPng(Png);
      end
      else begin
        { Since Berlin AddImage returns the new size of the list, while before it returned the index of the added image.
          Although this behaviour seems somewhat strange, it actually matches the documentation. }
        AddPng(Png);
        result := FPngImages.Count;
      end;
    finally
      Png.Free;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddImage');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        Result := TCustomImageList(Self).AddImage(Value, Index);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end
    else
      Result := -1;
  end;
end;

procedure TPngImageList.AddImages(Value: TCustomImageList);
var
  Patch: TMethodPatch;
  I: Integer;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    BeginUpdate;
    try
      //Copy every image from Value into this imagelist.
      Png := TPngImage.Create;
      try
        for I := 0 to Value.Count - 1 do begin
          CopyImageFromImageList(Png, Value, I);
          AddPng(Png);
        end;
      finally
        Png.Free;
      end;
    finally
      EndUpdate;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddImages');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).AddImages(Value);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

{$IF CompilerVersion >= 34.0 Delphi 10.4 Sydney }
function TPngImageList.AddDisabledImage(Value: TCustomImageList; Index: Integer): Integer;
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    Png := TPngImage.Create;
    try
      CopyImageFromImageList(Png, Value, Index);
      MakeDisabledImage(Png, PngOptions);
      AddPng(Png);
      result := FPngImages.Count;
    finally
      Png.Free;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddDisabledImage');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        Result := TCustomImageList(Self).AddDisabledImage(Value, Index);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end
    else
      Result := -1;
  end;
end;

procedure TPngImageList.AddDisabledImages(Value: TCustomImageList);
var
  Patch: TMethodPatch;
  I: Integer;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    BeginUpdate;
    try
      //Copy every image from Value into this imagelist.
      Png := TPngImage.Create;
      try
        for I := 0 to Value.Count - 1 do begin
          CopyImageFromImageList(Png, Value, I);
          MakeDisabledImage(Png, PngOptions);
          AddPng(Png);
        end;
      finally
        Png.Free;
      end;
    finally
      EndUpdate;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddDisabledImages');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).AddDisabledImages(Value);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;
{$ENDIF}

function TPngImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    Png := TPngImage.Create;
    try
      CreatePNGMasked(Image, MaskColor, Png);
      result := AddPng(Png);
    finally
      Png.Free;
    end;
  end
  else begin
    Patch := FindMethodPatch('AddMasked');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        Result := TCustomImageList(Self).AddMasked(Image, MaskColor);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end
    else
      Result := -1;
  end;
end;

procedure TPngImageList.Assign(Source: TPersistent);
var
  pngSource: TPngImageList;
begin
  if Source is TPngImageList then begin
    pngSource := TPngImageList(Source);
    BeginUpdate;
    try
      PngImages := pngSource.PngImages;
      EnabledImages := pngSource.EnabledImages;
      PngOptions := pngSource.PngOptions;
    finally
      EndUpdate(true);
    end;
  end;

  if Source is TCustomImageList then begin
    ColorDepth := TCustomImageList(Source).ColorDepth;
  end;

  inherited;
end;

procedure TPngImageList.AssignTo(Dest: TPersistent);
var
  pngDest: TPngImageList;
begin
  inherited;
  if Dest is TPngImageList then begin
    pngDest := TPngImageList(Dest);
    pngDest.PngImages := PngImages;
    pngDest.EnabledImages := EnabledImages;
    pngDest.PngOptions := PngOptions;
  end;
end;

procedure TPngImageList.BeginUpdate;
begin
  Inc(FLocked);
end;

procedure TPngImageList.Clear;
var
  Patch: TMethodPatch;
begin
  if TObject(Self) is TPngImageList then begin
    //Clear the PngImages collection and the internal imagelist.
    BeginUpdate;
    try
      FPngImages.Clear;
      ImageList_Remove(Handle, -1);
      Change;
    finally
      EndUpdate(False);
    end;
  end
  else begin
    Patch := FindMethodPatch('Clear');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).Clear;
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.CopyPngs;
var
  I: Integer;
  Png: TPngImage;
  Icon: HIcon;
  item: TPngImageCollectionItem;
begin
  //Are we adding a bunch of images?
  if FLocked > 0 then
    Exit;

  //Copy PNG images to the imagelist. These images will not be stored in the DFM.
  ImageList_Remove(Handle, -1);
  Handle := ImageList_Create(Width, Height, ILC_COLOR32 or (Integer(Masked) *
    ILC_MASK), 0, AllocBy);

  Png := TPngImage.Create;
  try
    for I := 0 to FPngImages.Count - 1 do begin
      item := FPngImages.Items[I];
      if (item.PngImage = nil) or item.PngImage.Empty then
        Continue;
      if FEnabledImages or (FPngOptions = []) then begin
        Icon := PngToIcon(item.PngImage, item.Background);
      end
      else begin
        //Basically the same as in the DrawPNG function
        Png.Assign(item.PngImage);
        MakeDisabledImage(Png, PngOptions);
        Icon := PngToIcon(Png);
      end;
      ImageList_AddIcon(Handle, Icon);
      DestroyIcon(Icon);
    end;
  finally
    Png.Free;
  end;
end;

procedure TPngImageList.Delete(Index: Integer);
var
  Patch: TMethodPatch;
begin
  if TObject(Self) is TPngImageList then begin
    //Delete an image from the PngImages collection and from the internal imagelist.
    if (Index >= 0) and (Index < Count) then begin
      BeginUpdate;
      try
        FPngImages.Delete(Index);
        ImageList_Remove(Handle, Index);
        Change;
      finally
        EndUpdate(False);
      end;
    end;
  end
  else begin
    Patch := FindMethodPatch('Delete');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).Delete(Index);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

//--- End of patched methods ---

procedure TPngImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
var
  PaintRect: TRect;
  Options: TPngOptions;
  IndexOfOverlay: Integer;
  Png: TPngImageCollectionItem;
begin
  //Draw a PNG directly to the Canvas. This is the preferred method to call,
  //because this omits the API calls that use a fixed background.
  PaintRect := Bounds(X, Y, Width, Height);
  if Enabled then
    Options := []
  else
    Options := FPngOptions;
  Png := FPngImages.Items[Index];
  if Png <> nil then begin
    DrawPNG(Png.PngImage, Canvas, PaintRect, Options);
    IndexOfOverlay := ExtractOverlayIndex(Style);
    if (IndexOfOverlay >= 0) and (IndexOfOverlay < Count) then begin
      Png := PngImages.Items[IndexOfOverlay];
      if Png <> nil then begin
        DrawPNG(Png.PngImage, Canvas, PaintRect, Options);
      end;
    end;
  end;
end;

procedure TPngImageList.EndUpdate(Update: Boolean);
begin
  Dec(FLocked);
  if Update and (FLocked = 0) then
    CopyPngs;
end;

function TPngImageList.ExtractOverlayIndex(Style: Cardinal): Integer;
var
  idx: Cardinal;
begin
  Result := -1;
  idx := Style and ILD_OVERLAYMASK;
  if idx > 0 then begin
    idx := idx shr 8;
    if (idx > 0) then begin
      Dec(idx);
      {$WARN COMPARISON_TRUE OFF }
      if (idx >= Low(FOverlayIndex)) and (idx <= High(FOverlayIndex)) then begin
        Result := FOverlayIndex[idx];
      end;
      {$WARN COMPARISON_TRUE DEFAULT }
    end;
  end;
end;

function TPngImageList.FindIndexByName(const AName: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to PngImages.Count - 1 do begin
    if SameText(PngImages[I].Name, AName) then begin
      Result := I;
      Break;
    end;
  end;
end;

function TPngImageList.GetHeight: Integer;
begin
  Result := inherited Height;
end;

function TPngImageList.GetImageName(Index: Integer): string;
var
  item: TPngImageCollectionItem;
begin
  Result := '';
  item := PngImages[Index];
  if item <> nil then
    Result := item.Name;
end;

{$IF CompilerVersion >= 34.0 Delphi 10.4 }
function TPngImageList.IsImageNameAvailable: Boolean;
begin
  Result := FImageNameAvailable;
end;

function TPngImageList.GetIndexByName(const AName: TImageName): TImageIndex;
begin
  Result := FindIndexByName(AName);
end;

function TPngImageList.GetNameByIndex(AIndex: TImageIndex): TImageName;
begin
  Result := ImageName[AIndex];
end;
{$ENDIF}

function TPngImageList.GetWidth: Integer;
begin
  Result := inherited Width;
end;

procedure TPngImageList.Insert(Index: Integer; Image, Mask: TBitmap);
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    //Insert a new PNG based on the image and its mask.
    if Image <> nil then begin
      Png := TPngImage.Create;
      try
        CreatePNG(Image, Mask, Png);
        InsertPng(Index, Png);
      finally
        Png.Free;
      end;
    end;
  end
  else begin
    Patch := FindMethodPatch('Insert');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).Insert(Index, Image, Mask);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.InsertIcon(Index: Integer; Image: TIcon);
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    //Insert a new PNG based on the image.
    if Image <> nil then begin
      Png := TPngImage.Create;
      try
        ConvertToPNG(Image, Png);
        InsertPng(Index, Png);
      finally
        Png.Free;
      end;
    end;
  end
  else begin
    Patch := FindMethodPatch('InsertIcon');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).InsertIcon(Index, Image);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.InsertPng(Index: Integer; Image: TPngImage; Background:
    TColor = clNone);
var
  Item: TPngImageCollectionItem;
begin
  if Image <> nil then begin
    BeginUpdate;
    try
      Item := PngImages.Insert(Index, True);
      Item.PngImage := Image;
      Item.Background := Background;
      InternalInsertPng(Index, Item.PngImage, Item.Background);
      Change;
    finally
      EndUpdate(False);
    end;
  end;
end;

procedure TPngImageList.InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
var
  Patch: TMethodPatch;
  Png: TPngImage;
begin
  if TObject(Self) is TPngImageList then begin
    //Insert a new PNG based on the image and a colored mask.
    if Image <> nil then begin
      Png := TPngImage.Create;
      try
        CreatePNGMasked(Image, MaskColor, Png);
        InsertPng(Index, Png);
      finally
        Png.Free;
      end;
    end;
  end
  else begin
    Patch := FindMethodPatch('InsertMasked');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).InsertMasked(Index, Image, MaskColor);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.InternalInsertPng(Index: Integer; const Png: TPngImage;
    Background: TColor);
var
  I: Integer;
  Icon: HICON;
  TempList: TPngImageList;
begin
  TempList := TPngImageList(TComponentClass(ClassType).Create(nil));
  try
    TempList.Assign(Self);
    ImageList_RemoveAll(Handle);
    for I := 0 to Index - 1 do begin
      Icon := ImageList_GetIcon(TempList.Handle, I, ILD_NORMAL);
      ImageList_AddIcon(Handle, Icon);
      DestroyIcon(Icon);
    end;
    Icon := PngToIcon(Png, Background);
    ImageList_AddIcon(Handle, Icon);
    DestroyIcon(Icon);
    for I := Index to TempList.Count - 1 do begin
      Icon := ImageList_GetIcon(TempList.Handle, I, ILD_NORMAL);
      ImageList_AddIcon(Handle, Icon);
      DestroyIcon(Icon);
    end;
  finally
    TempList.Free;
  end;
end;

procedure TPngImageList.InternalAddPng(const Png: TPngImage; Background: TColor
    = clNone);
var
  Icon: HICON;
begin
  Icon := PngToIcon(Png, Background);
  try
    ImageList_AddIcon(Handle, Icon);
  finally
    DestroyIcon(Icon);
  end;
end;

procedure TPngImageList.ListImageNames(Target: TStrings);
var
  I: Integer;
begin
  for I := 0 to PngImages.Count - 1 do begin
    Target.Add(PngImages[I].Name);
  end;
end;

procedure TPngImageList.Move(CurIndex, NewIndex: Integer);
var
  Patch: TMethodPatch;
begin
  if TObject(Self) is TPngImageList then begin
    //Move an image from one position to another. Don't try doing so in the internal
    //imagelist, just recreate it, since this method won't be called very often.
    BeginUpdate;
    try
      ImageList_Remove(Handle, CurIndex);
      InternalInsertPng(NewIndex, FPngImages[CurIndex].PngImage,
        FPngImages[CurIndex].Background);
      FPngImages[CurIndex].Index := NewIndex;
      Change;
    finally
      EndUpdate(False);
    end;
  end
  else begin
    Patch := FindMethodPatch('Move');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).Move(CurIndex, NewIndex);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

function TPngImageList.Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
begin
  Result := (ImageIndex >= 0) and (ImageIndex < Count);
  FOverlayIndex[Overlay] := ImageIndex;
end;

function TPngImageList.PngToIcon(const Png: TPngImage; Background: TColor): HICON;
const
  MaxRGBQuads = MaxInt div SizeOf(TRGBQuad) - 1;
type
  TRGBQuadArray = array[0..MaxRGBQuads] of TRGBQuad;
  PRGBQuadArray = ^TRGBQuadArray;
  TBitmapInfo4 = packed record
    bmiHeader: TBitmapV4Header;
    bmiColors: array[0..0] of TRGBQuad;
  end;

  function PngToIcon32(Png: TPngImage): HIcon;
  var
    ImageBits: PRGBQuadArray;
    BitmapInfo: TBitmapInfo4;
    IconInfo: TIconInfo;
    AlphaBitmap: HBitmap;
    MaskBitmap: TBitmap;
    X, Y: Integer;
    AlphaLine: PByteArray;
    HasAlpha, HasBitmask: Boolean;
    Color, TransparencyColor: TColor;
  begin
    //Convert a PNG object to an alpha-blended icon resource
    ImageBits := nil;

    //Allocate a DIB for the color data and alpha channel
    with BitmapInfo.bmiHeader do begin
      bV4Size := SizeOf(BitmapInfo.bmiHeader);
      bV4Width := Png.Width;
      bV4Height := Png.Height;
      bV4Planes := 1;
      bV4BitCount := 32;
      bV4V4Compression := BI_BITFIELDS;
      bV4SizeImage := 0;
      bV4XPelsPerMeter := 0;
      bV4YPelsPerMeter := 0;
      bV4ClrUsed := 0;
      bV4ClrImportant := 0;
      bV4RedMask := $00FF0000;
      bV4GreenMask := $0000FF00;
      bV4BlueMask := $000000FF;
      bV4AlphaMask := $FF000000;
    end;
    AlphaBitmap := CreateDIBSection(0, PBitmapInfo(@BitmapInfo)^,
      DIB_RGB_COLORS, Pointer(ImageBits), 0, 0);
    try
      //Spin through and fill it with a wash of color and alpha.
      AlphaLine := nil;
      HasAlpha := Png.Header.ColorType in [COLOR_GRAYSCALEALPHA,
        COLOR_RGBALPHA];
      HasBitmask := Png.TransparencyMode = ptmBit;
      TransparencyColor := Png.TransparentColor;
      for Y := 0 to Png.Height - 1 do begin
        if HasAlpha then
          AlphaLine := Png.AlphaScanline[Png.Height - Y - 1];
        for X := 0 to Png.Width - 1 do begin
          Color := Png.Pixels[X, Png.Height - Y - 1];
          ImageBits^[Y * Png.Width + X].rgbRed := Color and $FF;
          ImageBits^[Y * Png.Width + X].rgbGreen := Color shr 8 and $FF;
          ImageBits^[Y * Png.Width + X].rgbBlue := Color shr 16 and $FF;
          if HasAlpha then
            ImageBits^[Y * Png.Width + X].rgbReserved := AlphaLine^[X]
          else if HasBitmask then
            ImageBits^[Y * Png.Width + X].rgbReserved := Integer(Color <>
              TransparencyColor) * 255;
        end;
      end;

      //Create an empty mask
      MaskBitmap := TBitmap.Create;
      try
        MaskBitmap.Width := Png.Width;
        MaskBitmap.Height := Png.Height;
        MaskBitmap.PixelFormat := pf1bit;
        MaskBitmap.Canvas.Brush.Color := clBlack;
        MaskBitmap.Canvas.FillRect(Rect(0, 0, MaskBitmap.Width,
          MaskBitmap.Height));

        //Create the alpha blended icon
        IconInfo.fIcon := True;
        IconInfo.hbmColor := AlphaBitmap;
        IconInfo.hbmMask := MaskBitmap.Handle;
        Result := CreateIconIndirect(IconInfo);
      finally
        MaskBitmap.Free;
      end;
    finally
      DeleteObject(AlphaBitmap);
    end;
  end;

  function PngToIcon24(Png: TPngImage; Background: TColor): HIcon;
  var
    ColorBitmap, MaskBitmap: TBitmap;
    X, Y: Integer;
    AlphaLine: PByteArray;
    IconInfo: TIconInfo;
    TransparencyColor: TColor;
  begin
    ColorBitmap := TBitmap.Create;
    MaskBitmap := TBitmap.Create;
    try
      ColorBitmap.Width := Png.Width;
      ColorBitmap.Height := Png.Height;
      ColorBitmap.PixelFormat := pf32bit;
      MaskBitmap.Width := Png.Width;
      MaskBitmap.Height := Png.Height;
      MaskBitmap.PixelFormat := pf32bit;

      //Draw the color bitmap
      ColorBitmap.Canvas.Brush.Color := Background;
      ColorBitmap.Canvas.FillRect(Rect(0, 0, Png.Width, Png.Height));
      Png.Draw(ColorBitmap.Canvas, Rect(0, 0, Png.Width, Png.Height));

      //Create the mask bitmap
      if Png.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then
        for Y := 0 to Png.Height - 1 do begin
          AlphaLine := Png.AlphaScanline[Y];
          for X := 0 to Png.Width - 1 do
            if AlphaLine^[X] = 0 then
              SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clWhite)
            else
              SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clBlack);
        end
      else if Png.TransparencyMode = ptmBit then begin
        TransparencyColor := Png.TransparentColor;
        for Y := 0 to Png.Height - 1 do
          for X := 0 to Png.Width - 1 do
            if Png.Pixels[X, Y] = TransparencyColor then
              SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clWhite)
            else
              SetPixelV(MaskBitmap.Canvas.Handle, X, Y, clBlack);
      end;

      //Create the icon
      IconInfo.fIcon := True;
      IconInfo.hbmColor := ColorBitmap.Handle;
      IconInfo.hbmMask := MaskBitmap.Handle;
      Result := CreateIconIndirect(IconInfo);
    finally
      ColorBitmap.Free;
      MaskBitmap.Free;
    end;
  end;

begin
  if GetComCtlVersion >= ComCtlVersionIE6 then begin
    //Windows XP or later, using the modern method: convert every PNG to
    //an icon resource with alpha channel
    Result := PngToIcon32(Png);
  end
  else begin
    //No Windows XP, using the legacy method: copy every PNG to a normal
    //bitmap using a fixed background color
    Result := PngToIcon24(Png, Background);
  end;
end;

procedure TPngImageList.ReadData(Stream: TStream);
begin
  if not (csReading in ComponentState) then
    inherited;
  //Make sure nothing gets read from the DFM
end;

procedure TPngImageList.Replace(Index: Integer; Image, Mask: TBitmap);
var
  Item: TPngImageCollectionItem;
  Patch: TMethodPatch;
  Icon: HICON;
begin
  if TObject(Self) is TPngImageList then begin
    //Replace an existing PNG based with a new image and its mask.
    if Image <> nil then begin
      BeginUpdate;
      try
        Item := FPngImages[Index];
        CreatePNG(Image, Mask, Item.PngImage);
        Icon := PngToIcon(Item.PngImage, Item.Background);
        ImageList_ReplaceIcon(Handle, Index, Icon);
        DestroyIcon(Icon);
        Change;
      finally
        EndUpdate(False);
      end;
    end;
  end
  else begin
    Patch := FindMethodPatch('Replace');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).Replace(Index, Image, Mask);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.ReplaceIcon(Index: Integer; Image: TIcon);
var
  Item: TPngImageCollectionItem;
  Patch: TMethodPatch;
  Icon: HICON;
begin
  if TObject(Self) is TPngImageList then begin
    //Replace an existing PNG based with a new image.
    if Image <> nil then begin
      BeginUpdate;
      try
        Item := FPngImages[Index];
        ConvertToPNG(Image, Item.PngImage);
        Icon := PngToIcon(Item.PngImage, Item.Background);
        ImageList_ReplaceIcon(Handle, Index, Icon);
        DestroyIcon(Icon);
        Change;
      finally
        EndUpdate(False);
      end;
    end
  end
  else begin
    Patch := FindMethodPatch('ReplaceIcon');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).ReplaceIcon(Index, Image);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
var
  Item: TPngImageCollectionItem;
  Patch: TMethodPatch;
  Icon: HICON;
begin
  if TObject(Self) is TPngImageList then begin
    //Replace an existing PNG based with a new image and a colored mask.
    if NewImage <> nil then begin
      BeginUpdate;
      try
        Item := FPngImages[Index];
        CreatePNGMasked(NewImage, MaskColor, Item.PngImage);
        Icon := PngToIcon(Item.PngImage, Item.Background);
        ImageList_ReplaceIcon(Handle, Index, Icon);
        DestroyIcon(Icon);
        Change;
      finally
        EndUpdate(False);
      end;
    end
  end
  else begin
    Patch := FindMethodPatch('ReplaceMasked');
    if Patch <> nil then begin
      Patch.BeginInvokeOldMethod;
      try
        TCustomImageList(Self).ReplaceMasked(Index, NewImage, MaskColor);
      finally
        Patch.FinishInvokeOldMethod;
      end;
    end;
  end;
end;

procedure TPngImageList.SetEnabledImages(const Value: Boolean);
begin
  if FEnabledImages xor Value then begin
    FEnabledImages := Value;
    CopyPngs;
  end;
end;

procedure TPngImageList.SetHeight(const Value: Integer);
begin
  if inherited Height <> Value then begin
    inherited Height := Value;
    Clear;
  end;
end;

procedure TPngImageList.SetPngImages(const Value: TPngImageCollectionItems);
begin
  if FPngImages <> Value then begin
    FPngImages.Assign(Value);
    Change;
  end;
end;

procedure TPngImageList.SetPngOptions(const Value: TPngOptions);
begin
  if FPngOptions <> Value then begin
    FPngOptions := Value;
    CopyPngs;
  end;
end;

procedure TPngImageList.SetWidth(const Value: Integer);
begin
  if inherited Width <> Value then begin
    inherited Width := Value;
    Clear;
  end;
end;

procedure TPngImageList.WriteData(Stream: TStream);
begin
  if not (csWriting in ComponentState) then
    inherited;
  //Make sure nothing gets written to the DFM
end;

{ TPngImageCollection }

constructor TPngImageCollection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FItems := TPngImageCollectionItems.Create(Self);
end;

destructor TPngImageCollection.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

{ TPngImageCollectionItems }

constructor TPngImageCollectionItems.Create(AOwner: TPersistent);
begin
  inherited Create(TPngImageCollectionItem);
  FOwner := AOwner;
end;

function TPngImageCollectionItems.Add(DontCreatePNG: Boolean = False): TPngImageCollectionItem;
begin
  {$WARN SYMBOL_DEPRECATED OFF}
  Result := TPngImageCollectionItem.Create(Self, DontCreatePNG);
  Added(TCollectionItem(Result));
end;

procedure TPngImageCollectionItems.Assign(Source: TPersistent);
begin
  inherited Assign(Source);
  Update(nil);
end;

function TPngImageCollectionItems.GetItem(Index: Integer): TPngImageCollectionItem;
begin
  if (Index >= 0) and (Index < Count) then
    Result := TPngImageCollectionItem(inherited Items[Index])
  else
    Result := nil;
end;

function TPngImageCollectionItems.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

function TPngImageCollectionItems.Insert(Index: Integer; DontCreatePNG: Boolean = False): TPngImageCollectionItem;
begin
  Result := Add(DontCreatePNG);
  Result.Index := Index;
end;

procedure TPngImageCollectionItems.SetItem(Index: Integer; const Value: TPngImageCollectionItem);
begin
  if (Index >= 0) and (Index < Count) then
    inherited Items[Index] := Value;
end;

procedure TPngImageCollectionItems.Update(Item: TCollectionItem);
begin
  inherited Update(Item);
  if FOwner is TPngImageList then
    TPngImageList(FOwner).CopyPngs;
end;

constructor TPngImageCollectionItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FPngImage := TPngImage.Create;
  FName := Format('PngImage%d', [Index]);
  FBackground := clBtnFace;
end;

constructor TPngImageCollectionItem.Create(Collection: TCollection; DontCreatePNG: Boolean = False);
begin
  inherited Create(Collection);
  if DontCreatePng then
    FPngImage := nil
  else
    FPngImage := TPngImage.Create;
  FName := Format('PngImage%d', [Index]);
  FBackground := clBtnFace;
end;

destructor TPngImageCollectionItem.Destroy;
begin
  FPngImage.Free;
  inherited Destroy;
end;

procedure TPngImageCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TPngImageCollectionItem then begin
    PngImage.Assign(TPngImageCollectionItem(Source).PngImage);
    Background := TPngImageCollectionItem(Source).Background;
    Name := TPngImageCollectionItem(Source).Name;
  end
  else
    inherited Assign(Source);
end;

{ TPngImageCollectionItem }

procedure TPngImageCollectionItem.AssignTo(Dest: TPersistent);
begin
  inherited AssignTo(Dest);
  if (Dest is TPngImageCollectionItem) then
    TPngImageCollectionItem(Dest).PngImage := PngImage;
end;

function TPngImageCollectionItem.Duplicate: TPngImage;
begin
  Result := TPngImage.Create;
  Result.Assign(FPngImage);
end;

function TPngImageCollectionItem.GetDisplayName: string;
begin
  if Length(FName) = 0 then
    Result := inherited GetDisplayName
  else
    Result := FName;
end;

procedure TPngImageCollectionItem.SetBackground(const Value: TColor);
begin
  if FBackground <> Value then begin
    FBackground := Value;
    Changed(False);
  end;
end;

procedure TPngImageCollectionItem.SetPngImage(const Value: TPngImage);
begin
  if FPngImage = nil then
    FPngImage := TPngImage.Create;
  FPngImage.Assign(Value);
  Changed(False);
end;

initialization

finalization
  MethodPatches.Free;

end.