Fatal编程技术网
  • delphi/
  • Delphi 如何将32位图标的图像列表导出为单个32位位图文件？

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

delphi

Delphi 如何将32位图标的图像列表导出为单个32位位图文件？,delphi,delphi-7,delphi-5,Delphi,Delphi 7,Delphi 5,我想编写一个小实用程序，帮助我从EXE资源加载单个32位位图（带alpha）： ImageList1.DrawingStyle := dsTransparent; ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy, CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT); 上述

我想编写一个小实用程序，帮助我从EXE资源加载单个32位位图（带alpha）：

ImageList1.DrawingStyle := dsTransparent;
ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy,
    CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT);
上述方法效果良好

为了生成位图，我将32位透明图标从磁盘（带有alpha）加载到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），输出位图也是垂直的，不能通过
imagelist\u LoadImage
加载：

即使在Bummi给出的代码中，输出位图也会出现反锯齿，这是不好的。以下是一个示例（800%缩放-仅前3个图标）：

良好带有alpha通道的位图，可通过
ImageList\u LoadImage加载正常：



错误带有alpha通道的位图（注意黑色的反别名）：


我获得完美结果的唯一方法是使用GDI+并直接从磁盘文件读取图标（而不是图像列表）。

这仅适用于Vista而不是XP（在GDI+
GdipCreateBitmapFromHICON
和
GdipCreateBitmapFromHBITMAP
函数的旧版本中）
破坏alpha通道-他们为每个像素写入alpha=255）

我所有直接从Imagelist加载图标的尝试都失败了，并产生了抗锯齿位图



下面是另一张图片，用于说明输出位图结果：



我想我终于成功了。仍然需要缠绕，但对我有效。关键是将图标位图复制到目标扫描线，而不是将图标绘制到目标画布


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\u GetImageInfo（ImageList1.handle，0，Info）；h_Bitmap:=CopyImage（Info.hbmImage，IMAGE_Bitmap，0，0，LR_COPYRETURNORG）
但在任何情况下，它在以后的
ImageList\u LoadImage中都不可用
使用

要显示包含alpha通道信息的位图，可以使用或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;


您必须提供适当的句柄类型和字母格式（在较新版本上）

对于位图，您将必须清理扫描线，之后绘图将正常工作


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;


提取图标并将其绘制为thm透明位图


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); 


图标本身不包含透明度信息，所有绘制都由遮罩完成。
所以你可以用一种“神奇”的颜色来填充你的位图，在这里用紫红色（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;



Delphi内部附带的ImageList组件已经将其所有图像存储在一个大位图中。您可以访问此位图，尽管它的句柄可以通过调用


ImageList1.GetImageBitmap


编辑：经过一些思考和尝试，我必须承认我推荐的方法并不好。为什么？访问ImageList的内部位图可能不是最好的主意，因为在不同的Delphi版本之间，ImageList处理其图像的方式似乎有些不一致。这意味着在当前版本的Delphi中运行的任何此类代码在未来版本中可能不再运行

现在，如果我只检查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;



我创建了保存为位图或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;



创建尺寸为cx=ImageCount*ImageWidth和cy=ImageHeight的位图。然后在该位图上的明显位置逐个绘制图标。也许
TImageList.GetImageBitmap
可以在这里提供帮助。@Uwerabe，我已经尝试过了，但出现了“资源不足”异常。该异常返回图像列表控件正在使用的位图。你需要复制它。如果您将其分配给
TBitmap.Handle
，则位图和图像列表都认为它们拥有相同的位图。@DavidHeffernan，那么我如何复制它？D5中没有字母格式，我怀疑这是问题的关键：（为什么要去“复制”当ImageList已经将其所有图像存储在一个大位图中，您可以使用ImageList1检索该位图的句柄时，图像列表中包含的每个图像/图标将分别存储到一个位图中，以便将它们组合成一个图像。GetImageBitmap？我已经从D2009中破解了AlphaFormat。尝试了
PreMultiplyAlpha
和
UnmultiplyAlpha
。不透明度/Alpha通道/调色板（可能？）与图标不同。位图在alpha通道中是透明的，但在我从EXE资源通过
ImageList\u LoadImage
将其加载到图像列表后，它看起来非常糟糕。@SilverWarior，因为通过GetImageBitmap可访问的位图不包含alpha信息。@zig我只是在试验
Windows.AlphaBlend
在D7上，但这里的位图似乎已经有问题了。这是一个
HBITMAP
，您不能调用
DeleteObject
打开。因此，在不调用
DeleteObject
的情况下使用该位图需要一些努力。您应该在此基础上展开。当我使用
bmp:=TBitmap.Create；bmp.Handle:=ImageList10.GetImageBitmap；bmp.SaveToFi

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



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;



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.