Получить иконку файла по ярлыку

{ 
  Comment: 
  The procedure GetAssociatedIcon, trys via Registry to get the 
  icon(should work for small and big icons) that is associated with 
  the files shown in the explorer. 

  This is not my work. But I want to distribute it to you, because 
  it was really hard to find a corresonding document. 
  Thanks SuperTrax. 
}


 { 
  Kommentar: 
  Die Prozedure GetAssociatedIcon versucht uber die Registrierung 
  das Icon der Datei, wie im Explorer angezeigt, herauszubekommen. 
  (Sollte fur grosse und kleine funktionieren) 

  Dies ist nicht mein Werk. Ich mochte es nur fur andere zuganglich 
  machen, weil ich sehr lange gebraucht habe, um ein entsprechendes 
  Dokument zu finden. 
}

 unit
 AIconos;

 interface


 uses

   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ExtCtrls, StdCtrls, FileCtrl;

 type

   TForm1 = class
(TForm)
     Button1: TButton;
     Image1: TImage;
     Image2: TImage;
     OpenDialog1: TOpenDialog;
     procedure
 Button1Click(Sender: TObject);
   private

     { Private declarations }
   public

     { Public declarations }
   end
;

 type

   PHICON = ^HICON;

 var

   Form1: TForm1;
   PLargeIcon, PSmallIcon: phicon;

 implementation


 uses
 shellapi, registry;

 {$R *.DFM}

 procedure
 GetAssociatedIcon(FileName: TFilename; PLargeIcon, PSmallIcon: PHICON);
 var

   IconIndex: SmallInt;  // Position of the icon in the file 
  Icono: PHICON;       // The LargeIcon parameter of ExtractIconEx 
  FileExt, FileType: string
;
   Reg: TRegistry;
   p: Integer;
   p1, p2: PChar;
   buffer: array
 [0..255] of
 Char;

 Label

   noassoc, NoSHELL; // ugly! but I use it, to not modify to much the original code :( 
begin

   IconIndex := 0;
   Icono := nil
;
   // ;Get the extension of the file 
  FileExt := UpperCase(ExtractFileExt(FileName));
   if
 ((FileExt  '.EXE') and
 (FileExt  '.ICO')) or
 not
 FileExists(FileName) then

   begin

     // If the file is an EXE or ICO and exists, then we can 
    // extract the icon from that file. Otherwise here we try 
    // to find the icon in the Windows Registry. 
    Reg := nil
;
     try

       Reg := TRegistry.Create;
       Reg.RootKey := HKEY_CLASSES_ROOT;
       if
 FileExt = '.EXE' then
 FileExt := '.COM';
       if
 Reg.OpenKeyReadOnly(FileExt) then

         try

           FileType := Reg.ReadString('');
         finally

           Reg.CloseKey;
         end
;
       if
 (FileType <> '') and
 Reg.OpenKeyReadOnly(FileType + 'DefaultIcon') then

         try

           FileName := Reg.ReadString('');
         finally

           Reg.CloseKey;
         end
;
     finally

       Reg.Free;
     end
;

     // If there is not association then lets try to 
    // get the default icon 
    if
 FileName = '' then
 goto
 noassoc;

     // Get file name and icon index from the association 
    // ('"FileName",IconIndex') 
    p1 := PChar(FileName);
     p2 := StrRScan(p1, ',');
     if
 p2  nil
 then

     begin

       p         := p2 - p1 + 1; // Position de la coma 
      IconIndex := StrToInt(Copy(FileName, p + 1, Length(FileName) - p));
       SetLength(FileName, p - 1);
     end
;
   end
; //if ((FileExt  '.EX ... 

  // Try to extract the small icon 
  if
 ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then

   begin

     noassoc:
     // That code is executed only if the ExtractIconEx return a value but 1 
    // There is not associated icon 
    // try to get the default icon from SHELL32.DLL 

    FileName := 'C:WindowsSystemSHELL32.DLL';
     if
 not
 FileExists(FileName) then

     begin
  //If SHELL32.DLL is not in WindowsSystem then 
      GetWindowsDirectory(buffer, SizeOf(buffer));
       //Search in the current directory and in the windows directory 
      FileName := FileSearch('SHELL32.DLL', GetCurrentDir + ';' + buffer);
       if
 FileName = '' then

         goto
 NoSHELL; //the file SHELL32.DLL is not in the system 
    end
;

     // Determine the default icon for the file extension 
    if
 (FileExt = '.DOC') then
 IconIndex := 1
     else
 if
 (FileExt = '.EXE') or
 (FileExt = '.COM') then
 IconIndex := 2
     else
 if
 (FileExt = '.HLP') then
 IconIndex := 23
     else
 if
 (FileExt = '.INI') or
 (FileExt = '.INF') then
 IconIndex := 63
     else
 if
 (FileExt = '.TXT') then
 IconIndex := 64
     else
 if
 (FileExt = '.BAT') then
 IconIndex := 65
     else
 if
 (FileExt = '.DLL') or
 (FileExt = '.SYS') or
 (FileExt = '.VBX') or

       (FileExt = '.OCX') or
 (FileExt = '.VXD') then
 IconIndex := 66
     else
 if
 (FileExt = '.FON') then
 IconIndex := 67
     else
 if
 (FileExt = '.TTF') then
 IconIndex := 68
     else
 if
 (FileExt = '.FOT') then
 IconIndex := 69
     else

       IconIndex := 0;
     // Try to extract the small icon 
    if
 ExtractIconEx(PChar(FileName), IconIndex, Icono^, PSmallIcon^, 1) <> 1 then

     begin

       //That code is executed only if the ExtractIconEx return a value but 1 
      // Fallo encontrar el icono. Solo "regresar" ceros. 
      NoSHELL:
       if
 PLargeIcon  nil
 then
 PLargeIcon^ := 0;
       if
 PSmallIcon  nil
 then
 PSmallIcon^ := 0;
     end
;
   end
; //if ExtractIconEx 

  if
 PSmallIcon^ 0 then

   begin
 //If there is an small icon then extract the large icon. 
    PLargeIcon^ := ExtractIcon(Application.Handle, PChar(FileName), IconIndex);
     if
 PLargeIcon^ = Null then

       PLargeIcon^ := 0;
   end
;
 end
;

 procedure
 TForm1.Button1Click(Sender: TObject);
 var

   SmallIcon, LargeIcon: HIcon;
   Icon: TIcon;
 begin

   if
 not
 (OpenDialog1.Execute) then

     Exit;
   Icon := TIcon.Create;
   try

     GetAssociatedIcon(OpenDialog1.FileName, @LargeIcon, @SmallIcon);
     if
 LargeIcon <> 0 then

     begin

       Icon.Handle := LargeIcon;
       Image2.Picture.icon := Icon;
     end
;
     if
 SmallIcon <> 0 then

     begin

       Icon.Handle := SmallIcon;
       Image1.Picture.icon := Icon;
     end
;
   finally

     Icon.Destroy;
   end
;
 end
;

 end
.

Другое по теме:

• Как извлечь иконку из файлов ICO
• Создание ICO из BMP
• Анимированная иконка приложения