begin
FillChar(SFileinfo, Sizeof(SFileinfo), #0);
ShGetFileInfo(Pchar(aExt), 0, SFileinfo, SizeOf(SFileinfo), aFlags);
Result := SFileinfo.iIcon;
end;
先用GetSysImageList函数实现ImageList跟系统图标共享，然后跟据文件名获得文件在系统中图标的索引值。
完整代码如下：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ImgList, Menus, StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Edit1: TEdit;
Button1: TButton;
PopupMenu1: TPopupMenu;
ImageList1: TImageList;
procedure Button1Click(Sender: TObject);
procedure PopupMenu1Popup(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
procedure ShowPopupMenu(Sender: TObject; Pm: TPopupMenu);
{* 弹出菜单}
procedure MenuItemClick(Sender: TObject);
{* //如果当创建的菜单有子菜单时则移动鼠标则会触法下面的事件，反之则单击菜单项才触法下面的事件。}
procedure ShowPMFileIcon(Pm: TPopupMenu; aPath: String; aParent:
TMenuItem=nil; aFirst: Boolean = True);
{* 枚举某个文件夹下的所有文件及了文件夹到菜单上}
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
ShellApi;
var
Folder: String;
First: Boolean = True;
//得到文件的图标索引
function GetFileIconIndex(aExt: String): Integer;
Const
aFlags = SHGFI_SMALLICON OR SHGFI_SYSICONINDEX;
Var
SFileinfo: TShFileInfo;
begin
FillChar(SFileinfo, Sizeof(SFileinfo), #0);
ShGetFileInfo(Pchar(aExt), 0, SFileinfo, SizeOf(SFileinfo), aFlags);
Result := SFileinfo.iIcon;
end;
//把系统图标添加到ImageList中
procedure GetSysImageList(aImageList: TImageList);
Const
aFlags = SHGFI_SMALLICON OR SHGFI_SYSICONINDEX;
Var
SFileinfo: TShFileInfo;
begin
FillChar(SFileinfo, Sizeof(SFileinfo), #0);
aImageList.ShareImages := True;
aImageList.DrawingStyle := dsTransParent;
aImageList.Handle := ShGetFileInfo(', 0, SFileInfo,
SiZeof(SFileInfo), aFlags);
end;
//统计某个文件夹下的文件个数
function TotalFileCount(aPath: String): Integer;
var
sr: TSearchRec;
i: integer;
aTempPath: String;
begin
i:= -1;
aTempPath := IncludeTrailingBackslash(aPath) '*.*'; //修正文件夹名称
if FindFirst(aTempPath, faAnyFile, sr)=0 then
begin
while FindNext(sr) = 0 do
if sr.name[1]<>'.' then inc(i);
FindClose(sr);
end;
Result := i;
end;
//得到当前菜单项的完整文件名
function GetMenuFileName(aChild: TMenuItem): String;
begin
Result := aChild.Caption '\' Result;
if Assigned(aChild.Parent) then
Result := GetMenuFileName(aChild.Parent)
else
Result := Copy(Result, 2, Max_Path);
end;
//如果当创建的菜单有子菜单时则移动鼠标则会触法下面的事件，反之则单击菜单项才触法下面的事件。
procedure TForm1.MenuItemClick(Sender: TObject);
var
aFileName: String;
iIndex: integer;
begin
aFileName := Folder GetMenuFileName(TMenuItem(Sender));
//如果是文件则单击打开
if TMenuItem(Sender).Tag = 0 then
ShellExecute(0, 'Open', PChar(aFileName), nil, nil, SW_SHOWNORMAL)
else
begin
if TMenuItem(Sender).Count = 1 then
begin
ShowPMFileIcon(PopupMenu1, aFileName, TMenuItem(Sender));
iIndex := TotalFileCount(aFileName);
if iIndex <> -1 then
TMenuItem(Sender).Delete(0);
end;
end;
end;
//枚举某个文件夹下的所有文件及了文件夹到菜单上
procedure TForm1.ShowPMFileIcon(Pm: TPopupMenu; aPath: String; aParent:
TMenuItem=nil; aFirst: Boolean = True);
var
sr: TSearchRec;
i: integer;
aMenuItem: TMenuItem;
mnuEmpty: TmenuItem;
aTempPath: String;
{* 得到文件图标索引}
function MenuImageIndex: integer;
begin
Result := GetFileIconIndex(aTempPath sr.name);
end;
{* 添加空菜单项}
procedure EmptyMenuItem;
begin
if (sr.attr and faDirectory)= faDirectory then
begin
aMenuItem.Tag := 1; //标记该菜单为文件夹
mnuEmpty := TMenuItem.Create(Pm);
mnuEmpty.Caption := '(空)';
mnuEmpty.Enabled := False;
aMenuItem.Add(mnuEmpty);
end;
end;
begin
aTempPath := IncludeTrailingBackslash(aPath);
i := FindFirst(aTempPath '*.*', faAnyFile, sr);
while i=0 do
begin
if sr.Name[1] <> '.' then //如果文件名不为"."或".."
begin
aMenuItem := TMenuItem.Create(aParent);
aMenuItem.Hint := aTempPath;
aMenuItem.ImageIndex := MenuImageIndex;
aMenuItem.Caption := sr.Name;
aMenuItem.OnClick := MenuItemClick;
if aParent = nil then
Pm.Items.Add(aMenuItem)
else
aParent.Add(aMenuItem);
{* 添加空菜单项}
EmptyMenuItem;
end;
{* 查找下一个文件}
i := FindNext(sr);
end;
FindClose(sr);
end;
文章整理：西部数码--专业提供域名注册、虚拟主机服务
http://www.west263.com
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!
