如何将32位图标的图像列表导出到单个32位位图文件中？

Question

我想编写一个小工具，可以帮助我从EXE资源中加载单个32位带Alpha通道的位图：

ImageList1.DrawingStyle := dsTransparent;
ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy,
    CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT);

上述方法运行良好。因此，为了生成该位图，我从磁盘中加载带有Alpha通道的32位透明图标到ImageList中。

for i := 1 to 10 do ... ImageList2.AddIcon(AIcon)

现在，我该如何从这个图片列表中导出32位图（它将是透明的并且带有alpha通道），并将其保存为文件，使其看起来像这样：。 下面是我的尝试，但输出的位图不透明且没有保留alpha通道：

procedure PrepareBitmap(bmp: TBitmap);
var
  pscanLine32: pRGBQuadArray;
  i, j: Integer;
begin
  for i := 0 to bmp.Height - 1 do
  begin
    pscanLine32 := bmp.Scanline[i];
    for j := 0 to bmp.Width - 1 do
    begin
      pscanLine32[j].rgbReserved := 0;
    end;
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  bmp: TBitmap;
  I: Integer;
  IL: TImageList;
begin
  IL := Imagelist10;
  bmp := TBitmap.Create;
  bmp.PixelFormat := pf32Bit;
  bmp.Canvas.brush.Color := clNone;
  bmp.Width := IL.Width * IL.Count;
  bmp.Height := IL.Height;
  //SetBkMode(bmp.Canvas.Handle, TRANSPARENT); //TRANSPARENT
  PrepareBitmap(bmp);
  for I := 0 to IL.Count - 1 do
  begin
    IL.Draw(bmp.Canvas, (I * 16), 0, I, True);
  end;
  bmp.SaveToFile('2.bmp');
end;

请注意，即使我成功使用了GetImageBitmap（我已经用24位图像列表实现了），输出的位图是垂直的，无法通过ImageList_LoadImage加载： 即使在Bummi提供的代码中，输出的位图也会变成反锯齿效果，这是不好的。以下是一个示例（使用800%缩放-只有前3个图标）：

带有alpha通道的良好位图，可以使用ImageList_LoadImage正常加载： 带有alpha通道的不良位图（请注意黑色的反锯齿效果）： 我能够获得完美的结果的唯一方法是使用GDI+并直接从磁盘文件中读取图标（而不是ImageList）。这仅适用于Vista，而不适用于XP（在旧版本的GDI+中，GdipCreateBitmapFromHICON和GdipCreateBitmapFromHBITMAP函数会破坏alpha通道-它们为每个像素写入alpha = 255）。

procedure TForm1.Button3Click(Sender: TObject);
var
  i, num_icons: Integer;
  ico: TIcon;
  icon: HICON;

  encoderClsid: TGUID;
  g: TGPGraphics;
  in_img: TGPBitmap;
  out_img: TGPImage;  
begin
  num_icons := 24;
  out_img := TGPBitmap.Create(16 * num_icons , 16, PixelFormat32bppARGB);

  for i := 1 to num_icons do
  begin
     // does not produce correct bitmap:
     //ico := TIcon.Create;
     //ImageList1.GetIcon(i - 1, ico);
     //in_img := TGPBitmap.Create(ico.Handle);

     in_img := TGPBitmap.Create('D:\Delphi\Projects\Icons\Icon_' + inttostr(i) + '.ico');
     g := TGPGraphics.Create(out_img);
     g.DrawImage(in_img, (i - 1) * 16, 0);
     g.Free;
     in_img.Free;
  end;

  GetEncoderClsid('image/bmp', encoderClsid);
  out_img.Save('output.bmp', encoderClsid);
  out_img.Free;

  ImageList2.DrawingStyle := dsTransparent; 
  // Load from file: 
  ImageList2.Handle := ImageList_LoadImage(0, 'output.bmp', 16, ImageList2.AllocBy,
    CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT
     or LR_LOADFROMFILE);
end;

所有我直接从图像列表加载图标的尝试都失败了，并产生了反锯齿位图。请点击此处下载我正在使用的图标。以下是另一张图片，用于说明输出位图结果： 我认为最终我成功了。虽然还需要调整，但对我来说已经可以工作了。关键是将图标位图复制到目标扫描线，而不是将图标绘制到目标画布上。

procedure CopyBitmapChannels(Src, Dst: TBitMap; DstOffset: Integer);
var
  pscanLine32Src, pscanLine32Dst: pRGBQuadArray;
  nScanLineCount, nPixelCount: Integer;
begin
  with Src do
  begin
    for nScanLineCount := 0 to Height - 1 do
    begin
      pscanLine32Src := Scanline[nScanLineCount];
      pscanLine32Dst := Dst.Scanline[nScanLineCount];
      for nPixelCount := 0 to Width - 1 do
        with pscanLine32Src[nPixelCount] do
        begin
          pscanLine32Dst[nPixelCount + DstOffset].rgbReserved := rgbReserved;
          pscanLine32Dst[nPixelCount + DstOffset].rgbRed := rgbRed;
          pscanLine32Dst[nPixelCount + DstOffset].rgbGreen := rgbGreen;
          pscanLine32Dst[nPixelCount + DstOffset].rgbBlue := rgbBlue;
        end;
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  h_Bitmap, h_Mask: HBITMAP;
  bm_out, bm_ico: TBitmap;
  hico : HICON;
  icoInfo: TIconInfo;
  i, icon_size, num_icons: Integer;
  in_IL: TImageList;
begin
  // in_IL := ImageList1; // imagelist ready with 32 bit icons
  in_IL := nil; // from files

  icon_size := 16;
  num_icons := 24;

  bm_out := TBitmap.Create;
  bm_out.Width := icon_size * num_icons;
  bm_out.Height := icon_size;
  SetBitmapAlpha(bm_out, 0, 0, 0, 0); // no need to actually modify ScanLines but anyway 

  for i := 0 to num_icons - 1 do
  begin
    if in_IL = nil then
      hico := LoadImage(0, PChar('D:\Delphi\Projects\Icons\Icon_' + inttostr(i + 1) + '.ico'), IMAGE_ICON, 0, 0,
        LR_LOADFROMFILE or LR_LOADTRANSPARENT or LR_CREATEDIBSECTION)
    else
      hico := ImageList_GetIcon(in_IL.Handle, i, ILD_TRANSPARENT); // RGB is slightly changed - not 100% perfect but close enough!

    // get icon info (hbmColor -> bitmap)
    GetIconInfo(hico, icoInfo);
    bm_ico := TBitmap.Create;
    h_Bitmap := CopyImage(icoInfo.hbmColor, IMAGE_BITMAP, 0, 0, {LR_COPYDELETEORG or} LR_COPYRETURNORG or LR_CREATEDIBSECTION);
    bm_ico.Handle := h_Bitmap;

    CopyBitmapChannels(bm_ico, bm_out, i * icon_size);

    DestroyIcon(hico);
    DeleteObject(h_Bitmap);
    bm_ico.Free;
  end;
  bm_out.SaveToFile('output.bmp');
  bm_out.Free;
  // output.bmp is now ready to load with ImageList_LoadImage
end;

顺便提一下，我可以像这样复制GetImageBitmap的句柄：ImageList_GetImageInfo(ImageList1.Handle, 0, Info); h_Bitmap := CopyImage(Info.hbmImage, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)但无论如何，它都不能与ImageList_LoadImage后续使用。

- zig

---

也许 TImageList.GetImageBitmap 可以在这里帮助。 - Uwe Raabe

@UweRaabe，我已经尝试了，但我收到了“资源不足”异常。 - zig

这将返回图像列表控件正在使用的位图。您需要复制它。如果将其分配给TBitmap.Handle，则位图和图像列表都认为它们拥有相同的位图。 - David Heffernan

您需要将其选入 DC 中，然后调用 BitBlt。这是老派的 GDI 编程。 - David Heffernan

@David，你觉得你能发一些代码吗？我看到了这篇文章：https://dev59.com/DlbTa4cB1Zd3GeqP9Ukd，但不确定如何翻译。 - zig

Answer 1

使用32位DIB节创建您的图像列表。

ImageList1.Handle :=ImageList_Create(16, 16, ILC_COLOR32 ,4, 4);

为了显示包含 alpha 通道信息的位图，您可以使用 AlphaBlend 函数 或 GDI+ 函数。

uses CommCtrl;

Procedure DisplayAlphaChanelBitmap(BMP:TBitmap;C:TCanvas;X,Y:Integer);
var
  BF:TBlendFunction;
begin
    BF.BlendOp := AC_SRC_OVER;
    BF.BlendFlags := 0;
    BF.SourceConstantAlpha := 255;
    BF.AlphaFormat := AC_SRC_ALPHA;
    Windows.AlphaBlend(C.Handle, x, y, BMP.Width, BMP.Height, BMP.Canvas.Handle
                      , 0, 0, BMP.Width, BMP.Height, BF)
end;

您需要为位图提供适当的句柄类型和alphaformat（在较新的Delphi版本中），并清除扫描行，之后绘图将按预期工作。

type
  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = ARRAY [0 .. 0] OF TRGBQuad;
  TRefChanel=(rcBlue,rcRed,rcGreen);

procedure SetBitmapAlpha(ABitmap: TBitMap; Alpha, ARed, Green, Blue: Byte);
var
  pscanLine32: pRGBQuadArray;
  nScanLineCount, nPixelCount : Integer;
begin
  with ABitmap do
  begin
    PixelFormat := pf32Bit;
    HandleType := bmDIB;
    ignorepalette := true;
    // alphaformat := afDefined; not available with D5 and D7
    for nScanLineCount := 0 to Height - 1 do
    begin
      pscanLine32 := Scanline[nScanLineCount];
      for nPixelCount := 0 to Width - 1 do
        with pscanLine32[nPixelCount] do begin
          rgbReserved := Alpha;
          rgbBlue := Blue;
          rgbRed := ARed;
          rgbGreen := Green;
        end;
    end;    
  end;
end;

提取图标并将它们绘制到透明位图中。

procedure TForm1.Button3Click(Sender: TObject);
var
 BMP:TBitMap;
 ICO:TIcon;
 I: Integer;    
begin
  BMP:=TBitMap.Create;
  BMP.Width := Imagelist1.Width * Imagelist1.Count;
  BMP.Height := Imagelist1.Height;
  try
  SetBitmapAlpha(BMP,0,0,0,0);
  for I := 0 to Imagelist1.Count-1 do
    begin
     ICO:=TIcon.Create;
     try
       Imagelist1.GetIcon(i,ICO);
       BMP.Canvas.Draw(i * Imagelist1.Width, 0, ico);
     finally
       ICO.Free;
     end;
    end;
  BMP.SaveToFile('C:\Temp\Transparent.bmp');
  Canvas.Pen.Width := 3;
  Canvas.Pen.Color := clRed;
  Canvas.MoveTo(10,15);
  Canvas.LineTo(24*16+10,15);
  DisplayAlphaChanelBitmap( BMP, Canvas , 10 , 10)
  finally
    BMP.Free;
  end;
end;

使用 Delphi 5 或 Delphi 7 时，如何使用非透明图标

如果您正在使用以下代码加载 ICO 文件：

ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy,
        CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT); 

图标本身不包含透明信息，所有的绘制都是由掩码完成的。因此，在这里您可以使用 "魔法" 颜色 clFuchsia（C_R，C_G，C_B）填充位图，绘制图标，并将所有不包含 "魔法" 颜色的像素的 Alpha 通道设置为 255。

const
C_R=255;
C_G=0;
C_B=255;



procedure AdaptBitmapAlphaByColor(ABitmap: TBitMap;  ARed, AGreen, ABlue: Byte);
var
  pscanLine32: pRGBQuadArray;
  nScanLineCount, nPixelCount : Integer;
begin
  with ABitmap do
  begin
    for nScanLineCount := 0 to Height - 1 do
    begin
      pscanLine32 := Scanline[nScanLineCount];
      for nPixelCount := 0 to Width - 1 do
        with pscanLine32[nPixelCount] do
        begin
          if NOT (
          (rgbBlue = ABlue)
          AND (rgbRed = ARed)
          AND (rgbGreen = AGreen)
          ) then rgbReserved := 255;
        end;
    end;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
 BMP:TBitMap;
 ICO:TIcon;
 I: Integer;
begin
  BMP:=TBitMap.Create;
  BMP.Width := Imagelist1.Width * Imagelist1.Count;
  BMP.Height := Imagelist1.Height;
  try
  SetBitmapAlpha(BMP,0,C_R,C_G,C_B);
  for I := 0 to Imagelist1.Count-1 do
    begin
     ICO:=TIcon.Create;
     try
       Imagelist1.GetIcon(i,ICO);
       BMP.Canvas.Draw(i * Imagelist1.Width, 0, ico);
     finally
       ICO.Free;
     end;
    end;
  AdaptBitmapAlphaByColor(BMP, C_R, C_G, C_B);
  BMP.SaveToFile('C:\Temp\Transparent.bmp');
  finally
    BMP.Free;
  end;
end;

- bummi

---

为什么要逐个“复制”图像/图标，以便将它们全部组合成一幅图像，而ImageList已经将所有图像存储在一个大位图中，您可以使用ImageList1.GetImageBitmap检索其句柄？ - SilverWarior

@SilverWarior 因为通过 GetImageBitmap 获取的位图不包含 Alpha 信息。 - bummi

@zig 我只是在D7上尝试使用Windows.AlphaBlend，但是位图似乎已经出了问题。 - bummi

@bummi，尝试将该位图保存到EXE资源中，并通过ImageList1.DrawingStyle := dsTransparent; ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy, CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT);进行加载。您会注意到与原始图标的差异。 - zig

@zig，我会删除这个答案，我没有及时识别出 Delphi 5，抱歉。 - bummi

Answer 2

我创建了保存为位图或PNG的GDI+版本。

第一个技巧是将ImageList转换为GDI+位图：

function ImageListToGPBitmap(SourceImageList: TImageList): TGPBitmap;
var
    bmp: TGPBitmap;
    g: TGPGraphics;
    dc: HDC;
    i: Integer;
    x: Integer;

    procedure GdipCheck(Status: Winapi.GDIPAPI.TStatus);
    begin
        if Status <> Ok then
            raise Exception.CreateFmt('%s', [GetStatus(Status)]);
    end;
begin
    //Note: Code is public domain. No attribution required.
    bmp := TGPBitmap.Create(SourceImageList.Width*SourceImageList.Count, SourceImageList.Height);
    GdipCheck(bmp.GetLastStatus);

    g := TGPGraphics.Create(bmp);
    GdipCheck(g.GetLastStatus);

    g.Clear($00000000);
    GdipCheck(g.GetLastStatus);

    dc := g.GetHDC;

    for i := 0 to dmGlobal.imgImages.Count-1 do
    begin
        x := i*dmGlobal.imgImages.Width;

        ImageList_DrawEx(dmGlobal.imgImages.Handle, i, dc,
                        x, 0, dmGlobal.imgImages.Width, dmGlobal.imgImages.Height,
                        CLR_NONE, CLR_DEFAULT,
                        ILD_TRANSPARENT);
    end;
    g.ReleaseHDC(dc);
    g.Free;

    Result := bmp;
end;

一旦它是一个位图，你可以将其保存为任何你喜欢的格式。我喜欢image/png，但你也可以将其保存为image/bmp：

var
    bmp: TGPBitmap;
    filename: string;
    encoder: TGUID;
begin
    if not IsDebuggerPresent then
        Exit;

    //Get GDI+ Bitmap of the imageList
    bmp := ImageListToGPBitmap(dmGlobal.imgImages);

    //Save the image to a file
    filename := ChangeFileExt(GetTemporaryFilename('imgl', False), '.bmp');
    Winapi.GDIPUtil.GetEncoderClsid('image/bmp', {out}encoder);
    bmp.Save(filename, encoder);

    filename := ChangeFileExt(GetTemporaryFilename('imgl', False), '.png');
    Winapi.GDIPUtil.GetEncoderClsid('image/png', {out}encoder);
    bmp.Save(filename, encoder);
    //Note: Code is public domain. No attribution required.

- Ian Boyd

Answer 3

Delphi内置的ImageList组件已经将所有图像存储在一个大位图中。您可以通过调用其句柄来访问此位图。

ImageList1.GetImageBitmap

编辑：经过一些思考和尝试，我必须承认我推荐的方法不好。为什么？访问ImageList的内部位图可能不是最佳选择，因为在不同版本的Delphi之间，似乎存在一些关于图像列表如何处理其图像的不一致性。这意味着，在当前版本的Delphi中工作的任何此类代码在将来的版本中可能不再起作用。

现在，如果我只检查Delphi 7和Delphi XE3之间ImageList图像存储方式的差异，其中Delphi 7中ImageList图像存储在多行中，而Delphi XE3中ImageList图像存储在单列中，这意味着您的代码需要考虑到这一点。

无论如何，如果有人想进一步研究这种方法，这就是我用于将ImageList内部图像内容导出到文件的方法：

var Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  Bitmap.Handle := ImageList1.GetImageBitmap;
  Bitmap.SaveToFile('D:\Proba.bmp');
  Bitmap.ReleaseHandle;
  Bitmap.Free;
end;

- SilverWarior

---

那是一个 HBITMAP，你不能调用 DeleteObject。因此，在不调用 DeleteObject 的情况下使用该位图需要一些努力。你应该进一步扩展这个问题。 - David Heffernan

@Silver 这比你说的更加复杂。你需要做更多的工作。 - David Heffernan

我以前用过这个，但是现在似乎找不到我当时使用的完整代码了。我放弃了使用它，因为我转向了另一个组件，它为我提供了更多我需要的功能。 - SilverWarior

@DavidHeffernan，有趣的是imagelist流ImageList_Write/ImageList_Read以相同的垂直方式保存位图（有一个IL头，但位图就在那里）。位图也是反锯齿的。无论如何，好像还有一个额外的掩码位图...我不认为Silver曾经使用过ImageList_LoadImage。 - zig

我认为SilverWarrior似乎对于在这里起到关键作用的细节不感兴趣。这个回答应该是一条评论。 - David Heffernan