Extrair + de 1000 Icones do Windows

[Jhonas]

O Windows tem arquivos de Icones que voce pode usar em seus programas  ou outras aplicações

o código abaixo, extrai esses icones dos arquivos ( .DLL )  e salva esses icones em uma pasta no Diretório " C:\Icones "  

o Tamanho desses icones é 32 X 32 ...  No XP o resultado foi de 984 Icones

OBS: Se alguém souber de outros arquivos  que contenham icones, favor informar.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  // Arquivos de Icones do Windows
  Arquivo: array[0..22] of STRING = ('shell32.dll', 'wmploc.dll', 'imageres.dll',
  'ieframe.dll', 'vscript.dll', 'compstui.dll', 'ddores.dll', 'mmcndmgr.dll',
  'moricons.dll', 'netshell.dll', 'pnidui.dll', 'pifmgr.dll', 'wpdshext.dll',
  'comres.dll', 'dmdskres.dll', 'dsuiext.dll', 'mstscax.dll', 'setupapi.dll',
  'vrlmon.dll', 'wiashext.dll', 'mmres.dll', 'inetpic.dll', 'inetpic.cpl');

  implementation

{$R *.dfm}

uses
  ShellAPI;

procedure ExtractIconsFromWindows(SavetoFolder : string);
var
  Icon: TIcon;
  ExtrFileName, Arq : string;
  NumberOfIcons, i, n: Integer;
begin
  for n := 0 to 22 do
     begin
        showmessage('Extraindo Icones de : ' + Arquivo[n]);
        Arq := copy(Arquivo[n],1,pos('.',Arquivo[n])-1);
        ExtrFileName := IncludeTrailingBackSlash(Arquivo[n]);
        Icon := TIcon.Create;
        try
          NumberOfIcons := ExtractIcon(0, PChar(Arquivo[n]), UINT(-1));
          for i := 0 to NumberOfIcons - 1 do
          begin
            Icon.Handle := ExtractIcon(0, PChar(Arquivo[n]), i);
            Icon.Transparent := true;
            Icon.SaveToFile(IncludeTrailingBackSlash(SavetoFolder) +
                        Arq + ' - '+ IntToStr(i)+'.ico');
          end;
        finally
          icon.Free;
        end;
     end;
     showmessage('Extração de Icones Finalizada.');
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
   ExtractIconsFromWindows('C:\Icones');
end;

end.

Abraço