DELPHI AREA Forum

I've been trying to extract the icon from an external file and save it to a .ico for a while and I've got it to extract the icon and use it as Application.Icon - this works and everything looks just fine. But when I try to save the icon to a file it's saved to a crappy format with nearly no colors.. is there a way to fix this, or is it a limitation in delphi due to some problems similair to PNG/GIF etc?

this is the code I've been trying..

Code: Select all

Var
  Icon        : TIcon;
  IconHandle  : HIcon;
Begin
  Icon := TIcon.Create;
  Try
   iconHandle := ExtractIcon(Application.Handle, 'C:\WINDOWS\notepad.exe', 0) ;
   Icon.Handle := iconHandle;
   Icon.SaveToFile('D:\notepad.ico');
   Application.Icon := Icon;
  Finally
   Icon.Free;
  End;
End;


There is a small bug in Delphi prevents saving XP icons properly.

Code: Select all

procedure SaveIconToFile(Icon: TIcon; const FileName: String);

  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;

var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
  try
    WriteIcon(Stream, Icon.Handle);
  finally
    Stream.Free;
  end;
end;

This worked better then the one I had, but still it doesn't return "perfect" icons, they are very pixel-like and doesn't look as good as the original. Anyway to fix this aswell?

Hard Extract