Extract Complete Icon [All Sizes]

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;