ICO file format is an image file format for icons in Microsoft Windows. .ICO files contain one or more small images at multiple sizes and color depths. This function shows you how to extract the entire .ico file from an executable. Read more: http://en.wikipedia.org/wiki/ICO_%28file_format%29 { Coder: Xash Compiled: Delphi 10 Lite } Function PickIconDlgW(OwnerWnd: HWND; lpstrFile: PWideChar; var
nMaxFile: LongInt; var lpdwIconIndex: LongInt): LongBool; stdcall;
external 'SHELL32.DLL' index 62; implementation {
[WriteIcon] } 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; { [/WriteIcon] } procedure
TForm1.Image1Click(Sender: TObject); var FileName :
array[0..MAX_PATH - 1] of WideChar; Size, Index: LongInt;
hLargeIcon, hSmallIcon : HIcon; Stream: TFileStream; begin
Size := MAX_PATH;
StringToWideChar('%SystemRoot%\system32\Shell32.dll', FileName,
MAX_PATH); If PickIconDlgW(Self.Handle, FileName, Size, Index) Then
If (Index <> -1) Then If ExtractIconExW( FileName,
Index, hLargeIcon, hSmallIcon, 1) > 0 Then Begin
Stream := TFileStream.Create('icon.ico', fmCreate); try
WriteIcon(Stream, hLargeIcon); finally
Stream.Free; end;
Image1.Picture.LoadFromFile('icon.ico');
DestroyIcon(hLargeIcon); DestroyIcon(hSmallIcon); End; end; |
Delphi Basics - Free Delphi Source Code - Ultimate Programming Resource > Delphi Basics Snippets >