DELPHI AREA
MESSAGE BOARD
 
 FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   FavoritesFavorites   Watched TopicsWatched Topics     RegisterRegister 
 ProfileProfile   Log in to check your private messagesLog in to check your private messages   Log inLog in 

Extract Icon from external file

 
Post new topic   Reply to topic   printer-friendly view    DELPHI AREA Forum Index -> Delphi Programming
View previous topic :: View next topic  
Author Message
Codius
Member


Joined: 06 Jun 2006
Posts: 9
Location: Sweden
PostPosted: 21/10/06 22:22    Post subject: Extract Icon from external file Reply with quote
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:

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;

_________________
I've never let my schooling interfere with my education.
Back to top
View user's profile Send private message MSN Messenger
Kambiz
Administrator


Joined: 07 Mar 2003
Posts: 1044
Location: Tehran, Iran
PostPosted: 22/10/06 13:38    Post subject: Reply with quote
There is a small bug in Delphi prevents saving XP icons properly.

Code:
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;

_________________
Kambiz
Back to top
View user's profile Send private message Send e-mail Visit poster's website
Codius
Member


Joined: 06 Jun 2006
Posts: 9
Location: Sweden
PostPosted: 24/10/06 20:02    Post subject: Thanks you Reply with quote
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?
_________________
I've never let my schooling interfere with my education.
Back to top
View user's profile Send private message MSN Messenger
Johnny_Bit
Moderator


Joined: 15 Jun 2003
Posts: 274
PostPosted: 25/10/06 14:55    Post subject: Reply with quote
Hard Extract
Back to top
View user's profile Send private message Send e-mail Visit poster's website
Display posts from previous:   
Post new topic   Reply to topic   printer-friendly view    DELPHI AREA Forum Index -> Delphi Programming All times are GMT
Page 1 of 1

Add to favorites
 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum
You cannot attach files in this forum
You can download files in this forum


Powered by phpBB © 2001, 2005 phpBB Group