How to add an icon to the ImageList bigger-sized without stretching?

Question

I have ImageList sized 72x72, handle to the icon (HICON), obtained by SHGetFileInfo (for example a large icon sized 32x32). How to add it to this ImageList keeping transparency, but without stretching? Now I draw the icon in the middle of a temporary bitmap desired size, then add it to the ImageList.

SHGetFileInfo(PChar(Path + sr.Name), sr.FindData.dwFileAttributes, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
Bmp:=TBitmap.Create;
Bmp.PixelFormat:=pf32bit;
Bmp.SetSize(72, 72);
DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
iIcon:=ImageList_AddMasked(ilThumbs.Handle, Bmp.Handle, 0);
Bmp.Free;

But I think a way faster exists (without drawing on temporary bitmap). Also image in ImageList loses transparency and when I set index of this Image in ImageList for ListView item.ImageIndex it looks not pretty (when this item is selected, white background around is present). Is any way to solve this problem?

Thanks.

Answer 1

This is the code that I use to perform this task.

Note that I am assuming that the original icon uses 32 bit colour, with alpha channel. That's reasonable in the settings that I use this code, but I can't be sure whether or not it's reasonable for you.

uses
  Windows, Graphics;

function CreateIconFromSmallerIcon(IconSize: Integer; SmallerIcon: HICON): HICON;

  procedure GetDIBheaderAndBits(bmp: HBITMAP; out bih: BITMAPINFOHEADER; out bits: Pointer);
  var
    pbih: ^BITMAPINFOHEADER;
    bihSize, bitsSize: DWORD;
  begin
    bits := nil;
    GetDIBSizes(bmp, bihSize, bitsSize);
    pbih := AllocMem(bihSize);
    Try
      bits := AllocMem(bitsSize);
      GetDIB(bmp, 0, pbih^, bits^);
      if pbih.biSize<SizeOf(bih) then begin
        FreeMem(bits);
        bits := nil;
        exit;
      end;
      bih := pbih^;
    Finally
      FreeMem(pbih);
    End;
  end;

  procedure InitialiseBitmapInfoHeader(var bih: BITMAPINFOHEADER);
  begin
    bih.biSize := SizeOf(BITMAPINFOHEADER);
    bih.biWidth := IconSize;
    bih.biHeight := 2*IconSize;//height of xor bitmap plus height of and bitmap
    bih.biPlanes := 1;
    bih.biBitCount := 32;
    bih.biCompression := BI_RGB;
  end;

  procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
  var
    line, xOffset, yOffset: Integer;
  begin
    xOffset := (IconSize-sbih.biWidth) div 2;
    yOffset := (IconSize-sbih.biHeight) div 2;
    inc(dptr, xOffset + IconSize*yOffset);
    for line := 0 to sbih.biHeight-1 do begin
      Move(sptr^, dptr^, sbih.biWidth*SizeOf(DWORD));
      inc(dptr, IconSize);//relies on the fact that no padding is needed for RGBA scanlines
      inc(sptr, sbih.biWidth);//likewise
    end;
  end;

var
  SmallerIconInfo: TIconInfo;
  sBits, xorBits: PDWORD;
  xorScanSize, andScanSize: Integer;
  xorBitsSize, andBitsSize: Integer;
  sbih: BITMAPINFOHEADER;
  dbih: ^BITMAPINFOHEADER;
  resbitsSize: DWORD;
  resbits: Pointer;

begin
  Result := 0;
  Try
    if not GetIconInfo(SmallerIcon, SmallerIconInfo) then begin
      exit;
    end;
    Try
      GetDIBheaderAndBits(SmallerIconInfo.hbmColor, sbih, Pointer(sBits));
      if Assigned(sBits) then begin
        Try
          if (sbih.biWidth>IconSize) or (sbih.biHeight>IconSize) or (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
            exit;
          end;

          xorScanSize := BytesPerScanline(IconSize, 32, 32);
          Assert(xorScanSize=SizeOf(DWORD)*IconSize);
          andScanSize := BytesPerScanline(IconSize, 1, 32);
          xorBitsSize := IconSize*xorScanSize;
          andBitsSize := IconSize*andScanSize;
          resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
          resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
          Try
            dbih := resbits;
            InitialiseBitmapInfoHeader(dbih^);

            xorBits := resbits;
            inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
            CreateXORbitmap(sbih, dbih^, sBits, xorBits);

            //don't need to fill in the mask bitmap when using RGBA
            Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, IconSize, IconSize, LR_DEFAULTCOLOR);
          Finally
            FreeMem(resbits);
          End;
        Finally
          FreeMem(sBits);
        End;
      end;
    Finally
      if SmallerIconInfo.hbmMask<>0 then begin
        DeleteObject(SmallerIconInfo.hbmMask);
      end;
      if SmallerIconInfo.hbmColor<>0 then begin
        DeleteObject(SmallerIconInfo.hbmColor);
      end;
    End;
  Finally
    DestroyIcon(SmallerIcon);
  End;
end;

Answer 2

Ok, my solution below:

procedure SetAlpha(Bitmap: TBitmap);
type
  PPixelRec = ^TPixelRec;
  TPixelRec = packed record
    B, G, R, Alpha: Byte;
  end;
var
  X, Y: Integer;
  Pixel: PPixelRec;
begin
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    Pixel := Bitmap.ScanLine[Y];
    for X := 0 to (Bitmap.Width - 1) do
    begin
      Pixel.Alpha:=255;
      Inc(Pixel);
    end;
  end;
end;
//skipped
var Bmp: TBitmap;
    fi: TSHFileInfo;
    ImageList1: TImageList;
begin
  ImageList1:=TImageList.CreateSize(72, 72);
  ImageList1.DrawingStyle:=dsTransparent;
  ImageList1.ColorDepth:=cd32Bit;
  SHGetFileInfo('c:\Windows\notepad.exe', FILE_ATTRIBUTE_NORMAL, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
  Bmp:=TBitmap.Create;
  Bmp.SetSize(72, 72);
  SetAlpha(Bmp);
  Bmp.Canvas.Brush.Color:=clWhite;
  Bmp.Canvas.FillRect(Rect(0, 0, 72, 72));
  DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
  fi.iIcon:=ImageList1.Add(Bmp, nil);
  ImageList1.Draw(Canvas, 0, 0, fi.iIcon); //just to see that's alright
end;