1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:

uses ShellApi;

// --------------------- Funktion Nr. 1 -------------------------//

function TotalNumberOfIcons(const FileName: String): Integer;
begin
 if not FileExists(FileName) then Result:= -1
 else Result := ExtractIcon(HInstance, PChar(FileName), $FFFFFFFF);
end;

function GetIconFromFile(const FileName: String; Index: Word;
  Icon: TIcon): Boolean;
begin
 Result:= False;
 showmessage(inttostr(TotalNumberOfIcons(FileName)));
 if (TotalNumberOfIcons(FileName) < 1) or ((Index + 1 ) > TotalNumberOfIcons(FileName)) then exit;
 Icon.Handle:= ExtractIcon(HInstance, PChar(FileName), Index);
 Result:= true;
end;

// ---------------------------------------------------------------//

// --------------------- Funktion Nr. 2 -------------------------//

function ExtractIcons(exeFilename,icoOutFileName:String;icoSize:Integer): boolean;
const
{$ifdef UNICODE}
 ExtractProcName='PrivateExtractIconsW';
{$else}
 ExtractProcName='PrivateExtractIconsA';
{$endif}
type
  TExtractFunc = function(lpszFile: PChar; nIconIndex, cxIcon, cyIcon: integer; phicon: PHANDLE; piconid: PDWORD; nicon, flags: DWORD): DWORD; stdcall;
var
  hIcon: THandle;
  nIconId: DWORD;
  Icon: TIcon;
  PrivateExtractIcons: TExtractFunc;
  hUserDll: THandle;
begin
 result:= false;

 hUserDll:= LoadLibrary('user32.dll');

 PrivateExtractIcons:= GetProcAddress(hUserDll, ExtractProcName);
 if not Assigned(PrivateExtractIcons) then exit;
 //extract a icoSize x icoSize  icon where icoSize is one of 256,128,64,48,32,16

 if PrivateExtractIcons(Pchar(exeFilename), 0, icoSize, icoSize, @hIcon, @nIconId, 1, LR_LOADFROMFILE) <>0 then
 begin
  try
   Icon:=TIcon.Create;
   try
    Icon.Handle:=hIcon;
    Icon.SaveToFile(icoOutFileName);
    result := true;
   finally
    Icon.Free;
   end;
  finally
   DestroyIcon(hIcon);
  end;
 end;
end;

// ---------------------------------------------------------------//

procedure TForm1.Button1Click(Sender: TObject);
var OutFile: string;
const FilePath = 'D:\Apps\GIMPPortable\GIMPPortable.exe';
begin
 OutFile:= 'C:\Users\<User>\Desktop\Icon'+inttostr(Random(500))+'.ico';
 ExtractIcons(FilePath, OutFile, 256);
end;

procedure TForm1.Button2Click(Sender: TObject);
var Icon: TIcon;
    OutFile: string;
const FilePath = 'D:\Apps\GIMPPortable\GIMPPortable.exe';
begin
 Icon:= TIcon.Create;
 GetIconFromFile(FilePath, 0, Icon);
 OutFile:= 'C:\Users\<User>\Desktop\Icon'+inttostr(Random(500))+'.ico';
 if not Icon.Empty then
  Icon.SaveToFile(OutFile);
 Icon.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Randomize;
end;