Mega Code Archive
Get associated icon of a file shortcut
<![CDATA[
{
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.
]]>