{http://www.awitness.org/delphi_pascal_tutorial/index.html}
{this demo illustrates one way to create an icon cache for a program
rather than thashing a disk drive and reading the registry and so on
to reload icons on each program run where a certain set of icons is needed
the icon cache file it creates has the following format
4 bytes - number icons cached in the file
4 bytes - width of icons
4 bytes - height of icons
followed by the raw pixel data for the XOR color bitmap in pf24bit format
followed by the raw pixel data for the And mask in pf1bit format
followed immediately by another XOR map, another AND map etc
by saving the pixel data for the color XOR bitmap in 24 bit format
the code avoids the problems of different screen display settings
and problems with API routines returning bitmaps from icons
of indeterminate color depth (bit count) and also
avoids problems of icon palettes (returned as zero) and strange
colored icons that can result
the API icon routines will accept a 24 bit XOR bitmap for the icon creation
routine, and by using 24 bits the need for palette data is eliminated

The open file button is set to open a dialogue pointing to c:\windows\system
and the file filter is set to Shell32.dll for convenience
hit the Get Icon button a number of times to load some icons from the shell
into the image list, then hit the save button to save the icons as a cache file
and then reload the cache file and recreate the icons by hitting the load button
you can then surf through the icons recreated from the cache stored on
the image list by hitting the view button to cycle through icons on the list}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  ShellApi, Dialogs, ExtCtrls, StdCtrls, ImgList;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    OpenDialog1: TOpenDialog;
    Edit1: TEdit;
    ImageList1: TImageList;
    Button3: TButton;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    SaveDialog1: TSaveDialog;
    Button4: TButton;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Label7: TLabel;
    Label8: TLabel;
    OpenDialog2: TOpenDialog;
    Label9: TLabel;
    Button5: TButton;
    Edit2: TEdit;
    Image4: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    Procedure GetFilesIcon(FileName:string);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  IconInfo : TIconInfo;
  IconWidth, IconHeight : integer;

implementation

{$R *.DFM}


procedure TForm1.FormCreate(Sender: TObject);
begin
        IconWidth := GetSystemMetrics(SM_CXICON);
        IconHeight := GetSystemMetrics(SM_CYICON);
        ImageList1.Width := IconWidth;
        ImageList1.Height := IconHeight;
        Form1.Caption := 'Create an Icon cache file';
        Button1.Caption := 'Open file';
        Button2.Caption := 'Add Icon';
        Button3.Caption := 'Save List';
        Button4.Caption := 'Load List';
        Button5.Caption := 'View ->';
        Label9.Caption := 'View items on image list';
        Edit2.Text := '0';
        Edit1.Text := '-1';
        Label3.Caption := 'This demo is set to open  Shell32.dll  in c:\windows\system';
        Label4.Caption := 'If your default windows system direcctory is not as above change the iinitial dir in the opendialog';
        Label5.Caption := 'When the shell has been opened click get icon to add icons to image list';
        Label6.Caption :=  'Click save list button to create an icon cache file from the icons on the image list';
end;


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;
   AnLIcon{, AnSIcon} : TIcon;
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
        AnLIcon := TIcon.Create;
   {     AnSIcon := TIcon.Create;  }

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

              AnLIcon.Handle := PLargeIcon;
           {   AnSIcon.Handle := PSmallIcon;}
              ImageList1.AddIcon(AnLIcon);
             {update edit box }
             Edit1.Text := IntToStr(IconPos);
             AnLIcon.Free;
             DeleteObject(PLargeIcon); DeleteObject(PSmallIcon);
{             AnSIcon.Free;   }
           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 icon cache}
var
  bmp, abmp: TBitmap; {24bit color xor mask, 1 bit b/w and mask}
  xorbitmap, andbitmap: TBitmap; {get handles from api iconinfo}
  aicon:TIcon;
  i: integer; {imagelist loop counter}
  IconPalette: PLogPalette;{logical pallette structure for icon}
  hIconPalette : HPALETTE;    {handle to the icon palette}
  f : file; {binary file icon cache}
  pb : Pointer;  {pointer for scanline bitmap function}
  Alongint : Longint;   {temp var for blockwrite}
  amt : integer; {var variable bytes written/read to binary file}
  RowLength, y : integer;  {length of bitmap row for scanline, loop counter}

begin
If (ImageList1.Count <> 0) and (SaveDialog1.Execute) then begin
     OpenDialog2.Filename := SaveDialog1.Filename;
     bmp := TBitmap.Create;  {color 24 bit xor map holder}
     abmp := TBitmap.Create;  {b/w 1 bit and map holder}
     bmp.height := IconHeight;  {set permanent color bitmap values}
     bmp.width := IconWidth;    {based on GetSystemMetrics in FormCreate}
     bmp.pixelformat := pf24bit; {24 bit, a known value for read/write}
     abmp.height := IconHeight;
     abmp.width := IconWidth;
     abmp.monochrome := true;
     abmp.pixelformat := pf1bit; {1 bit, a known value for read/write}

    {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; {current standard}
    IconPalette.palNumEntries := 2;
    for i := 0 to 1 do begin  {0 = black, 1 = white}
    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(PLogPalette(IconPalette)^);
    If HIconPalette <> 0 then
       abmp.Palette := HIconPalette;
    if hiconpalette = 0 then messagedlg('error creating palette', mterror, [mbok],0);

    AssignFile(f, SaveDialog1.Filename);
    Rewrite(f, 1);

    {create an icon cache file format
    number of images, width, height}
    AlongInt := ImageList1.Count;
    BlockWrite(f, Alongint, 4, amt);
    Alongint := IconWidth;
    BlockWrite(f, Alongint, 4, amt);
    Alongint := IconHeight;
    BlockWrite(f, Alongint, 4, amt);

        {loop through image list}
    for i := 0 to ImageList1.Count - 1 do begin
        aicon := ticon.create;
        Imagelist1.GetIcon(i, aicon);

        andbitmap:=tbitmap.create; xorbitmap := tbitmap.create;

        {get color xor and b/w and bitmaps}
        GetIconInfo(aicon.handle, IconInfo);
        xorbitmap.handle := iconinfo.hbmColor ;
        andbitmap.handle := iconinfo.hbmMask ;

        {windows api returns bitmaps with pixelformat set to pfDevice}
        {transfer bitmaps to two permanent bitmaps with known color depth}
        bmp.Canvas.Draw(0,0, xorbitmap);
        abmp.Canvas.Draw(0,0, andbitmap);

        {some visual debugging code}
        Image1.Picture.Graphic := bmp;
        Image2.Picture.Graphic := abmp;
        MessageDlg('look', mtinformation, [mbok],0);

        
        {write color bitmap pixel data to icon cache file}
        RowLength := (IconWidth *  24) div 8;

        for y := 0 to IconHeight - 1 do begin
                pb := bmp.ScanLine[y];  {get ^ address of first byte on row}
                BlockWrite(f, pb^, RowLength, amt);
        end;
        {write data for black and white and mask to file}
        RowLength := IconWidth div 8; {1 bit per pixel}

        for y := 0 to IconHeight - 1 do begin
                pb := abmp.ScanLine[y];  {get ^ address of first byte on row}
                Blockwrite(f, pb^, RowLength, amt);
        end;

        DeleteObject(IconInfo.hbmMask);
        DeleteObject(IconInfo.hbmColor);
        XorBitmap.free;
        AndBitmap.Free;
    end; {for loop}
    FreeMem(IconPalette);
    DeleteObject(HIconPalette);
    bmp.free;
    abmp.Free;
    closefile(f);
end; {if open dialog executes and count imagelist <> 0}
end; {procedure}

procedure TForm1.Button4Click(Sender: TObject);  {load icon cache to imagelist}
var
  bmp, abmp: TBitmap; {color xor mask, b/w and mask}
  aicon:TIcon;
  i: integer; {count loop}
  IconPalette: PLogPalette;{logical pallette structure for icon}
  hIconPalette : HPALETTE;    {handle to the icon palette}
  f : file;  {binary file - icon cache}
  pb : Pointer; {pointer for scanline function in bitmap}
  amt : integer; {var variable bytes written/read to binary file}
  RowLength : integer; {num bytes in XOR/And mask data}
  y : integer; {loop counter for scanline of bitmap}
  ImageCount, IWidth, IHeight : longint;

begin
If (OpenDialog2.Execute) then begin
     If not (FileExists(OpenDialog2.FileName)) then exit;

     ImageList1.Clear;

     AssignFile(f, OpenDialog2.Filename);
     Reset(f, 1);

    {read an icon cache file format
    number of images, width, height}

     BlockRead(f, ImageCount, 4, amt);
     If amt <> 4 then begin
        MessageDlg('File Format incorrect', mterror, [mbok],0);
        exit;   {read icons from registry, etc, rebuild icon cache}
     end;
     BlockRead(f, IWidth, 4, amt);
     If amt <> 4 then begin
        MessageDlg('File Format incorrect', mterror, [mbok],0);
        exit;
     end;
     BlockRead(f, IHeight, 4, amt);
     If amt <> 4 then begin
        MessageDlg('File Format incorrect', mterror, [mbok],0);
        exit;
     end;

     bmp := TBitmap.Create;  {color 24 bit xor map holder}
     abmp := TBitmap.Create;  {b/w 1 bit and map holder}
     bmp.height := IHeight;  {set permanent color bitmap values}
     bmp.width := IWidth;    {based on GetSystemMetrics in FormCreate}
     bmp.pixelformat := pf24bit; {24 bit, a known value for read/write}
     abmp.height := IHeight;
     abmp.width := IWidth;
     abmp.monochrome := true;
     abmp.pixelformat := pf1bit; {1 bit, a known value for read/write}

    {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; {current standard}
    IconPalette.palNumEntries := 2;
    for i := 0 to 1 do begin  {0 = black, 1 = white}
    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(PLogPalette(IconPalette)^);
    If HIconPalette <> 0 then
       abmp.Palette := HIconPalette;
    if hiconpalette = 0 then messagedlg('error creating palette', mterror, [mbok],0);

        {loop through image list}
    for i := 0 to ImageCount - 1 do begin
         {read in bit data for color and b/w bitmaps}

        RowLength := (IWidth *  24) div 8;

        for y := 0 to IHeight - 1 do begin
                pb := bmp.ScanLine[y];  {get ^ address of first byte on row}
                BlockRead(f, pb^, RowLength, amt);
        end;
        {read data for black and white and mask from file}
        RowLength := IWidth div 8; {1 bit per pixel}

        for y := 0 to IHeight - 1 do begin
                pb := abmp.ScanLine[y];  {get ^ address of first byte on row}
                BlockRead(f, pb^, RowLength, amt);
        end;

        {use bitmaps to create icon}
        aicon := TIcon.Create;
        IconInfo.hbmMask := abmp.handle;
        IconInfo.hbmColor := bmp.handle;
        IconInfo.fIcon := true; {an icon not a cursor}
        aicon.handle := CreateIconIndirect(IconInfo);

        {add icon to imagelist}
        ImageList1.AddIcon(aicon);

        {some visual debugging code}
        Image1.Picture.Graphic := bmp;
        Image2.Picture.Graphic := abmp;
        Image3.Picture.Graphic := aicon;
        MessageDlg('look', mtinformation, [mbok],0);

        aicon.ReleaseHandle;
        aicon.free;

    end; {loop through imagecount # bitmaps}
    FreeMem(IconPalette);
    DeleteObject(HIconPalette);
    bmp.free;
    abmp.Free;
    closefile(f);
end; {if open dialog2 execute}
end;

procedure TForm1.Button5Click(Sender: TObject); {after using save/load
                                                view icons on image list
                                                returned from icon cache}
var i : integer;
begin
      If ImageList1.Count = 0 then exit
      else begin
           i := StrToInt(Edit2.Text);
           If i = ImageList1.Count then i := 0; {rollover count}
           ImageList1.GetIcon(i, Image4.Picture.Icon);
           Edit2.Text := IntToStr(i + 1);
      end;
end;

end.