// Icons aus Bitmaps erstellen. // VARIANTE 1 // Getestet mit D2010 unter W7 var
ic: TIcon;
procedure TForm1.FormCreate(Sender: TObject);
begin
ic := TIcon.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(ic);
end;
function BitmapIcon(Bitmap: TBitmap; Transparenz: TColor): TIcon;
begin
with TImageList.CreateSize(Bitmap.Width, Bitmap.Height) do
begin
try
AllocBy := 1;
AddMasked(Bitmap, Transparenz);
Result := TIcon.Create;
try
GetIcon(0, Result);
except
Result.Free;
end;
finally
Free;
end;
end;
end;
// Beispielaufruf transparentes Icon
procedure TForm1.Button1Click(Sender: TObject);
begin
with Image1.Picture do
ic := BitmapIcon(Bitmap, Bitmap.Canvas.Pixels[0, 0]);
Canvas.Draw(10, 10, ic);
end;
// Beispielaufruf ohne Transparenz
procedure TForm1.Button2Click(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
Bmp.LoadFromFile('C:\Test.bmp');
ic := BitmapIcon(Bmp, -1);
ic.SaveToFile('C:\Test.ico');
FreeAndNil(Bmp); ;
end;
// ---------------------------------------- // VARIANTE 2 // Erstellen
von Icons aus einem Paletten-Bitmap type
TICONDIRENTRY = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWord;
dwImageOffset: DWord;
end;
TIcondir = packed record
idReserved: Word;
idType: Word;
idCount: Word;
IdEntrys: TICONDIRENTRY;
end;
procedure makeico(bild: TBitmap; icon: string; transparent: boolean;
cx, cy, x, y: integer);
var
cc: byte;
ts: TStream;
Farbe: TColor;
pdat: pointer;
TID: TIconDir;
bm, bmm: TBitmap;
MPBI: PBitmapInfo;
BSize, IHS, MSize: DWord;
maskbuffer: pointer;
Farbtiefe, bc: Word;
i, j, pa: integer;
TBI: TBitmapInfoHeader;
Pltte: array[0..255] of TPaletteEntry;
begin
if not (bild.pixelformat in [pf1bit, pf4bit, pf8bit]) then begin
showmessage('Sorry, diese Farbtiefe wird nicht unterstützt!');
exit;
end;
bm := TBitmap.create;
bmm := TBitmap.create;
bm.width := cx;
bm.height := cy;
bm.pixelformat := bild.pixelformat;
case bm.pixelformat of
pf1bit: begin Farbtiefe := 1; pa := 8; cc := 2; bc := 0; end;
pf4bit: begin Farbtiefe := 4; pa := 64; cc := 16; bc := 0; end;
pf8bit: begin Farbtiefe := 8; pa := 1024; cc := 0; bc := 8; end;
end;
bm.palette := copypalette(bild.palette);
bm.canvas.stretchdraw(rect(0, 0, bm.width, bm.height), bild);
Farbe := bm.canvas.pixels[x, y];
bmm.assign(bm);
bmm.mask(Farbe);
bmm.pixelformat := pf1bit;
GetDIBSizes(bmm.handle, IHS, MSize);
maskBuffer := AllocMem(MSize);
MPBI := AllocMem(IHS);
if transparent then begin
for i := 0 to pred(bm.width) do
for j := 0 to pred(bm.height) do
if bm.canvas.pixels[i, j] = Farbe then
bm.canvas.pixels[i, j] := 0;
with MPBI^.bmiHeader do begin
biSize := sizeof(TBI);
biWidth := cx;
biHeight := cy;
biPlanes := 1;
biBitCount := 1;
biCompression := 0;
biSizeImage := MSize;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
GetDIBits(bmm.canvas.handle, bmm.handle,
0, bmm.height, maskBuffer, MPBI^, DIB_RGB_COLORS);
end;
bmm.free;
freemem(MPBI);
GetDIBSizes(bm.handle, IHS, BSize);
getmem(pdat, BSize);
ts := TMemoryStream.Create;
bm.savetostream(ts);
ts.Seek(sizeof(TBI) + 14, 0);
ts.Read(Pltte, pa);
ts.Read(pdat^, BSize);
ts.free;
bm.free;
TBI.biSize := sizeof(TBI);
TBI.biWidth := cx;
TBI.biHeight := cy * 2;
TBI.biPlanes := 1;
TBI.biBitCount := Farbtiefe;
TBI.biCompression := 0;
TBI.biSizeImage := BSize + MSize;
TBI.biXPelsPerMeter := 0;
TBI.biYPelsPerMeter := 0;
TBI.biClrUsed := 0;
TBI.biClrImportant := 0;
TID.idreserved := 0;
TID.idType := 1;
TID.idCount := 1;
TID.identrys.bWidth := cx;
TID.identrys.bHeight := cy;
TID.identrys.bColorCount := cc;
TID.identrys.bReserved := 0;
TID.identrys.wPlanes := 1;
TID.identrys.wBitCount := bc;
TID.identrys.dwBytesInRes := BSize + pa + MSize + sizeof(TBI);
TID.identrys.dwImageOffset := sizeof(TID);
ts := TFileStream.Create(icon, fmCreate);
ts.Write(TID, sizeof(TID));
ts.Write(TBI, sizeof(TBI));
ts.Write(Pltte, pa);
ts.Write(pdat^, BSize);
ts.Write(maskBuffer^, MSize);
ts.Free;
freemem(pdat);
freemem(maskBuffer);
end;
// Beispielaufruf
// 31 und 0 legen einen Punkt fest, der die transparente Farbe
// im fertigen Icon (nicht im Ursprungsbild) bestimmt.
// Nur relevant, wenn "transparent = true" ist
procedure TForm1.CButton1Click(Sender: TObject);
var
bm: tbitmap;
transparent: boolean;
begin
bm := TBitmap.create;
transparent := true;
bm.loadfromfile('c:\test.bmp');
makeico(bm, 'c:\test.ico', transparent, 32, 32, 31, 0);
bm.free;
end;
type
TICONDIRENTRY = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWord;
dwImageOffset: DWord;
end;
TIcondir = packed record
idReserved: Word;
idType: Word;
idCount: Word;
IdEntrys: TICONDIRENTRY;
end;
procedure makeicoTrue
(Bild: TBitmap; Icon: string; Transparent: boolean; cx, cy, x, y: integer);
var
ts: TStream;
Farbe: TColor;
TID: TIconDir;
i, j: integer;
bm, bmm: TBitmap;
TBI: TBitmapInfoHeader;
PBI, MPBI: PBitmapInfo;
bmBuffer, maskBuffer: Pointer;
IHS, MIHS, ImageSize, MSize: DWord;
begin
bm := TBitmap.create;
bmm := TBitmap.create;
bm.width := cx;
bm.height := cy;
bm.pixelformat := pf24bit;
bm.canvas.stretchdraw(rect(0, 0, bm.width, bm.height), Bild);
Farbe := bm.canvas.pixels[x, y];
bmm.assign(bm);
bmm.mask(Farbe);
GetDIBSizes(bmm.handle, MIHS, MSize);
maskBuffer := AllocMem(MSize);
MPBI := AllocMem(MIHS);
if Transparent then begin
for i := 0 to bm.width - 1 do
for j := 0 to bm.height - 1 do
if bm.canvas.pixels[i, j] = Farbe then
bm.canvas.pixels[i, j] := 0;
with MPBI^.bmiHeader do begin
biSize := sizeof(TBI);
biWidth := cx;
biHeight := cy;
biPlanes := 1;
biBitCount := 1;
biCompression := 0;
biSizeImage := MSize;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
GetDIBits(bmm.canvas.handle, bmm.handle,
0, bmm.height, maskBuffer, MPBI^, DIB_RGB_COLORS);
end;
bmm.free;
freemem(MPBI);
GetDIBSizes(bm.handle, IHS, ImageSize);
PBI := AllocMem(IHS);
bmBuffer := AllocMem(ImageSize);
with PBI^.bmiHeader do begin
biSize := sizeof(TBI);
biWidth := cx;
biHeight := cy;
biPlanes := 1;
biBitCount := 24;
biCompression := 0;
biSizeImage := ImageSize;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
GetDIBits(bm.canvas.handle, bm.handle,
0, bm.height, bmBuffer, PBI^, DIB_RGB_COLORS);
bm.free;
freemem(PBI);
TBI.biSize := sizeof(TBI);
TBI.biWidth := cx;
TBI.biHeight := cy * 2;
TBI.biPlanes := 1;
TBI.biBitCount := 24;
TBI.biCompression := 0;
TBI.biSizeImage := Imagesize;
TBI.biXPelsPerMeter := 0;
TBI.biYPelsPerMeter := 0;
TBI.biClrUsed := 0;
TBI.biClrImportant := 0;
TID.idReserved := 0;
TID.idType := 1;
TID.idCount := 1;
TID.identrys.bWidth := cx;
TID.identrys.bHeight := cy;
TID.identrys.bColorCount := 0;
TID.identrys.bReserved := 0;
TID.identrys.wPlanes := 1;
TID.identrys.wBitCount := 24;
TID.identrys.dwBytesInRes := sizeof(TBI) + Imagesize + MSize;
TID.identrys.dwImageOffset := Sizeof(TID);
ts := TFileStream.Create(Icon, FMCreate);
ts.Write(TID, sizeof(TID));
ts.Write(TBI, sizeof(TBI));
ts.Write(bmBuffer^, Imagesize);
ts.Write(maskBuffer^, MSize);
ts.Free;
freemem(maskBuffer);
freemem(bmBuffer);
end;
// Beispielaufruf
// die letzten beiden Nullen legen einen Punkt fest, der die transparente
// Farbe im fertigen Icon (nicht im Ursprungsbild) bestimmt.
procedure TForm1.CButton1Click(Sender: TObject);
var
bm: tbitmap;
begin
bm := TBitmap.create;
bm.loadfromfile('c:\test.bmp');
makeicoTrue(bm, 'c:\test.ico', true, 32, 32, 0, 0);
bm.free;
end;
 |
