ذخیره آیکون با بیش از 256 رنگ

[Kambiz]

تصاویر 24/32 بیتی موجود در یک ImageList رو می‌خوام تک به تک بصورت آیکون ذخیره کنم اما شئ TIcon تصاویر رو بصورت 256 رنگ ذخیره می‌کنه.

چطوری می‌شه آیکونهای با بیش از 256 رنگ رو ذخیره کرد؟

راستی٬ از دلفی 6 و ویندوز XP استفاده می‌کنم.

[Delphi-Clinic]

حاج کامبیز اینو فعلا پیدا کردم داشته باش بازم می گردم:




procedure TForm1.Button1Click(Sender: TObject);
var
ICONSizeX : integer;
ICONSizeY : integer;
AndMask : TBitmap;
XOrMask : TBitmap;
ICONInfo : TICONInfo;
ICON : TICON;
begin
{Get the ICON size}
ICONSizeX := GetSystemMetrics(SM_CXICON);
ICONSizeY := GetSystemMetrics(SM_CYICON);

{Create the "And" mask}
AndMask := TBitmap.Create;
AndMask.Monochrome := true;
AndMask.Width := ICONSizeX;
AndMask.Height := ICONSizeY;

{Draw on the "And" mask}
AndMask.Canvas.Brush.Color := clWhite;
AndMask.Canvas.FillRect(Rect(0, 0, ICONSizeX, ICONSizeY));
AndMask.Canvas.Brush.Color := clBlack;
AndMask.Canvas.Ellipse(4, 4, ICONSizeX - 4, ICONSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(ICONSizeX * 2, ICONSizeY, AndMask);

{Create the "XOr" mask}
XOrMask := TBitmap.Create;
XOrMask.Width := ICONSizeX;
XOrMask.Height := ICONSizeY;

{Draw on the "XOr" mask}
XOrMask.Canvas.Brush.Color := ClBlack;
XOrMask.Canvas.FillRect(Rect(0, 0, ICONSizeX, ICONSizeY));
XOrMask.Canvas.Pen.Color := clRed;
XOrMask.Canvas.Brush.Color := clRed;
XOrMask.Canvas.Ellipse(4, 4, ICONSizeX - 4, ICONSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(ICONSizeX * 4, ICONSizeY, XOrMask);

{Create a ICON}
ICON := TICON.Create;
ICONInfo.fICON := true;
ICONInfo.xHotspot := 0;
ICONInfo.yHotspot := 0;
ICONInfo.hbmMask := AndMask.Handle;
ICONInfo.hbmColor := XOrMask.Handle;
ICON.Handle := CreateICONIndirect(ICONInfo);

{Destroy the temporary bitmaps}
AndMask.Free;
XOrMask.Free;

{Draw as a test}
Form1.Canvas.Draw(ICONSizeX * 6, ICONSizeY, ICON);

{Assign the application ICON}
Application.ICON := ICON;

{Force a repaint}
InvalidateRect(Application.Handle, nil, true);

{Free the ICON}
ICON.Free;
end;

[Kambiz]

حاج احمد٬ مثل اینکه سوال رو نخوندی! :?
من ذخیره آیکون 32 بیتی تو Stream یا فایل رو می‌خوام.

[Inprise]

حاج آقا (!) های محترم ،

سلام ! :wink:

بررسی کنید آیا این کامپوننت کمک میکنه یا خیر .

[Kambiz]

ممنون حاج اینپرایز! :heart:

این کامپوننت برای استفاده توسط من دو تا مشکل عمده داشت:
فقط آیکونهای 32 بیتی رو پشتیبانی می‌کنه
چیزی به عنوان Handle نداره

[Kambiz]

با تابع زیر، آیکون یا کروزر از 1 بیتی تا 32 بیتی رو می‌شه درست ذخیره کرد.


procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean = False);

const
RC3_STOCKICON = 0;
RC3_ICON = 1;
RC3_CURSOR = 2;

type
PCursorOrIcon = ^TCursorOrIcon;
TCursorOrIcon = packed record
Reserved: Word;
wType: Word;
Count: Word;
end;

type
PIconRec = ^TIconRec;
TIconRec = packed record
Width: Byte;
Height: Byte;
Colors: Word;
Reserved1: Word;
Reserved2: Word;
DIBSize: Longint;
DIBOffset: Longint;
end;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
Colors: Integer);
var
DS: TDIBSection;
Bytes: Integer;
begin
DS.dsbmih.biSize := 0;
Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
if Bytes = 0 then Abort // ERROR
else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
(DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
BI := DS.dsbmih
else
begin
FillChar(BI, sizeof(BI), 0);
with BI, DS.dsbm do
begin
biSize := SizeOf(BI);
biWidth := bmWidth;
biHeight := bmHeight;
end;
end;
case Colors of
2: BI.biBitCount := 1;
3..16:
begin
BI.biBitCount := 4;
BI.biClrUsed := Colors;
end;
17..256:
begin
BI.biBitCount := 8;
BI.biClrUsed := Colors;
end;
else
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
end;
BI.biPlanes := 1;
if BI.biClrImportant > BI.biClrUsed then
BI.biClrImportant := BI.biClrUsed;
if BI.biSizeImage = 0 then
BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;

procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; Colors: Integer);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, Colors);
if BI.biBitCount > 8 then
begin
InfoHeaderSize := SizeOf(TBitmapInfoHeader);
if (BI.biCompression and BI_BITFIELDS) <> 0 then
Inc(InfoHeaderSize, 12);
end
else
if BI.biClrUsed = 0 then
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
else
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * BI.biClrUsed;
ImageSize := BI.biSizeImage;
end;

function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
OldPal := 0;
DC := CreateCompatibleDC(0);
try
if Palette <> 0 then
begin
OldPal := SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
finally
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;

var
IconInfo: TIconInfo;
MonoInfoSize, ColorInfoSize: DWORD;
MonoBitsSize, ColorBitsSize: DWORD;
MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
CI: TCursorOrIcon;
List: TIconRec;
Length: Longint;
begin
FillChar(CI, SizeOf(CI), 0);
FillChar(List, SizeOf(List), 0);
GetIconInfo(Icon, IconInfo);
try
InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 0 {16 -> 0});
MonoInfo := nil;
MonoBits := nil;
ColorInfo := nil;
ColorBits := nil;
try
MonoInfo := AllocMem(MonoInfoSize);
MonoBits := AllocMem(MonoBitsSize);
ColorInfo := AllocMem(ColorInfoSize);
ColorBits := AllocMem(ColorBitsSize);
InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 0 {16 -> 0});
if WriteLength then
begin
Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
ColorBitsSize + MonoBitsSize;
Stream.Write(Length, SizeOf(Length));
end;
with CI do
begin
CI.wType := RC3_ICON;
CI.Count := 1;
end;
Stream.Write(CI, SizeOf(CI));
with List, PBitmapInfoHeader(ColorInfo)^ do
begin
Width := biWidth;
Height := biHeight;
Colors := biPlanes * biBitCount;
DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
DIBOffset := SizeOf(CI) + SizeOf(List);
end;
Stream.Write(List, SizeOf(List));
with PBitmapInfoHeader(ColorInfo)^ do
Inc(biHeight, biHeight); { color height includes mono bits }
Stream.Write(ColorInfo^, ColorInfoSize);
Stream.Write(ColorBits^, ColorBitsSize);
Stream.Write(MonoBits^, MonoBitsSize);
finally
FreeMem(ColorInfo, ColorInfoSize);
FreeMem(ColorBits, ColorBitsSize);
FreeMem(MonoInfo, MonoInfoSize);
FreeMem(MonoBits, MonoBitsSize);
end;
finally
DeleteObject(IconInfo.hbmColor);
DeleteObject(IconInfo.hbmMask);
end;
end;

به کد ذخیره آیکون در دلفی که نگاه کردم دیدم دلفی حداکثر می‌تونه آیکون رو بصورت 4 بیتی (16 رنگ) ذخیره کنه! :?
مثل اینکه بورلند کد مربوطه در دلفی یک رو بدون بازبینی تو بقیه ویرایشها کپی کرده چون برای رفع مشکل تنها نیاز به تعیین حداکثر تعداد رنگها (16) بود.

بازم از هر دو شما دوستان تشکر می‌کنم.