{http://www.awitness.org/delphi_pascal_tutorial/index.html} {this demo extracts and then saves icons without using delphi's crappy 'savetofile' function for an icon a few issues to note first, the routine is designed to save 16 color 32 by 32 icons you can however use the GetSystemMetrics function in the windows api to find out the width and height of the system icon and make modifications in the code below to save icons of another size should 32 by 32 not be correct for that system - the windows api will only work with icons of the size returned by function above most icon files only contain one 32 by 32 16 color icon and the system manufactures the small sized icon from this larger icon so the routine below only saves this single large icon also worth noting is that icon files include a palette but icons returned by the system have no palette handle being mapped to the system colors apparently therefore the routine below retrieves the system colors and gives the icon these as a palette more work could be done on this routine such as mentioned above but it does save 32 by 32 16 color icons it could be modified easily to save 256 color icons however the problem, not a trivial one to solve is in finding the color count of the icon when the palette is nil and the bitcount is set to pfDevice once these problems are solved the rest is trivial also note that delphi three displays the small icon in the image as a crappy looking large icon much like what happens when you use savetofile on an icon this is a problem that delphi 3 users will have to deal with in displaying and using small icons } unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ShellApi, Dialogs, ExtCtrls, StdCtrls; type PtrIconHeader = ^TIconHeader; TIconHeader = record idReserved: Word; {always 0} idType: Word; {always 1} idCount: Word; {total number of icon pics in file} end; TIconDirEntry = record bWidth: Byte; {ie: 16 or 32} bHeight: Byte; {ie: 16 or 32} bColorCount: Byte; {number of entires in pallette table below} bReserved: Byte; { not used = 0} wPlanes: Word; { not used = 0} wBitCount: Word; { not used = 0} dwBytesInRes: Longint; {total number bytes in images including pallette data XOR, AND and bitmap info header} dwImageOffset: Longint; {pos of image as offset from the beginning of file} end; TBitmapInfoHeader = record biSize: Longint; {size of tbitmapinfoheader} biWidth: Longint; {bitmap width} biHeight: Longint; (* height of bitmap, see notes *) biPlanes: Word; {always 1} biBitCount: Word; {number color bits 4 = 16 colors, 8 = 256 pixel is a byte} biCompression: Longint; {compression used, 0 } biSizeImage: Longint; (* size of the pixel data, see notes *) biXPelsPerMeter: Longint; {not used, 0 } biYPelsPerMeter: Longint; {not used, 0 } biClrUsed: Longint; {number of colors used, set to 0 } biClrImportant: Longint; {important colors, set to 0 } end; TForm1 = class(TForm) Button1: TButton; Button2: TButton; Label1: TLabel; Label2: TLabel; OpenDialog1: TOpenDialog; Edit1: TEdit; Image1: TImage; Image2: TImage; Button3: TButton; SaveDialog1: TSaveDialog; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); Procedure GetFilesIcon(FileName:string); procedure Button3Click(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); {Open File to find icons} begin If OpenDialog1.Execute then begin Edit1.Text := '-1'; GetFilesIcon(OpenDialog1.Filename); end; end; procedure TForm1.Button2Click(Sender: TObject); {get next icon} begin GetFilesIcon(OpenDialog1.FileName); end; Procedure TForm1.GetFilesIcon(FileName:string); var IconPos : Cardinal; NumIcons, PLargeIcon, PSmallIcon : HICON; begin try IconPos := StrToInt(Edit1.Text) + 1; {init -1 for pass 1} If FileExists(FileName) then begin Label1.Caption := 'Opened File : ' + FileName; {get total number of icons ExtractIconEx returns a small icon created even when only only one large icon actually exists in the file pass function -1 iconpos, and 0 0 for Var HIcons to signal function that it is to return the number of icons in the file} PLargeIcon := 0; PSmallIcon := 0; NumIcons := ExtractIconEx(PChar(FileName), -1, PLargeIcon, PSmallIcon, 1); If NumIcons = 0 then begin MessageDlg('No icons in this file' + chr(13) + 'Try finding extension in registry', mtError, [mbok],0); Label2.Caption := 'No Icons in this file'; end else begin Label2.Caption := 'TOTAL NUMBER OF ICONS IN FILE : ' + IntToStr(NumIcons); {did user put invalid integer into edit position box?} {note Iconpos starts at zero, NumIcons starts at 1} If IconPos > NumIcons then IconPos := NumIcons -1; If NumIcons = IconPos then IconPos := 0; {rollover count} {now get large, small icons at icon pos} ExtractIconEx(PChar(FileName), IconPos, PLargeIcon, PSmallIcon, 1); {if icon pic currently has handle then release resources first} If not (Image1.Picture.Icon.Empty) then Image1.Picture.Icon.ReleaseHandle; If not (Image2.Picture.Icon.Empty) then Image2.Picture.Icon.ReleaseHandle; Image1.Picture.Icon.Handle := PSmallIcon; Image2.Picture.Icon.Handle := PLargeIcon; {update edit box } Edit1.Text := IntToStr(IconPos); end; {num icons <> 0} end; {if fileexists} except {string did not convert to integer} MessageDlg('Enter a valid integer in the Edit Box!', mtError, [mbok], 0); end; {try} end; {procedure} procedure TForm1.Button3Click(Sender: TObject); {save an icon} var i , j, y: integer; IconFile : File; {untyped file for icon manipulation} PIconHeader : PtrIconHeader; {header of icon file} IconDirEntry : TIconDirEntry; {dynamic array declaration} BitMapInfoHeader : TBitmapInfoHeader; {ditto} RedByte, BlueByte, GreenByte : Byte; AWord : Word; Amt, Rowlength : Integer; {var variable, total bytes returned by blockread} AByte : Byte; ALongint : Longint; IconInfo : TIconInfo; {icon info structure used by API} IconHandle :HIcon; {handle to an icon} IconPalette : PLogPalette; {logical pallette structure for icon} XORBitMap, ANDBitMap : TBitmap; pb : Pointer; dc :HDC; PalNum : Word; begin {get device context to find system palette entries} DC := CreateCompatibleDC(0); {get the XOR color bitmap and the monochrome AND bitmap since it seems that most ico files contain one 32 by 32 large icon and ExtractIconEx creates a small icon from scratch the following example saves the current large icon in an ico file} IconHandle := Image2.Picture.Icon.Handle; {use GetIconInfo to return the handles to XOR and AND bitmaps in IconInfo structure} If GetIconInfo(IconHandle, IconInfo) then begin {next construct all the icon structures manually} XORBitMap := TBitmap.Create; ANDBitMap := TBitmap.Create; {the XORBitmap will turn out to be pixelformat pfDevice this routine will only save a 16 bit color icon} XORBitmap.Handle := IconInfo.hbmColor ; ANDBitmap.Handle := IconInfo.hbmMask ; XORBitmap.PixelFormat := pf4bit; ANDBitmap.PixelFormat := pf1bit; New(PIconHeader); {use pointer to create new record} {Construct Ico header record} PIconHeader^.idReserved := 0; PIconHeader^.idType := 1; {set to one for an icon} PIconHeader^.idCount := 1; {saving one large icon} {this is followed by idcount number of IconDirectory structures in this example just one} {for i := 0 to PIconHeader^.idCount - 1 do begin if more than one this loop must be worked into the code, for now just i := 0 for one icon} {Width} IconDirEntry.bWidth := XORBitmap.Width ; {Height} IconDirEntry.bHeight := XORBitmap.Height ; {Color Count note that rarely an icon will have 24 bit format, I have seen just one on my computer, this routine saves 16 color icons} { case XORBitmap.PixelFormat of pf1Bit : IconDirEntry.bColorCount := 2; pf4Bit : IconDirEntry.bColorCount := 16; pf8Bit : IconDirEntry.bColorCount := 0; {256 or more colors} { end; } IconDirEntry.bColorCount := 16; {Reserved} IconDirEntry.bReserved := 0; {Planes} IconDirEntry.wPlanes := 0; {not used} {BitCount} IconDirEntry.wBitCount := 0; {not used} {construct BitMapInfoHeader, one in this example} BitMapInfoHeader.biSize := 40; {size of header itself} BitMapInfoHeader.biWidth := XORBitMap.Width ; BitMapInfoHeader.biHeight := XORBitMap.Height + ANDBitmap.Height ; BitMapInfoHeader.biPlanes := 1; {always 1} {this demo only saves 16 color 4 bit pixelformat icons} BitMapInfoHeader.biBitCount := 4; BitMapInfoHeader.biCompression := 0 ; {not used} BitMapInfoHeader.biXPelsPerMeter := 0; {not used} BitMapInfoHeader.biYPelsPerMeter := 0; {not used} BitMapInfoHeader.biClrUsed := 0; {not used} BitMapInfoHeader.biClrImportant := 0; {not used} BitMapInfoHeader.biSizeImage := (XORBitmap.Width * XORBitmap.Height * BitMapInfoHeader.biBitCount) div 8; {a zero color count indicates 256 or more colors - more if pixelformat > 8 icon files with more than 256 colors do not include a palette} If IconDirEntry.bColorCount = 0 then PalNum := 256 {# palette entries} else PalNum := IconDirEntry.bColorCount; IconPalette := nil; {get mem for ColorCount number of palette entries, get disk data, create} GetMem(IconPalette, sizeof(TLogPalette) + sizeof(TPaletteEntry) * PalNum); IconPalette.palVersion := $300; {the current standard} IconPalette.palNumEntries := PalNum; {retrieve the BitMap pallette into the TLogPalette structure since the palette handle of the icons returned will be zero use DC to get the entries in the system color palette } Amt := GetSystemPaletteEntries(dc, 0, PalNum, IconPalette.palPalEntry); {if function succeeds then amt = palnum = colorcount} {Bytes in Resource = Header + Palette + XORBitmap + ANDBitmap} IconDirEntry.dwBytesInRes := sizeof(TBitMapInfoHeader) + (sizeof(TPaletteEntry) * Palnum) + ((XORBitmap.Width * XORBitmap.Height * BitMapInfoHeader.biBitCount) div 8) + ((ANDBitMap.Width * ANDBitMap.Height) div 8); {Image Offset from begin of file the following calculation is only for one icon the structure of the file is TIconHeader, idcount number of IconDirEntries, followed by each icon consisting of Bitmapinfo header, palette, xorbitmap, andbitmap, so the first icon starts after all the IconDirentries, the second starts after the direntries plus the IconDirEntry.dwBytesinRes which is the total size of the first icon, etc etc } IconDirEntry.dwImageOffset := sizeof(TIconHeader) + (sizeof(TIconDirEntry) * PIconHeader.idCount); {add onto this the accumulated bytes in res of all the icon files preceding the icon for which you want to set the image offset in the directory for that icon} {save to disk} If SaveDialog1.Execute then begin AssignFile(IconFile, SaveDialog1.Filename); Rewrite(IconFile, 1); {an untyped binary file set to 1 byte} {write the file header because of problems due to record alignment and word boundaries and so on, the writing is not done from the record itself in this demo, after fruitless hours searching the net for info if you are aware of how to calculate the record pos for a blockread so things will always work right you can make the adjustments in the code below and skip a step on each write} Aword := PIconHeader^.idReserved; Blockwrite(IconFile, AWord, 2, Amt); AWord := PIconHeader^.idType; Blockwrite(IconFile, AWord, 2, amt); AWord := PIconHeader^.idCount; Blockwrite(IconFile, AWord, 2, amt); {write the IconDirEntries for i := 0 to idcount -1 etc} {because record structures must be on a '4 byte boundary' just copy the record, the size of the record doesn't always work reliably} AByte := IconDirEntry.bWidth; Blockwrite(IconFile, AByte, 1, amt); AByte := IconDirEntry.bHeight; Blockwrite(IconFile, AByte , 1, amt); AByte := IconDirEntry.bColorCount; Blockwrite(IconFile, AByte , 1, amt); AByte := IconDirEntry.bReserved; Blockwrite(IconFile, AByte , 1, amt); AWord := IconDirEntry.wPlanes; Blockwrite(IconFile, AWord , 2, amt); AWord := IconDirEntry.wBitCount; Blockwrite(IconFile, AWord , 2, amt); ALongInt := IconDirEntry.dwBytesInRes; Blockwrite(IconFile, ALongInt , 4, amt); ALongInt := IconDirEntry.dwImageOffset; Blockwrite(IconFile, ALongInt , 4, amt); {now that all the direntries are written begin writing each icon starting with the bitmapinfo header} ALongInt := BitMapInfoHeader.biSize; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biWidth; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biHeight; BlockWrite(IconFile, ALongInt , 4, amt); AWord := BitMapInfoHeader.biPlanes; BlockWrite(IconFile, AWord , 2, amt); AWord := BitMapInfoHeader.biBitCount; BlockWrite(IconFile, AWord , 2, amt); ALongInt := BitMapInfoHeader.biCompression; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biSizeImage; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biXPelsPerMeter; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biYPelsPerMeter; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biClrUsed; BlockWrite(IconFile, ALongInt , 4, amt); ALongInt := BitMapInfoHeader.biClrImportant; BlockWrite(IconFile, ALongInt , 4, amt); {now save the four bytes of each entry in the Palette data} {***********if bitcount <=8 this demo only saves 16 color icons} for j := 0 to Palnum - 1 do begin RedByte := IconPalette.palPalEntry[j].peRed ; GreenByte := IconPalette.palPalEntry[j].peGreen ; BlueByte := IconPalette.palPalEntry[j].peBlue; Abyte := IconPalette.palPalEntry[j].peFlags; {note that bitmaps are saved 'upside down' and have the RGB palette 'upside down' arranged as blue, green, red, (BGR) and certain windows functions seem to ignore palettes altogether, so if results have a weird color the problem is here} BlockWrite(IconFile, RedByte, 1, Amt); BlockWrite(IconFile, GreenByte, 1, Amt); BlockWrite(IconFile, BlueByte, 1, Amt); BlockWrite(IconFile, AByte, 1, Amt); {The flag byte} end; {this is followed by the pixel data for the XORBitmap} RowLength := (IconDirEntry.bWidth * BitMapInfoHeader.biBitCount) div 8; {the bitmap is stored upside down} for y := IconDirEntry.bHeight - 1 downto 0 do begin {get pointer to address of first byte on row} pb := XORBitMap.ScanLine[y]; BlockWrite(IconFile, pb^, RowLength, amt); end; {finally the data is stored for the monochrome ANDBitMap} RowLength := IconDirEntry.bWidth div 8; for y := IconDirEntry.bHeight - 1 downto 0 do begin {get ^ address of first byte on row} pb := ANDBitMap.ScanLine[y]; Blockwrite(IconFile, pb^, RowLength, amt); end; {the IconFile has been written to disk} CloseFile(IconFile); MessageDlg('dun', mterror, [mbok],0); end; {if savedialog executed} end; {if iconhandle returned} DeleteDC(DC); end; {procedure} procedure TForm1.FormCreate(Sender: TObject); begin Form1.Caption := 'Extract and Save Icons'; Button1.Caption := 'Open file'; Button2.Caption := 'Next Icon'; Button3.Caption := 'Save Icon'; Edit1.Text := '-1'; end; end.