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.