How to export Image list of 32bit icons into single 32bit bitmap file?
I want to write a small utility which will help me load a single 32bit bitmap (with alpha) from a EXE resource:
ImageList1.DrawingStyle := dsTransparent;
ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy,
CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT);
The above works well.
So to generate that bitmap, I'm loading 32 bit transparent icons from my disk (with alpha) into an ImageList
for i := 1 to 10 do ... ImageList2.AddIcon(AIcon)
Now, how do I export the 32 bitmap (which will be transparent and have the alpha channel) from this image list and save it as a file which should looks like this:
Here is my attempt. But the output bitmap does NOT look transparent and does not maintain the alpha channel:
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;
Note that even if you I manage to use GetImageBitmap (I did with 24bit imagelist), the output bitmap is vertical and cannot be load via ImageList_LoadImage :
Even in the code given by Bummi the output bitmap becomes anti-aliased which is no good. here is an example (with 800% zoom - only first 3 icons):
Good bitmap with alpha channel which will load OK with ImageList_LoadImage :
Bad bitmap with alpha channel (notice the anti-alias with black):
The Only way I could get perfect results was with GDI+ and reading the icons directly from disk files ( NOT the ImageList).
This Only works ok on Vista NOT XP (in older versions of GDI+ GdipCreateBitmapFromHICON and GdipCreateBitmapFromHBITMAP functions destroy alpha channel - they write alpha=255 for each pixel).
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:DelphiProjectsIconsIcon_' + 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;
All my attempts to load the Icons from the Imagelist directly, failed and resulted anti-aliased bitmaps.
Here is a link to download the icons I'm working with
And here is another picture to illustrate the output bitmap results:
I think I made it work finally. still needs twining but it works for me. the key is to copy the icons bitmaps to the destination scanlines, instead of drawing the icons to the destination canvas.
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:DelphiProjectsIconsIcon_' + 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;
BTW, I could copy GetImageBitmap handle like this: ImageList_GetImageInfo(ImageList1.Handle, 0, Info); h_Bitmap := CopyImage(Info.hbmImage, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) ImageList_GetImageInfo(ImageList1.Handle, 0, Info); h_Bitmap := CopyImage(Info.hbmImage, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) but in any case it is not usable later with ImageList_LoadImage .
Create your imagelist using a Use a 32-bit DIB section.
ImageList1.Handle :=ImageList_Create(16, 16, ILC_COLOR32 ,4, 4);
To display Bitmaps containing alpha channel information you may use the AlphaBlend function or GDI+ functions.
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;
You will have to provide the appropriate handle type and alphaformat (on newer Delphiversions)
for your bitmap and you will have to clean the Scanlines , afterwards drawing will work es expected.
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;
Extract the icons and paint them to thm transparent bitmap
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:TempTransparent.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;
Using Delphi 5 or Delphi 7 with non transparent icons
If you are loading ICO's as shown with
ImageList1.Handle := ImageList_LoadImage(MainInstance, 'MyBitmap32', 16, ImageList1.AllocBy,
CLR_NONE, IMAGE_BITMAP, LR_CREATEDIBSECTION or LR_LOADTRANSPARENT);
The Icons itself do not contain transparency informations, all painting is done by the mask. So you could fill your Bitmap with a "magic" color here clFuchsia (C_R, C_G, C_B), paint your icons and set the Alpha channel for all Pixels not containg the "magic" color to 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:TempTransparent.bmp');
finally
BMP.Free;
end;
end;
ImageList component that ships with Delphi internally already stores all its Images in one large bitmap. You can access this bitmap though it's handle wihch you can retrieve by calling
ImageList1.GetImageBitmap
EDIT: After some thinking and trying I must admit that the approach I recomended is not good. Why? Accesing internal bitmap of ImageList is probably not the best idea as there seems to be some inconsistencies how image list treats its images between different Delphi versions. This means that any such code that works in current version of Delphi may no longer work in future versions.
Now if I only check the difference between Delphi 7 where ImageList images are stored in multiple lines and Delphi XE3 where ImageList images are stored in a single column it means that your code needs to take this into account.
Anywhay this is the approach I used for expoting the ImageList internal image contents to a file if anybody wants to further work on this approach:
var Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.Handle := ImageList1.GetImageBitmap;
Bitmap.SaveToFile('D:Proba.bmp');
Bitmap.ReleaseHandle;
Bitmap.Free;
end;
I created the GDI+ version that saves to a Bitmap or PNG.
The first trick is converting the ImageList to a GDI+ Bitmap:
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;
Once it's a Bitmap , you can save it to whatever format you prefer. I prefer image/png , but you can just as well save it to an 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.