{http://www.awitness.org/delphi_pascal_tutorial/index.html} {this demo reads an icon file - some of the structures declared in the API follow} {TICONINFO record for use with Windows API routines} {if the function returns bitmaps the handles are returned in the last two fields of the record and if the function requires handles they are passed in these fields} {TIconInfo = record fIcon : boolean; {true = icon, false = cursor} { xHotspot : longint; {not used for icon, hot spot of cursor} { yHotspot : longint; {not used for icon} { hbmMask : HBITMAP; {handle to black and white AND mask passed or returned} { hbmColor : HBITMAP; {handle to color XOR mask passed or returned} {end; } {Logical pallette structure needed for Windows API} {the tagLogPalette structure tagLogPalette = record palVersion : word; { $300 hex} { palNumEntries : word; {IconDirEntry.bColorCount see below} { palPalEntry : PALETTEENTRY; {first member of array structures} {end; {TRGBQuad see below} { TRGBQuad is 4 bytes total bytes in pallette = 4 * TIconDirEntry.bColorCount } { structure of a entry in Windows API PaletteEntry structure TRGBQuad = record rgbRed: Byte; (* red component of color *) rgbGreen: Byte; (* green component of color *) rgbBlue: Byte; (* blue component of color *) rgbReserved: Byte; (* reserved, 0 *) end; } {I am still looking for info on REALLY freeing the memory used by graphics...this is trivial if you just have a bitmap to free but what happens when the bitmap is associated with an imagelist or an image? Don't take my word for it on the FreeGraphics code another issue concerning this code is the RGB quad structure on disk - some weird things have been happening in this area and if there are color problems swap the get blue and get red part also if you have the 'Windows Update' icon in your windows directory open it and you will find that several icons do not return an AND mask thus producing weird results and the last icon is colored strangely, while the bitmap is normal} unit unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ScktComp, ShellApi; type {structure of icon file on disk} PtrIconHeader = ^TIconHeader; TIconHeader = record idReserved: Word; {always 0} idType: Word; {always 1} idCount: Word; {total number of icon pics in file} end; {idCount entries of TIconDirEntry follow with info on each icon } 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; {Bitmap info header begins each bitmap in the icon file} TBitmapInfoHeader = record biSize: Longint; {size of tbitmapinfoheader} biWidth: Longint; {bitmap width} biHeight: Longint; (height of bitmap) 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; {next follows the pallette data as RGB quads and then the bit data for the color XOR and black and white AND bitmaps} TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; Memo1: TMemo; Image1: TImage; Image2: TImage; Image3: TImage; Label1: TLabel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Button3: TButton; OpenDialog1: TOpenDialog; Memo2: TMemo; Button4: TButton; Image4: TImage; Label5: TLabel; Label6: TLabel; Label7: TLabel; Button2: TButton; procedure Button1Click(Sender: TObject); {open file for windows API} procedure Button2Click(Sender: TObject); {open for direct disk read} procedure OpenIconFile; procedure FreeTheArrays; procedure ReadIconFileInfo(FileName : string); procedure GetIconDirEntries(w : Word); procedure GetBitMapInfoHeaders(w : Word); procedure Button3Click(Sender: TObject); {sequentially display icons} procedure ShowIcon(w : word); {using Windows API ExtractIcon} procedure FreeGraphics; {still uncertain about this one} {memo writing procedures} procedure WriteDirEntryToMemo(i : integer); Procedure WriteBitMapInfoToMemo(i : integer); procedure WriteCalcToMemo(i : word); {extract icon data directly from disk} procedure ShowIconUserRoutine(w : Word); {quit program button} procedure Button4Click(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; IconFile, PalFile : File; {untyped file for icon manipulation} PIconHeader : PtrIconHeader; {header of icon file} IconDirEntry : array of TIconDirEntry; {dynamic array declaration} BitMapInfoHeader : array of TBitmapInfoHeader; {ditto} RedByte, BlueByte, GreenByte : Byte; AWord : Word; Amt : 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} UserRoutine : Boolean; {use API (false) or use user written routine (true)} implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin UserRoutine := false; OpenIconFile; Button3.Enabled := true; end; procedure TForm1.Button2Click(Sender: TObject); begin UserRoutine := true; OpenIconFile; Button3.Enabled := true; end; procedure TForm1.OpenIconFile; begin If OpenDialog1.Execute then begin Edit1.Text := '-1'; AssignFile(IconFile, OpenDialog1.FileName); Reset(IconFile, 1); {set record size to 1 byte} ReadIconFileInfo(OpenDialog1.FileName); end; end; procedure TForm1.FreeTheArrays; begin Dispose(PIconHeader); {free file header record} Finalize(IconDirEntry); {deallocate dynamic array} Finalize(BitMapInfoHeader); {ditto} end; procedure TForm1.ReadIconFileInfo(FileName : string); begin {Get ICON FILE HEADER **********************************************} New(PIconHeader); {use pointer to create new record} {get header record fields from Icon file} BlockRead(IconFile, AWord, 2, Amt); PIconHeader^.idReserved := AWord; BlockRead(IconFile, AWord, 2, Amt); PIconHeader^.idType := AWord; {always 1} BlockRead(IconFile, AWord, 2, Amt); PIconHeader^.idCount := Aword; {number of icons in this icon file} {Show Header Record fields in header memo} Memo1.Clear; {previous entries} Memo1.Lines.Append('idReserved : ' + IntToStr(PIconHeader^.idReserved)); Memo1.Lines.Append('idType : ' + IntToStr(PIconHeader^.idType)); Memo1.Lines.Append('idCount : ' + IntToStr(PIconHeader^.idCount)); {Get idCount Number of ICON DIRECTORY ENTRIES **************************} { create dynamic array of IconDirEntry records equal to the size of idCount number of Icons in file } SetLength(IconDirEntry, sizeof(TIconDirEntry) * PIconHeader^.idCount); {count # of records} {dynamic arrays are indexed starting from 0 to count-1} GetIconDirEntries(PIconHeader^.idCount - 1); {fill the array start at 0} {use info from idCount and Dir entries to fetch bitmap info headers} SetLength(BitMapInfoHeader, sizeof(TBitMapInfoHeader) * PIconHeader^.idCount); {set array len # icons} GetBitMapInfoHeaders(PIconHeader^.idCount - 1); {indexed from 0} {records are stored in memory} {from this point on all that remains is the actual bit map data which will be loaded from disk as needed} CloseFile(IconFile); end; procedure TForm1.GetIconDirEntries(w : word); var i : word; begin for i := 0 to w do begin {get idCount dir emtry records} BlockRead(IconFile, AByte, 1, Amt); {Width} IconDirEntry[i].bWidth := AByte; BlockRead(IconFile, AByte, 1, Amt); {Height} IconDirEntry[i].bHeight := AByte; BlockRead(IconFile, AByte, 1, Amt); {Color Count} IconDirEntry[i].bColorCount := AByte; BlockRead(IconFile, AByte, 1, Amt); {Reserved} IconDirEntry[i].bReserved := AByte; BlockRead(IconFile, AWord, 2, Amt); {Planes} IconDirEntry[i].wPlanes := AWord; BlockRead(IconFile, AWord, 2, Amt); {BitCount} IconDirEntry[i].wBitCount := AWord; BlockRead(IconFile, ALongInt, 4, Amt); {Bytes in Resource} IconDirEntry[i].dwBytesInRes := ALongint; BlockRead(IconFile, ALongInt, 4, Amt);{Image Offset from begin of file} IconDirEntry[i].dwImageOffset := Alongint; end; {for} end; {procedure} {info to obtain the Bitmap info headers is found in corresponding dir entry} procedure TForm1.GetBitMapInfoHeaders(w : Word); var i : Word; begin for i := 0 to w do begin {idcount # of icon entries} {format of Bitmap image data has BitMapInfoHeader first so header begins at the offset from beginning of file stored in corresponding IconDirEntry} {point file to beginning of image data} Seek(IconFile, IconDirEntry[i].dwImageOffset); BlockRead(IconFile, Alongint, 4, Amt); {size of header} BitMapInfoHeader[i].biSize := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {width of Bitmap} BitMapInfoHeader[i].biWidth := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {height of Bitmap} BitMapInfoHeader[i].biHeight := Alongint; BlockRead(IconFile, AWord, 2, Amt); {Planes 0 not used} BitMapInfoHeader[i].biPlanes := AWord; BlockRead(IconFile, AWord, 2, Amt); {pixel bit count} BitMapInfoHeader[i].biBitCount := AWord; BlockRead(IconFile, Alongint, 4, Amt); {compression 0 not used} BitMapInfoHeader[i].biCompression := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {size of pixel data} BitMapInfoHeader[i].biSizeImage := Alongint; {note the following entries are not used and set to zero} BlockRead(IconFile, Alongint, 4, Amt); {pixels per meter x 0} BitMapInfoHeader[i].biXPelsPerMeter := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {pixels per meter y 0} BitMapInfoHeader[i].biYPelsPerMeter := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {colors used 0} BitMapInfoHeader[i].biClrUsed := Alongint; BlockRead(IconFile, Alongint, 4, Amt); {important colors 0} BitMapInfoHeader[i].biClrImportant := Alongint; end; {for} end; {proc} procedure TForm1.Button3Click(Sender: TObject); var i:integer; begin i := StrToInt(Edit1.Text) + 1; If i = PIconHeader^.idCount then i := 0; WriteDirEntryToMemo(i); WriteBitMapInfoToMemo(i); If not UserRoutine then {use API ExtractIcon function} ShowIcon(StrToInt(Edit1.Text)) else ShowIconUserRoutine(StrToInt(Edit1.Text)); {manual extraction} end; procedure TForm1.ShowIcon(w : word); var IconPos : Word; success : boolean; begin FreeGraphics; IconPos := StrToInt(Edit1.Text) + 1; If IconPos = PIconHeader^.idCount then IconPos := 0; {rollover count} Edit1.Text := IntToStr(IconPos); IconHandle := ExtractIcon(Application.Handle, PChar(OpenDialog1.FileName), IconPos); If IconHandle = 0 then MessageDlg('No Icon returned suitable for this display', mtInformation, [mbok], 0) else begin {display original Icon} Image4.Picture.Icon.Handle := IconHandle; { Now get the IconInfo and the And and Xor bitmasks} success := GetIconInfo(IconHandle, IconInfo); If success then begin {the And and Xor bitmap handles are returned in the IconInfo structure} Image2.Picture.Bitmap.Handle := IconInfo.hbmColor ; {color bitmap} Image3.Picture.Bitmap.Handle := IconInfo.hbmMask ; {AND mask} {next test the Icon creation routine by recombining the two masks and creating an icon } Image1.Picture.Icon.Handle := CreateIconIndirect(IconInfo); end; {if} end; {else} end; {proc} procedure TForm1.FreeGraphics; var Bitmap : TBitmap; begin {release handles and pass to object which will destroy graphic} {releasing the handle on an icon in an image, according to delphi help gets rid of the icon, and using the handle again shows that it is no longer associated with the icon, however bitmaps need to be freed...do not trust what you find in this freegraphics routine as I am still looking for more info on REALLY freeing bitmaps one thing you don't want is a program that leaks memory especially when it comes to resource hogs like graphics what follows below is 'experimental' given the difficulty in finding just what you want when you search for it} If not (Image1.Picture.Icon.Empty) then Image1.Picture.Icon.ReleaseHandle; If not (Image4.Picture.Icon.Empty) then Image4.Picture.Icon.ReleaseHandle; If not (Image2.Picture.Bitmap.Empty) then begin Bitmap := TBitmap.Create; Bitmap.Handle := Image2.Picture.Bitmap.Handle; Image2.Picture.Bitmap.ReleaseHandle; Bitmap.Free; Image2.Picture.Bitmap.FreeImage; end; If not (Image3.Picture.Bitmap.Empty) then begin Image3.Picture.Bitmap.FreeImage; Image3.Picture.Bitmap.ReleaseHandle; end; {Form2.Paint;} end; {MEMO WRITE} procedure TForm1.WriteDirEntryToMemo(i : integer); begin Memo2.Lines.Append('Icon number : ' + IntToStr(i)); Memo2.Lines.Append('Width : ' + IntToStr(IconDirEntry[i].bWidth)); Memo2.Lines.Append('Height : ' + IntToStr(IconDirEntry[i].bHeight)); Memo2.Lines.Append('Color Count : ' + IntToStr(IconDirEntry[i].bColorCount)); Memo2.Lines.Append('Reserved : ' + IntToStr(IconDirEntry[i].bReserved)); Memo2.Lines.Append('Planes : ' + IntToStr(IconDirEntry[i].wPlanes)); Memo2.Lines.Append('Bit Count : ' + IntToStr(IconDirEntry[i].wBitCount)); Memo2.Lines.Append('Bytes in Res : ' + IntToStr(IconDirEntry[i].dwBytesInRes)); Memo2.Lines.Append('Image OffSet : ' + IntToStr(IconDirEntry[i].dwImageOffset)); Memo2.Lines.Append(' '); end; Procedure TForm1.WriteBitMapInfoToMemo(i : integer); begin Memo2.Lines.Append('Size : ' + IntToStr(BitMapInfoHeader[i].biSize )); Memo2.Lines.Append('Width : ' + IntToStr(BitMapInfoHeader[i].biWidth )); Memo2.Lines.Append('Height x 2 : ' + IntToStr(BitMapInfoHeader[i].biHeight )); Memo2.Lines.Append('Planes : ' + IntToStr(BitMapInfoHeader[i].biPlanes )); Memo2.Lines.Append('Pixel Bit Count: ' + IntToStr(BitMapInfoHeader[i].biBitCount )); Memo2.Lines.Append('Compression : ' + IntToStr(BitMapInfoHeader[i].biCompression )); Memo2.Lines.Append('Size Image : ' + IntToStr(BitMapInfoHeader[i].biSizeImage )); Memo2.Lines.Append('PPM x : ' + IntToStr(BitMapInfoHeader[i].biXPelsPerMeter )); Memo2.Lines.Append('PPM y : ' + IntToStr(BitMapInfoHeader[i].biYPelsPerMeter )); Memo2.Lines.Append('Colors used : ' + IntToStr(BitMapInfoHeader[i].biClrUsed )); Memo2.Lines.Append('Important Clrs : ' + IntToStr(BitMapInfoHeader[i].biClrImportant )); Memo2.Lines.Append(' '); end; procedure TForm1.ShowIconUserRoutine(w : Word); var i, y : integer; XORBitmap, ANDBitMap : TBitmap; rowlength, palcount : integer; pb : Pointer; IconPalette: PLogPalette;{logical pallette structure for icon} hIconPalette : HPALETTE; {handle to the icon palette} begin HIconPalette := 0; AssignFile(IconFile, OpenDialog1.FileName); Reset(IconFile, 1); {set record size to 1 byte} w := w + 1; {because the edit box is initialized to -1} If w = PIconHeader^.idCount then w := 0; Edit1.Text := IntToStr(w); {seek start of palette data which immediately follows bitmapinfoheader} Seek(IconFile, IconDirEntry[w].dwImageOffset + BitMapInfoHeader[w].biSize); {when an icon has more than 256 colors it does not have a palette} If (BitMapInfoHeader[w].biBitCount <= 8) then begin IconPalette := nil; {get mem for ColorCount number of palette entries, get disk data, create} If IconDirEntry[w].bColorCount = 0 then palcount := 256 else palcount := IconDirEntry[w].bColorCount; GetMem(IconPalette, sizeof(TLogPalette) + sizeof(TPaletteEntry) * palcount); IconPalette.palVersion := $300; IconPalette.palNumEntries := palcount; for i := 0 to palcount - 1 do begin BlockRead(IconFile, BlueByte, 1, Amt); BlockRead(IconFile, GreenByte, 1, Amt); BlockRead(IconFile, RedByte, 1, Amt); BlockRead(IconFile, AByte, 1, Amt); {The flag byte} IconPalette.palPalEntry[i].peBlue := BlueByte; IconPalette.palPalEntry[i].peGreen := GreenByte; IconPalette.palPalEntry[i].peRed := RedByte; IconPalette.palPalEntry[i].peFlags := Abyte; end; HIconPalette := CreatePalette(IconPalette^); FreeMem(IconPalette); end; {if bitcount <= 8} {Next retrieve from disk the XOR color bitmap data and the monochrome AND mask bitmap data} XORBitMap := TBitmap.Create; XORBitmap.Height := IconDirEntry[w].bHeight; XORBitmap.Width := BitMapInfoHeader[w].biWidth; {Icons are only supposed to have a max of 256 colors - 8 bit but I have an icon on my computer that is 24 bit so .... } case BitMapInfoHeader[w].biBitCount of 1 : XORBitmap.PixelFormat := pf1bit; 4 : XORBitmap.PixelFormat := pf4bit; 8 : XORBitmap.PixelFormat := pf8bit; 15 : XORBitmap.PixelFormat := pf15bit; 16 : XORBitmap.PixelFormat := pf16bit; 24 : XORBitmap.PixelFormat := pf24bit; 32 : XORBitmap.PixelFormat := pf32bit; { : XORBitmap.PixelFormat := pfCustom;} end; {icons with more than 256 colors/ 8 bit do not include palette data} If (HIconPalette <> 0) and (BitMapInfoHeader[w].biBitCount <= 8) then XORBitmap.Palette := HIconPalette; {TotalSize := (IconDirEntry.bWidth * IconDirEntry.bHeight * BitMapInfoHeader.biBitCount) div 8; {Color XOR Bitmap} {calculate number of bytes in one row of Color XOR Map} RowLength := (IconDirEntry[w].bWidth*BitMapInfoHeader[w].biBitCount) div 8; {pixel data is stored upside down, so fill bitmap from bottom up} for y := IconDirEntry[w].bHeight - 1 downto 0 do begin pb := XORBitMap.ScanLine[y]; {get ^ address of first byte on row} BlockRead(IconFile, pb^, RowLength, amt); end; If not Image2.Picture.Bitmap.Empty then begin Image2.Picture.Bitmap.ReleaseHandle; Image2.Picture.Bitmap.ReleasePalette; end; Image2.Picture.Bitmap := XORBitmap; XORBitmap.ReleasePalette; XORBitmap.Free; {Total Number of bytes in monochrome AND Mask Bitmap} {TotalSize := (IconDirEntry[w].bWidth * IconDirEntry[w].bHeight) div 8;} ANDBitmap := TBitmap.Create; AndBitMap.Monochrome := true; AndBitMap.PixelFormat := pf1bit; RowLength := IconDirEntry[w].bWidth div 8; {1 bit per pixel} ANDBitmap.Height := IconDirEntry[w].bHeight; ANDBitmap.Width := BitMapInfoHeader[w].biWidth; IconPalette := nil; {make a black and white palette for the ANDBitmap so it doesn't turn out purple and white or some other strange color} GetMem(IconPalette, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 2); {black and white} IconPalette.palVersion := $300; IconPalette.palNumEntries := 2; for i := 0 to 1 do begin IconPalette.palPalEntry[i].peRed := (i * 255); IconPalette.palPalEntry[i].peGreen := (i * 255); IconPalette.palPalEntry[i].peBlue := (i * 255); IconPalette.palPalEntry[i].peFlags := 0; end; HIconPalette := CreatePalette(IconPalette^); If HIconPalette <> 0 then ANDBitmap.Palette := HIconPalette; for y := IconDirEntry[w].bHeight - 1 downto 0 do begin pb := ANDBitMap.ScanLine[y]; {get ^ address of first byte on row} BlockRead(IconFile, pb^, RowLength, amt); end; If not Image3.Picture.Bitmap.Empty then Image3.Picture.Bitmap.ReleaseHandle; Image3.Picture.Bitmap := ANDBitmap; ANDBitmap.ReleasePalette; ANDBitmap.Free; FreeMem(IconPalette); {now use two extracted images to make an icon} IconInfo.fIcon := true; {an icon not a cursor} IconInfo.hbmMask := Image3.Picture.Bitmap.Handle; IconInfo.hbmColor := Image2.Picture.Bitmap.Handle; Image1.Picture.Icon.Handle := CreateIconIndirect(IconInfo); WriteCalcToMemo(w); CloseFile(IconFile); end; procedure TForm1.WriteCalcToMemo(i : word); var j : longint; begin Memo2.Lines.Append(' '); Memo2.Lines.Append(' '); Memo2.Lines.Append('Bytes in Res : ' + IntToStr(IconDirEntry[i].dwBytesInRes)); {size of BitmapInfoHeader + size of Palette + XORBitmap size + AND BitMap size should equal BytesInRes} j := BitMapInfoHeader[i].biSize + (IconDirEntry[i].bColorCount * 4) + ((IconDirEntry[i].bHeight * IconDirEntry[i].bWidth * BitMapInfoHeader[i].biBitCount) div 8) + ((IconDirEntry[i].bHeight * IconDirEntry[i].bWidth) div 8); Memo2.Lines.Append('Calculated : ' + IntToStr(j)); If (i+1) <> PIconHeader^.idCount then Memo2.Lines.Append('Pos Next Icon : ' + IntToStr(IconDirEntry[i+1].dwImageOffset)) else Memo2.Lines.Append('No following Icon'); Memo2.Lines.Append('Calculated Pos : ' + IntToStr(IconDirEntry[i].dwImageOffset + j)); Memo2.Lines.Append('Current File Pos : ' + IntToStr(FilePos(IconFile))); Memo2.Lines.Append(' '); Memo2.Lines.append(' '); end; procedure TForm1.Button4Click(Sender: TObject); begin Application.Terminate; end; procedure TForm1.FormCreate(Sender: TObject); begin Button1.Caption := 'Open File'; Button2.Caption := 'Open File'; Button3.Caption := 'Next Icon'; Button4.Caption := 'Exit'; Label1.Caption := 'ExtractIcon'; Label2.Caption := 'User Written'; Label3.Caption := 'ICON #'; Label4.Caption := 'Original Icon'; Label5.Caption := 'Icon Created'; Label6.Caption := 'XOR Mask'; Label7.Caption := 'AND Mask'; end; end.