Как извлечь иконку из файла ярлыка?
Falk0ner, вс, 06/07/2008 - 15:34.
How to get icon from a shortcut file ?
I have found that if you use a ListView component,
to show a list of files in any folder that contains shortcuts,
then the shortcut icons do not appear correctly -
they do not show the true icon of the application to which they relate.
However, there is a a very useful feature of SHGetFileInfo,
which is SHGFI_LINKOVERLAY. This adds the shortcut "arrow",
which is shown in the bottom left corner of any shortcut icon.
The demo code below shows the basic use of the SHGFI_LINKOVERLAY feature.
I have added code to this demo, to distingiush between shortcut and non-shortcut files -
without this code, it will overlay the shortcut "arrow" irrespective of the file type.
To show the icon of a shortcut, the following code can be used as a demo:
1. Add the following components to a new project, and adjust their
properties according to the code below: }
// Code for DFM file:
object Form1: TForm1
Left = 379
= 355
Width = 479
Height = 382
Caption = 'Get Icon from Shortcut File'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object ListView: TListView
Left = 0
= 73
Width = 471
Height = 275
Align = alClient
Columns = <
item
Width = 100
end
item
Width = 100
end>
SmallImages = imgList
TabOrder = 0
ViewStyle = vsReport
end
object Panel: TPanel
Left = 0
= 0
Width = 471
Height = 73
Align = al
TabOrder = 1
object btnGetFile: TButton
Left = 16
= 8
Width = 75
Height = 25
Caption = 'Get file'
TabOrder = 0
OnClick = btnGetFileClick
end
object btnGetIcon: TButton
Left = 104
= 8
Width = 75
Height = 25
Caption = 'Get icon'
TabOrder = 1
OnClick = btnGetIconClick
end
object edFileName: TEdit
Left = 16
= 40
Width = 441
Height = 21
TabOrder = 2
end
end
object dlgOpen: TOpenDialog
Filter = 'Shortcut files|*.lnk|All files|*.*'
Options = [ofHideReadOnly, ofNoDereferenceLinks,
ofEnableSizing] // - this is important !
Left = 248
= 8
end
object imgList: TImageList
BlendColor = clWhite
BkColor = clWhite
Masked = False
ShareImages = True
Left = 216
= 8
end
end
object Form1: TForm1
Left = 379
= 355
Width = 479
Height = 382
Caption = 'Get Icon from Shortcut File'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object ListView: TListView
Left = 0
= 73
Width = 471
Height = 275
Align = alClient
Columns = <
item
Width = 100
end
item
Width = 100
end>
SmallImages = imgList
TabOrder = 0
ViewStyle = vsReport
end
object Panel: TPanel
Left = 0
= 0
Width = 471
Height = 73
Align = al
TabOrder = 1
object btnGetFile: TButton
Left = 16
= 8
Width = 75
Height = 25
Caption = 'Get file'
TabOrder = 0
OnClick = btnGetFileClick
end
object btnGetIcon: TButton
Left = 104
= 8
Width = 75
Height = 25
Caption = 'Get icon'
TabOrder = 1
OnClick = btnGetIconClick
end
object edFileName: TEdit
Left = 16
= 40
Width = 441
Height = 21
TabOrder = 2
end
end
object dlgOpen: TOpenDialog
Filter = 'Shortcut files|*.lnk|All files|*.*'
Options = [ofHideReadOnly, ofNoDereferenceLinks,
ofEnableSizing] // - this is important !
Left = 248
= 8
end
object imgList: TImageList
BlendColor = clWhite
BkColor = clWhite
Masked = False
ShareImages = True
Left = 216
= 8
end
end
// 2. Add the code to the PAS file below:
unit cdShortCutIcon;
interface
uses
Windows, Messages, SysUtils, Variants, Graphics, Controls, Forms,
Dialogs, Buttons, ExtCtrls, StdCtrls, StrUtils, ShellAPI,
CommCtrl, ImgList, ComCtrls, Classes;
type
TForm1 = class(TForm)
dlgOpen: TOpenDialog;
ListView: TListView;
imgList: TImageList;
Panel: TPanel;
btnGetFile: TButton;
btnGetIcon: TButton;
edFileName: TEdit;
procedure btnGetFileClick(Sender: TObject);
procedure btnGetIconClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnGetFileClick(Sender: TObject);
begin
{ choose file to get icon from }
if dlgOpen.Execute then edFileName.Text := dlgOpen.FileName;
end;
procedure TForm1.btnGetIconClick(Sender: TObject);
var
Icon : TIcon;
ListItem : TListItem;
shInfo : TSHFileInfo;
sFileType : string;
begin
{ initialise ListView and Icon }
ListView.SmallImages := imgList;
Icon := TIcon.Create;
try
ListView.Items.BeginUpdate;
ListItem := listview.items.add;{ Initialise ListView.Item.Add }
{ get details about file type from SHGetFileInfo }
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo,
SizeOf(shInfo), SHGFI_TYPENAME);
sFileType := shInfo.szTypeName;
{ is this a shortcut file ? }
if shInfo.szTypeName = 'Shortcut' then
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
SHGFI_LINKOVERLAY or SHGFI_ICON or
SHGFI_SMALLICON or SHGFI_SYSICONINDEX)
else
{ ...otherwise treat it as a normal file}
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
SHGFI_ICON or SHGFI_SMALLICON or
SHGFI_SYSICONINDEX);
{ assign icon }
Icon.Handle := shInfo.hIcon;
{ List File name, Icon and FileType in ListView}
ListItem.Caption := ExtractFileName(edFileName.Text); //...add filename
ListItem.SubItems.Add(sFileType); //...and filetype..
ListItem.ImageIndex := imgList.AddIcon(Icon); //...and icon.
finally
ListView.Items.EndUpdate; //..free memory on icon and clean up.
sFileType := '';
Icon.Free;
end;
end;
end.
unit cdShortCutIcon;
interface
uses
Windows, Messages, SysUtils, Variants, Graphics, Controls, Forms,
Dialogs, Buttons, ExtCtrls, StdCtrls, StrUtils, ShellAPI,
CommCtrl, ImgList, ComCtrls, Classes;
type
TForm1 = class(TForm)
dlgOpen: TOpenDialog;
ListView: TListView;
imgList: TImageList;
Panel: TPanel;
btnGetFile: TButton;
btnGetIcon: TButton;
edFileName: TEdit;
procedure btnGetFileClick(Sender: TObject);
procedure btnGetIconClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnGetFileClick(Sender: TObject);
begin
{ choose file to get icon from }
if dlgOpen.Execute then edFileName.Text := dlgOpen.FileName;
end;
procedure TForm1.btnGetIconClick(Sender: TObject);
var
Icon : TIcon;
ListItem : TListItem;
shInfo : TSHFileInfo;
sFileType : string;
begin
{ initialise ListView and Icon }
ListView.SmallImages := imgList;
Icon := TIcon.Create;
try
ListView.Items.BeginUpdate;
ListItem := listview.items.add;{ Initialise ListView.Item.Add }
{ get details about file type from SHGetFileInfo }
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo,
SizeOf(shInfo), SHGFI_TYPENAME);
sFileType := shInfo.szTypeName;
{ is this a shortcut file ? }
if shInfo.szTypeName = 'Shortcut' then
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
SHGFI_LINKOVERLAY or SHGFI_ICON or
SHGFI_SMALLICON or SHGFI_SYSICONINDEX)
else
{ ...otherwise treat it as a normal file}
SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
SHGFI_ICON or SHGFI_SMALLICON or
SHGFI_SYSICONINDEX);
{ assign icon }
Icon.Handle := shInfo.hIcon;
{ List File name, Icon and FileType in ListView}
ListItem.Caption := ExtractFileName(edFileName.Text); //...add filename
ListItem.SubItems.Add(sFileType); //...and filetype..
ListItem.ImageIndex := imgList.AddIcon(Icon); //...and icon.
finally
ListView.Items.EndUpdate; //..free memory on icon and clean up.
sFileType := '';
Icon.Free;
end;
end;
end.
{ 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.
}
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.
DelphiWorld 6.0
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.
}
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.
Отправить комментарий