...Icons für Dateiverknüpfungen herausfinden?

Autor: SuperTrax
Homepage: http://www.SuperTrax.de

Kategorie: System

{
  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 über die Registrierung
  das Icon der Datei, wie im Explorer angezeigt, herauszubekommen.
  (Sollte für grosse und kleine funktionieren)

  Dies ist nicht mein Werk. Ich möchte es nur für andere zugänglich
  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
    // ('"File\Name",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:\Windows\System\SHELL32.DLL';
    if not FileExists(FileName) then
    begin  
//If SHELL32.DLL is not in Windows\System 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.

 

printed from
www.swissdelphicenter.ch
developers knowledge base