unit ContextMenuHandle;
interface
uses Windows,ActiveX,ComObj,ShlObj,Classes;
type
TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
private
FFileName: array[0..MAX_PATH] of Char;
protected
function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; stdcall;
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;
end;
const
Class_ContextMenu: TGUID = '{19741013-C829-11D1-8233-0020AF3E97A0}';
{全局唯一标识符(GUID)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}
var
FileList:TStringList;
implementation
uses ComServ, SysUtils, ShellApi, Registry,UnitForm;
function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
FileNumber,i:Integer;
begin
file://如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;
end;
file://首先初始化并清空FileList以添加文件
FileList:=TStringList.Create;
FileList.Clear;
file://初始化剪贴版格式文件
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result) then Exit;
file://首先查询用户选中的文件的个数
FileNumber := DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0);
file://循环读取，将所有用户选中的文件保存到FileList中
for i:=0 to FileNumber-1 do begin
DragQueryFile(StgMedium.hGlobal, i, FFileName, SizeOf(FFileName));
FileList.Add(FFileName);
Result := NOERROR;
end;
ReleaseStgMedium(StgMedium);
end;
function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0;
if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
// 往Context Menu中加入一个菜单项 ,菜单项的标题为察看位图文件
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
PChar('文件操作'));
// 返回增加菜单项的个数
Result := 1;
end;
end;
function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
frmOP:TForm1;
begin
// 首先确定该过程是被系统而不是被一个程序所调用
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin
Result := E_FAIL;
Exit;
end;
// 确定传递的参数的有效性
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;
end;
file://建立文件操作窗口
frmOP:=TForm1.Create(nil);
file://将所有的文件列表添加到文件操作窗口的列表中
frmOP.ListBox1.Items := FileList;
Result := NOERROR;
end;
function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin
if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then
{返回该菜单项的帮助信息，此帮助信息将在用户把鼠标
移动到该菜单项时出现在状态条上。}
StrCopy(pszName, PChar('点击该菜单项将执行文件操作'));
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;
type
TContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean); override;
end;
procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
if Register then begin
inherited UpdateRegistry(Register);
ClassID := GUIDToString(Class_ContextMenu);
file://当注册扩展库文件时，添加库到注册表中
CreateRegKey('*shellex', ', ');
CreateRegKey('*shellexContextMenuHandlers', ', ');
CreateRegKey('*shellexContextMenuHandlersFileOpreation', ', ClassID);
file://如果操作系统为Windows NT的话
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWAREMicrosoftWindowsCurrentVersionShell Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'Context Menu Shell Extension');
finally
Free;
end;
end
else begin
DeleteRegKey('*shellexContextMenuHandlersFileOpreation');
inherited UpdateRegistry(Register);
end;
end;
initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
', 'Context Menu Shell Extension', ciMultiInstance,tmApartment);
end.
在OpWindow窗口中加入一个TListBox控件和两个TButton控件，OpWindows.pas的程序清单如下：
unit opwindow;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls,shlobj,shellapi,ActiveX;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
FileList:TStringList;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
FileList:=TStringList.Create;
Button1.Caption :='复制文件';
Button2.Caption :='移动文件';
Self.Show;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FileList.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sPath:string;
fsTemp:SHFILEOPSTRUCT;
i:integer;
begin
sPath:=InputBox('文件操作','输入复制路径','c:windows');
if sPath<>'then begin
fsTemp.Wnd := Self.Handle;
file://设置文件操作类型
fsTemp.wFunc :=FO_COPY;
file://允许执行撤消操作
fsTemp.fFlags :=FOF_ALLOWUNDO;
for i:=0 to ListBox1.Items.Count-1 do begin
file://源文件全路径名
fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
file://要复制到的路径
fsTemp.pTo := PChar(sPath);
fsTemp.lpszProgressTitle:='拷贝文件';
if SHFileOperation(fsTemp)<>0 then
ShowMessage('文件复制失败');
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
sPath:string;
fsTemp:SHFILEOPSTRUCT;
i:integer;
begin
sPath:=InputBox('文件操作','输入移动路径','c:windows');
if sPath<>'then begin
fsTemp.Wnd := Self.Handle;
fsTemp.wFunc :=FO_MOVE;
fsTemp.fFlags :=FOF_ALLOWUNDO;
for i:=0 to ListBox1.Items.Count-1 do begin
fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
fsTemp.pTo := PChar(sPath);
fsTemp.lpszProgressTitle:='移动文件';
if SHFileOperation(fsTemp)<>0 then
ShowMessage('文件复制失败');
end;
end;
end;
end.
上一页123下一页
