uSystemImageList.pas

unit uSystemImageList;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, ImgList, uutlGenerics;

type
  TSystemImageList = class(TCustomImageList)
  private type
    TSysIconIndex = specialize TutlMap<LongInt, Integer>;
  private
    fKnownMap: TSysIconIndex;
  protected
    function GetIconByObject(obj: PChar; Flags: LongInt): integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure AddImagesFrom(const aList: TCustomImageList);

    function GetFileImage(const Path: string): integer;
    function GetExtImage(const Extension: string): integer;
  end;

implementation

uses
  ShellApi, Windows, Graphics, CommCtrl;

{ TSystemImageList }

constructor TSystemImageList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fKnownMap:= TSysIconIndex.Create;
  SetWidthHeight(GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
end;

destructor TSystemImageList.Destroy;
begin
  FreeAndNil(fKnownMap);
  inherited Destroy;
end;


function TSystemImageList.GetIconByObject(obj: PChar; Flags: LongInt): integer;
var
  fi: TSHFILEINFO;
  sysil: THandle;
  icon: TIcon;
begin
  Result:= -1;
  Flags:= Flags or SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_ICON;

  FillChar(fi{%H-}, sizeof(fi), 0);
  sysil:= SHGetFileInfo(obj, 0, fi, sizeof(fi), flags);
  try
    if sysil = 0 then
      exit;

    if fKnownMap.Contains(fi.iIcon) then begin
      Result:= fKnownMap.Values[fi.iIcon];
    end else begin
      icon:= TIcon.Create;
      try
        icon.Handle:= fi.hIcon;
        Result:= AddIcon(icon);
        // replace icon to preserve transparency, see http://forum.lazarus.freepascal.org/index.php/topic,24111.msg144788.html#msg144788
        ImageList_ReplaceIcon(Handle, Result, icon.Handle);
        fKnownMap.Add(fi.iIcon, Result);
      finally
        FreeAndNil(icon);
      end;
    end;
  finally
    DestroyIcon(fi.hIcon);
  end;
end;

function TSystemImageList.GetExtImage(const Extension: string): integer;
var
  ex: string;
begin
  // comment on https://msdn.microsoft.com/en-us/library/windows/desktop/bb762179%28v=vs.85%29.aspx
  // to get the "unknown file" for files with no extension, don't pass the empty string but
  // rather pass a name with no extension
  if Extension = '' then
    ex:= 'unknown'
  else
    ex:= Extension;
  Result:= GetIconByObject(PChar(ex), SHGFI_USEFILEATTRIBUTES);
end;

function TSystemImageList.GetFileImage(const Path: string): integer;
begin
  Result:= GetIconByObject(PChar(Path), 0);
end;

procedure TSystemImageList.AddImagesFrom(const aList: TCustomImageList);
var
  i: integer;
  img: TBitmap;
begin
  if (aList.Width = Width) and (aList.Height = Height) then
    AddImages(aList)
  else begin
    img:= TBitmap.Create;
    try
      for i:= 0 to aList.Count - 1 do begin
        aList.GetBitmap(i, img);
        Add(img,nil);
      end;
    finally
      FreeAndNil(img);
    end;
  end;
end;

end.