Delphi 使用PNG图标缩放高DPI模式的TImageList

我想让HeidiSQL具有高dpi意识，这包括使用大量透明的PNG图标放大我的单幅图像列表

我已经烘焙了一个程序，但它破坏了正常的透明度和alpha透明度，因此图标在之后看起来非常破碎，尤其是在其边缘：

下面是代码：

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;

我也尝试了一些，但那只是去除了图像的透明度，即使没有实际的缩放

Paint.net在图标上的缩放效果很好，但它是用C#编写的，因此这没有帮助：

---

好的，下面是我如何平滑地放大列表中的图像

从主窗体的

OnCreate

事件中，我调用

ScaleImageList

：

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

ScaleImageList

本身在运行时创建一个空白的TImageList，从原始列表加载PNG，调整每个PNG的大小，并将其放入新的图像列表中。最后，原始图像列表将被新图像列表覆盖：

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;

最重要的是用于将PNG图像从imagelist加载到

TPNGImage

的两个助手

LoadPNGFromImageList

，包括其alpha通道。及

ResizePngImage

，它基本上是来自《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;

---

不要调整图像的大小。提供16像素、20像素、24像素、32像素的图像。在运行时根据DPI选择它们。并且，必要时，始终提供可以缩小的较大图像，不要提供必须放大的较小图像。这将减少伪影，尤其是在边框周围。您正在向ImgListCopy添加位图。请参阅“TCustomImageList”中的“CopyImages”，这是提取源图像的内容。一旦进入图像列表，就永远无法提取“png”或任何原始格式。图像列表不保留文件，而是保留图像。在这方面，这个问题不是重复的。如果你需要一个png，那么你必须在周围保留一个png。你可以从图像列表中的图像信息构造一个png。但那将是一个不同的png，而不是原来的。请参阅。-“…现在已解除功能…”-实际上它仍然可以正常工作，它是在VCL中提供png支持的代码的基础。请参阅pngimage.pas顶部的注释。顺便说一句，您可能想回答您的问题。很高兴看到我的代码帮助了其他人，但您的代码中存在一些内存泄漏。首先，在循环外部创建

TPNGImage

，并在循环完成后将其释放。其次，在循环中，您可以编写这个

PngOrig.CreateBlank（COLOR_RGBALPHA，8，ImgList.Width，ImgList.Height）而不是在每次迭代中创建
TPNGImage
。此外，您还可以创建并不释放
位图副本
和
大小图像
。您必须改进代码，否则它肯定会消耗大量有关
ImgList
中图像计数的资源。
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;