Delphi - wypakowanie ikonki z EXE do ICO

0

Hmm... wrzuciłem temat na forum Delphi, ale jak na razie głucha cisza...
Szukam sposobu, żeby wypakować ikonkę z pliku EXE / DLL do pliku ICO z zachowaniem palety kolorów [!!!]

Robię tak:

Var TempIcon: TIcon;
{...}
TempIcon:=TIcon.Create;
TempIcon.Handle:=ExtractIcon(Handle, 'c:\windows\explorer.exe', 0);
Image1.Picture.BitMap.Canvas.Draw(0,0,TempIcon);
Image1.Picture.Graphic.SaveToFile('c:\1.bmp');

Zapis do BMP działa; przez Canvas.Draw na formatce również wyświetla się bez problemu (kolory OK)...
Ale z ICO niestety już nie mam pojęcia, co zrobić, bo wszelkie logiczne sposoby dają efekt w postaci 16-kolorowej ikonki......
[ Funkcja ExtractIconEx daje te same efekty... :-[ ]

TempIcon.SaveToFile('c:\1.ico');

=> zapis z paletą 16 kolorów

Image2.Picture.Graphic.SaveToFile('c:\2.ico'); 

=> zapis w nieprawidłowym formacie....

Image2.Picture.SaveToFile('c:\2.ico'); 

=> zapis w nieprawidłowym formacie....

To o dziwo nie takie proste jak by się mogło wydawać....
Jeśli ktoś ma pojęcie jak to zrobić / jakieś źródłówki, to byłbym wdzięczny za pomoc... Rzeszukałem Google, ale na trop niczego pomocnego jak na razie nie wpadłem... Widziałem gdzieś parę komponentów, ale żaden nie ma źródłówek :/

Z góry dziękuję za zainteresowanie tematem :-)

0

A API dotyczące zasobów? W końcu ikonki siedzą w zasobach.

0
CyberKid napisał(a)

A API dotyczące zasobów? W końcu ikonki siedzą w zasobach.

No... też tak próbowałem, ale się okazuje, że nie działa ze wszystkimi plikami...
Powody? :

Standardowe wypakowanie zasobów wypróbowałem jako pierwsze - listing typu RT_GROUP_ICON + wypakowanie pierwszej grupy - działa ładnie i pięknie... do pewnego momentu...

-pierwszą rzeczą, jaką trzeba zrobić jest dostanie uchwytu do pliku przez LoadLibrary().
No i jest pierwszy kłopot - tą procedurą da się tylko załadować plik i dostać jego uchwyt tylko jeśli spełnia standard WinPE - próba załadowania czegokolwiek innego - np. głupiego C:\WINDOWS\Calc.exe już się wysypuje... (tylko się zastanawiam, jakim sposobem otwiera go ResHack...)

-druga sprawa - niektóre programy są skompresowane (UPX, etc.) i nijak z nich zasobów wyciągnąć się nie da (nawet ResHack potrafi tylko zrobić enumerację, a przy próbie odczytu wywala błąd)... A jednak Windoza wyświetla ikonki tych programów !

Drugim sposobem, który testowałem były funkcje z API do obsługi ikon - ExtractIcon, ExtractIconEx, ImageList_AddIcon, LookupIconIdFromDirectory, LoadImage, SHGetFileInfo...
Kiedy próbuję wyświetlić ikonkę / zapisać do TIcon jest wszystko OK... ale przy próbie zapisu na dysk znów są cuda - jak byś nie próbował zawsze po zapisie plik ICO będzie miał okrojoną paletę do 16 kolorów, albo będzie niezgodny z formatem...

Właśnie po 2 dniach poszukiwań na Googlach wyczytałem, że...... w Unicie obsługującym ikonki w Delphi jest dziura (a raczej z góry nałożone ograniczenie) - zapis ikon tylko w 16 kolorach..... :|
Dziwię się, że prawie nikt nigdzie o tym nie pisze...

Cóż.... więc szukam dalej jakiegoś sposobu...

0

LoadLibrary używa się tylko po to, aby móc uruchamiać funkcje. Do grafiki lepiej użyć LoadLibraryEx z flagą DONT_RESOLVE_DLL_REFERENCES - wtedy możesz załadować nawet takiego oporniaka jak ntoskrnl.exe.

ResHacker robi to całkowicie po swojemu - odczytuje nagłówki pliku prosto z pliku.

Windows User Interface Technical Articles
Icons in Win32
Tu masz szczegółowo opisane jak ikony są przechowywane w zasobach i jak je skopiować.

0
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;

Z pamięci lece więc mogą być błędy

1 użytkowników online, w tym zalogowanych: 0, gości: 1, botów: 0