Extract Shell Icon

uses ShellApi

//

Function PickIconDlgW(OwnerWnd: HWND; lpstrFile: PWideChar; var nMaxFile: LongInt;
var lpdwIconIndex: LongInt): LongBool; stdcall; external 'SHELL32.DLL' index 62;
  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);
      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);
        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); 
        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;

Beispiel :

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;