(*//

标题:目录转换成菜单项;获取系统图标

说明:示例打开文件

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

 ShellApi;

function GetSystemImageList(mImageList: TImageList): Boolean;

{ 返回系统图标到图形列表中是否成功 }

var

 vHandle: THandle;

 vSHFileInfo: TSHFileInfo;

begin

 FillChar(vSHFileInfo, SizeOf(vSHFileInfo), 0);

 vHandle := SHGetFileInfo('', 0, vSHFileInfo, SizeOf(vSHFileInfo),

   SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

 Result := vHandle <> 0;

 mImageList.Handle := vHandle;

 mImageList.ShareImages := True;

end; { GetSystemImageList }

function GetIconIndex(mPath: string): Integer;

{ 返回文件或路径所对应的图标序号 }

var

 vSHFileInfo: TSHFileInfo;

begin

 FillChar(vSHFileInfo, SizeOf(vSHFileInfo), 0);

 SHGetFileInfo(PChar(mPath), 0, vSHFileInfo, SizeOf(vSHFileInfo),

   SHGFI_SYSICONINDEX);

 Result := vSHFileInfo.iIcon;

end; { GetIconIndex }

procedure PathToMenuItem(mDirName: string; mMenuItem: TMenuItem;

 mItemClick: TNotifyEvent = nil);

{ 返回目录转换成菜单项是否成功 }

var

 vSearchRec: TSearchRec;

 vPathName: string;

 K: Integer;

 vMenuItem: TMenuItem;

begin

 vPathName := mDirName + '\*.*';

 K := FindFirst(vPathName, faAnyFile, vSearchRec);

 while K = 0 do begin

   if (vSearchRec.Attr and faDirectory <> 0) and

     (Pos(vSearchRec.Name, '..') = 0) then begin

     vMenuItem := TMenuItem.Create(mMenuItem.Owner);

     vMenuItem.Caption := vSearchRec.Name;

     vMenuItem.Hint := mDirName + '\' + vSearchRec.Name;

     vMenuItem.ImageIndex := GetIconIndex(mDirName + '\' + vSearchRec.Name);

     vMenuItem.OnClick := mItemClick;

     mMenuItem.Add(vMenuItem);

     PathToMenuItem(mDirName + '\' + vSearchRec.Name, vMenuItem)

   end else if (Pos(vSearchRec.Name, '..') = 0) then begin

     vMenuItem := TMenuItem.Create(mMenuItem.Owner);

     vMenuItem.Caption := vSearchRec.Name;

     vMenuItem.Hint := mDirName + '\' + vSearchRec.Name;

     vMenuItem.ImageIndex := GetIconIndex(mDirName + '\' + vSearchRec.Name);

     vMenuItem.OnClick := mItemClick;

     mMenuItem.Add(vMenuItem);

   end;

   K := FindNext(vSearchRec);

 end;

 FindClose(vSearchRec);

end; { PathToMenuItem }

///////End Source

///////Begin Demo

{ uses FileCtrl }

procedure TForm1.Button1Click(Sender: TObject);

var

 vDirectory: string;

begin

 { 测试时不要选择内容太多的目录 }

 if not SelectDirectory('Path', '', vDirectory) then Exit;

 MainMenu1.Items.Clear;

 PathToMenuItem(vDirectory, MainMenu1.Items, ItemClick);

 PopupMenu1.Items.Clear;

 PathToMenuItem(vDirectory, PopupMenu1.Items, ItemClick);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

 GetSystemImageList(ImageList1);

 ImageList1.DrawingStyle := dsTransparent;

 MainMenu1.AutoHotkeys := maManual;

 MainMenu1.Images := ImageList1;

 PopupMenu1.AutoHotkeys := maManual;

 PopupMenu1.Images := ImageList1;

end;

procedure TForm1.ItemClick(Sender: TObject);

begin

 if FileExists(TMenuItem(Sender).Hint) then //避免目录

   ShellExecute(Handle, 'OPEN', PChar(TMenuItem(Sender).Hint), nil, nil, SW_SHOW);

end;

///////End Demo