Scaling TImageList with PNG icons for high DPI mode

Question

I want to make HeidiSQL high-dpi aware, which includes upscaling my one TImageList with lots of alpha-transparent PNG icons in it.

I have baken a procedure which does it, but it breaks the normal transparency and also the alpha-transparency, so the icons look very broken afterwards, especially at their edges:

Here's the code for that:

procedure ScaleImageList(const ImgList: TImageList; ScaleFactor: Real);
var
  i: Integer;
  Extracted, Scaled: Graphics.TBitmap;
  ImgListCopy: TImageList;
begin
  if ScaleFactor = 1 then
    Exit;
  // Create copy of original image list
  ImgListCopy := TImageList.Create(nil);
  ImgListCopy.ColorDepth := cd32Bit;
  ImgListCopy.DrawingStyle := dsTransparent;
  ImgListCopy.Clear;
  // Add from source image list
  for i := 0 to ImgList.Count-1 do begin
    ImgListCopy.AddImage(ImgList, i);
  end;
  // Set size to match scale factor
  ImgList.SetSize(Round(ImgList.Width * ScaleFactor), Round(ImgList.Height * ScaleFactor));
  for i:= 0 to ImgListCopy.Count-1 do begin
    Extracted := Graphics.TBitmap.Create;
    ImgListCopy.GetBitmap(i, Extracted);
    Scaled := Graphics.TBitmap.Create;
    Scaled.Width := ImgList.Width;
    Scaled.Height := ImgList.Height;
    Scaled.Canvas.FillRect(Scaled.Canvas.ClipRect);
    GraphUtil.ScaleImage(Extracted, Scaled, ScaleFactor);
    ImgList.Add(Scaled, Scaled);
  end;
  ImgListCopy.Free;
end;

I also tried some code from Žarko Gajić but that did just remove transparency from the images, even without actual scaling.

Paint.net does nice scaling on its icons, but it's written in C#, so this is of no help:

Answer 1

Ok, here's how I upscaled images in that list smoothly.

From the main form's OnCreate event, I am calling ScaleImageList:

DpiScaleFactor := Monitor.PixelsPerInch / PixelsPerInch;
ScaleImageList(ImageListMain, DpiScaleFactor);

ScaleImageList itself creates a blank TImageList at runtime, loads PNGs from the original list, resizes each of them, and put these into the new image list. In the end the original image list gets overwritten with the new one:

procedure ScaleImageList(const ImgList: TImageList; ScaleFactor: Real);
var
  ResizedImages: TImageList;
  i: integer;
  BitmapCopy: Graphics.TBitmap;
  PngOrig: TPngImage;
  ResizedWidth: Integer;
begin
  // Upscale image list for high-dpi mode
  if ScaleFactor = 1 then
    Exit;

  ResizedWidth := Round(imgList.Width * ScaleFactor);

  // Create new list with resized icons
  ResizedImages := TImageList.Create(ImgList.Owner);
  ResizedImages.Width := ResizedWidth;
  ResizedImages.Height := ResizedWidth;
  ResizedImages.ColorDepth := ImgList.ColorDepth;
  ResizedImages.DrawingStyle := ImgList.DrawingStyle;
  ResizedImages.Clear;

  for i:=0 to ImgList.Count-1 do begin
    PngOrig := TPngImage.CreateBlank(COLOR_RGBALPHA, 8, ImgList.Width, ImgList.Height);
    LoadPNGFromImageList(ImgList, i, PngOrig);
    ResizePngImage(PngOrig, ResizedWidth, ResizedWidth);
    BitmapCopy := Graphics.TBitmap.Create;
    PngOrig.AssignTo(BitmapCopy);
    BitmapCopy.AlphaFormat := afIgnored;
    ImageList_Add(ResizedImages.Handle, BitmapCopy.Handle, 0);
  end;

  // Assign images to original instance
  ImgList.Assign(ResizedImages);
end;

Most important are the both helpers LoadPNGFromImageList for loading an PNG image from an imagelist into a TPNGImage, including its alpha channel. And ResizePngImage, which is basically a code snippet from Gustavo Daud, the author of PNGDelphi:

procedure LoadPNGFromImageList(AImageList: TCustomImageList; AIndex: Integer; var ADestPNG: TPngImage);
const
  PixelsQuad = MaxInt div SizeOf(TRGBQuad) - 1;
type
  TRGBAArray = Array [0..PixelsQuad - 1] of TRGBQuad;
  PRGBAArray = ^TRGBAArray;
var
  ContentBmp: Graphics.TBitmap;
  RowInOut: PRGBAArray;
  RowAlpha: PByteArray;
  x: Integer;
  y: Integer;
begin
  // Extract PNG image with alpha transparency from an imagelist
  // Code taken from https://stackoverflow.com/a/52811869/4110077
  if not Assigned(AImageList) or (AIndex < 0)
    or (AIndex > AImageList.Count - 1) or not Assigned(ADestPNG)
    then
    Exit;
  ContentBmp := Graphics.TBitmap.Create;
  try
    ContentBmp.SetSize(ADestPNG.Width, ADestPNG.Height);
    ContentBmp.PixelFormat := pf32bit;
    // Allocate zero alpha-channel
    for y:=0 to ContentBmp.Height - 1 do begin
      RowInOut := ContentBmp.ScanLine[y];
      for x:=0 to ContentBmp.Width - 1 do
        RowInOut[x].rgbReserved := 0;
    end;
    ContentBmp.AlphaFormat := afDefined;
    // Copy image
    AImageList.Draw(ContentBmp.Canvas, 0, 0, AIndex, true);
    // Now ContentBmp has premultiplied alpha value, but it will
    // make bitmap too dark after converting it to PNG. Setting
    // AlphaFormat property to afIgnored helps to unpremultiply
    // alpha value of each pixel in bitmap.
    ContentBmp.AlphaFormat := afIgnored;
    // Copy graphical data and alpha-channel values
    ADestPNG.Assign(ContentBmp);
    ADestPNG.CreateAlpha;
    for y:=0 to ContentBmp.Height - 1 do begin
      RowInOut := ContentBmp.ScanLine[y];
      RowAlpha := ADestPNG.AlphaScanline[y];
      for x:=0 to ContentBmp.Width - 1 do
        RowAlpha[x] := RowInOut[x].rgbReserved;
    end;
  finally
    ContentBmp.Free;
  end;
end;

And the second helper:

procedure ResizePngImage(aPng: TPNGImage; NewWidth, NewHeight: Integer);
var
  xscale, yscale: Single;
  sfrom_y, sfrom_x: Single;
  ifrom_y, ifrom_x: Integer;
  to_y, to_x: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue, new_alpha: Integer;
  new_colortype: Integer;
  total_red, total_green: Single;
  total_blue, total_alpha: Single;
  IsAlpha: Boolean;
  ix, iy: Integer;
  bTmp: TPNGImage;
  sli, slo: pRGBLine;
  ali, alo: PByteArray;
begin
  // Code taken from PNGDelphi component snippets, published by Gustavo Daud in 2006
  // on SourceForge, now downloadable on https://cc.embarcadero.com/Item/25631 .
  // Slightly but carefully modified for readability.
  if not (aPng.Header.ColorType in [COLOR_RGBALPHA, COLOR_RGB]) then
    Raise Exception.Create('Only COLOR_RGBALPHA and COLOR_RGB formats are supported');
  IsAlpha := aPng.Header.ColorType in [COLOR_RGBALPHA];
  if IsAlpha then
    new_colortype := COLOR_RGBALPHA
  else
    new_colortype := COLOR_RGB;
  bTmp := TPNGImage.CreateBlank(new_colortype, 8, NewWidth, NewHeight);
  xscale := bTmp.Width / (aPng.Width-0.35); // Modified: (was -1) substract minimal value before AlphaScanline crashes
  yscale := bTmp.Height / (aPng.Height-0.35);
  for to_y:=0 to bTmp.Height-1 do begin
    sfrom_y := to_y / yscale;
    ifrom_y := Trunc(sfrom_y);
    weight_y[1] := sfrom_y - ifrom_y;
    weight_y[0] := 1 - weight_y[1];
    for to_x := 0 to bTmp.Width-1 do begin
      sfrom_x := to_x / xscale;
      ifrom_x := Trunc(sfrom_x);
      weight_x[1] := sfrom_x - ifrom_x;
      weight_x[0] := 1 - weight_x[1];

      total_red   := 0.0;
      total_green := 0.0;
      total_blue  := 0.0;
      total_alpha  := 0.0;
      for ix := 0 to 1 do begin
        for iy := 0 to 1 do begin
          sli := aPng.Scanline[ifrom_y + iy];
          if IsAlpha then
            ali := aPng.AlphaScanline[ifrom_y + iy];
          new_red := sli[ifrom_x + ix].rgbtRed;
          new_green := sli[ifrom_x + ix].rgbtGreen;
          new_blue := sli[ifrom_x + ix].rgbtBlue;
          if IsAlpha then
            new_alpha := ali[ifrom_x + ix];
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red   + new_red   * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue  + new_blue  * weight;
          if IsAlpha then
            total_alpha := total_alpha + new_alpha * weight;
        end;
      end;
      slo := bTmp.ScanLine[to_y];
      if IsAlpha then
        alo := bTmp.AlphaScanLine[to_y];
      slo[to_x].rgbtRed := Round(total_red);
      slo[to_x].rgbtGreen := Round(total_green);
      slo[to_x].rgbtBlue := Round(total_blue);
      if isAlpha then
        alo[to_x] := Round(total_alpha);
    end;
  end;
  aPng.Assign(bTmp);
  bTmp.Free;
end;