Extract Complete Icon [All Sizes]

posted 16 Mar 2010, 08:02 by Delphi Basics
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;
Comments