Вот что получилось в итоге (демо версия, нужно оптимизировать, глюк с "Send to->My Documents" остался)
| Код |
unit ShellContextMenu;
interface
uses StdCtrls, ComCtrls, ShlObj, ActiveX, ShellCtrls, WIndows, SysUtils, Messages,
Controls, Math;
procedure GetProperties(fNames : array of string; MP : TPoint; WC : TWinControl);
procedure GetPropertiesWindows(fNames : array of string; WC : TWinControl);
implementation
procedure FormatDir(var s:string);
begin
if s='' then exit;
if s[length(s)]<>'\' then s:=s+'\';
end;
Function GetCommonDir(dir1 {Common dir}, dir2 {Compare dir} : String) : String;
var
i, c : integer;
begin
if Dir1=dir2 then
begin
Result:=Dir1;
end else
begin
if dir1=Copy(dir2,1,Length(dir1)) then
begin
Result:=dir1;
exit;
end;
c:=Min(Length(dir1),Length(dir2));
for i:=1 to c do
if dir1[i]<>dir2[i] then
begin
c:=i;
break;
end;
Result:=ExtractFilePath(Copy(dir1,1,c-1));
end;
end;
function GetCommonDirectory(Files : array of string) : String;
var
i, j : integer;
s, temp, d : string;
begin
Result:='';
if Length(Files)=0 then exit;
for i:=0 to Length(Files)-1 do
begin
Files[i]:=ExtractFilePath(Files[i])
end;
s:=Copy(Files[0],1,2);
temp:=Files[0];
for i:=0 to Length(Files)-1 do
begin
Files[i]:=AnsiLowerCase(Files[i]);
If length(Files[i])<2 then exit;
if s<>Copy(Files[i],1,2) then exit;
d:=ExtractFilePath(Files[i]);
if Length(Temp)>Length(d) then
temp:=d;
end;
for i:=0 to Length(Files)-1 do
begin
temp:=GetCommonDir(temp,Files[i]);
end;
Result:=temp;
end;
function MenuCallback(Wnd: HWND; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall;
var
ContextMenu2: IContextMenu2;
begin
case Msg of
WM_CREATE:
begin
ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams);
SetWindowLong(Wnd, GWL_USERDATA, Longint(ContextMenu2));
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
WM_INITMENUPOPUP:
begin
ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
Result := 0;
end;
WM_DRAWITEM, WM_MEASUREITEM:
begin
ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
Result := 1;
end;
else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
end;
function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND;
const
IcmCallbackWnd = 'ICMCALLBACKWND';
var
WndClass: TWndClass;
begin
FillChar(WndClass, SizeOf(WndClass), #0);
WndClass.lpszClassName := PChar(IcmCallbackWnd);
WndClass.lpfnWndProc := @MenuCallback;
WndClass.hInstance := HInstance;
Windows.RegisterClass(WndClass);
Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0,
0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu));
end;
procedure GetProperties(fNames : array of string; MP : TPoint; WC : TWinControl);
var
dISF,ISF:IShellFolder;
ICMenu:IContextMenu;
ICMenu2: IContextMenu2;
CMD:TCMInvokeCommandInfo;
PathPIDL:PItemIDList;
FilePIDLs : array of PItemIDList;
cIE,HR:HResult;
M:IMAlloc;
pMenu:HMenu;
fPath:PWideChar;
sFP,sFN,s:string;
Attr,L:Cardinal;
fPM:LongBool;
ICmd:integer;
ZVerb: array[0..1023] of char;
Verb: string;
Handled:Boolean;
SCV:IShellCommandVerb;
i, len : integer;
CallbackWindow: HWND;
begin
pMenu:=0;
Attr:=0;
PathPIDL:=nil;
cIE:=CoInitializeEx(nil,COINIT_MULTITHREADED);
try
sFP:=GetCommonDirectory(fNames);
len:=length(sFP);
sFN:=fNames[0];
Delete(sFN,1,length(sFP));
if SHGetDesktopFolder(dISF)<>S_OK then exit;
if sFN='' then
begin
sFN:=sFP;
fPath:=StringToOleStr(sFN);
L:=Length(sFN);
if (SHGetSpecialFolderLocation(0,CSIDL_DRIVES,PathPIDL)<>S_OK) or
(dISF.BindToObject(PathPIDL,nil,IID_IShellFolder,Pointer(ISF))<>S_OK) then exit;
SetLength(FilePIDLs,1);
ISF.ParseDisplayName(WC.Handle,nil,fPath,L,FilePIDLs[0],Attr);
HR:=ISF.GetUIObjectOf(WC.Handle,1,FilePIDLs[0],IID_IContextMenu,nil,Pointer(ICMenu));
end else
begin
fPath:=StringToOleStr(sFP);
L:=Length(sFP);
SetLength(FilePIDLs,Length(fNames)+1);
FillChar(FilePIDLs[Length(fNames)],Sizeof(PItemIDList),#0);
for i:=0 to Length(fNames)-1 do
FilePIDLs[i]:=nil;
if (dISF.ParseDisplayName(WC.Handle,nil,fPath,L,PathPIDL,Attr)<>S_OK)or
(dISF.BindToObject(PathPIDL,nil,IID_IShellFolder,Pointer(ISF))<>S_OK) then exit;
for i:=0 to Length(fNames)-1 do
begin
delete(fNames[i],1,len);
fPath:=StringToOleStr(fNames[i]);
L:=Length(fNames[i]);
ISF.ParseDisplayName(WC.Handle,nil,fPath,L,FilePIDLs[i],Attr);
end;
HR:=ISF.GetUIObjectOf(WC.Handle,Length(fNames),FilePIDLs[0],IID_IContextMenu,nil,Pointer(ICMenu));
end;
if Succeeded(HR) then
begin
ICMenu2:=nil;
Windows.ClientToScreen(WC.Handle,MP);
pMenu:=CreatePopupMenu;
if Succeeded(ICMenu.QueryContextMenu(pMenu, 0, 1, $7FFF, CMF_EXPLORE)) then
CallbackWindow := 0;
if Succeeded(ICMenu.QueryInterface(IContextMenu2, ICMenu2)) then
begin
CallbackWindow := CreateMenuCallbackWnd(ICMenu2);
end;
try
fPM:=TrackPopupMenu(pMenu,TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD,MP.X,MP.Y,0,CallbackWindow,nil);
finally
ICMenu2:=nil;
end;
if fPM then
begin
ICmd:=LongInt(fPM)-1;
HR:=ICMenu.GetCommandString(ICmd,GCS_VERBA,nil,ZVerb,SizeOf(ZVerb));
Verb:=StrPas(ZVerb);
Handled:=False;
if Supports(WC,IShellCommandVerb,SCV) then
begin
HR:=0;
SCV.ExecuteCommand(Verb, Handled);
end;
if not(Handled) then
begin
FillChar(CMD,SizeOf(CMD),#0);
with CMD do
begin
cbSize:=SizeOf(CMD);
hWND:=WC.Handle;
lpVerb:=MakeIntResource(ICmd);
nShow:=SW_SHOWNORMAL;
end;
HR:=ICMenu.InvokeCommand(CMD);
end;
if Assigned(SCV) then
SCV.CommandCompleted(Verb,HR=S_OK);
end;
end;
finally
for i:=0 to Length(fNames)-1 do
if FilePIDLs[i]<>nil then
begin
SHGetMAlloc(M);
M.Free(FilePIDLs[i]);
M:=nil;
end;
if PathPIDL<>nil then
begin
SHGetMAlloc(M);
M.Free(PathPIDL);
M:=nil;
end;
if pMenu<>0 then DestroyMenu(pMenu);
if CallbackWindow <> 0 then DestroyWindow(CallbackWindow);
ICMenu:=nil;
ISF:=nil;
dISF:=nil;
if cIE=S_OK then CoUninitialize;
end;
end;
procedure GetPropertiesWindows(fNames : array of string; WC : TWinControl);
var
dISF,ISF:IShellFolder;
ICMenu:IContextMenu;
CMD:TCMInvokeCommandInfo;
PathPIDL:PItemIDList;
FilePIDLs : array of PItemIDList;
cIE,HR:HResult;
M:IMAlloc;
pMenu:HMenu;
fPath:PWideChar;
sFP,sFN:string;
Attr,L:Cardinal;
ICmd:integer;
ZVerb: array[0..1023] of char;
Verb: string;
Handled:Boolean;
SCV:IShellCommandVerb;
i, len : integer;
begin
pMenu:=0;
Attr:=0;
PathPIDL:=nil;
cIE:=CoInitializeEx(nil,COINIT_MULTITHREADED);
try
sFP:=GetCommonDirectory(fNames);
len:=length(sFP);
sFN:=fNames[0];
Delete(sFN,1,length(sFP));
if SHGetDesktopFolder(dISF)<>S_OK then exit;
if sFN='' then
begin
sFN:=sFP;
fPath:=StringToOleStr(sFN);
L:=Length(sFN);
if (SHGetSpecialFolderLocation(0,CSIDL_DRIVES,PathPIDL)<>S_OK) or
(dISF.BindToObject(PathPIDL,nil,IID_IShellFolder,Pointer(ISF))<>S_OK) then exit;
SetLength(FilePIDLs,1);
ISF.ParseDisplayName(WC.Handle,nil,fPath,L,FilePIDLs[0],Attr);
HR:=ISF.GetUIObjectOf(WC.Handle,1,FilePIDLs[0],IID_IContextMenu,nil,Pointer(ICMenu));
end else
begin
fPath:=StringToOleStr(sFP);
L:=Length(sFP);
SetLength(FilePIDLs,Length(fNames)+1);
FillChar(FilePIDLs[Length(fNames)],Sizeof(PItemIDList),#0);
for i:=0 to Length(fNames)-1 do
FilePIDLs[i]:=nil;
if (dISF.ParseDisplayName(WC.Handle,nil,fPath,L,PathPIDL,Attr)<>S_OK)or
(dISF.BindToObject(PathPIDL,nil,IID_IShellFolder,Pointer(ISF))<>S_OK) then exit;
for i:=0 to Length(fNames)-1 do
begin
delete(fNames[i],1,len);
fPath:=StringToOleStr(fNames[i]);
L:=Length(fNames[i]);
ISF.ParseDisplayName(WC.Handle,nil,fPath,L,FilePIDLs[i],Attr);
end;
HR:=ISF.GetUIObjectOf(WC.Handle,Length(fNames),FilePIDLs[0],IID_IContextMenu,nil,Pointer(ICMenu));
end;
if Succeeded(HR) then
begin
pMenu:=CreatePopupMenu;
if Succeeded(ICMenu.QueryContextMenu(pMenu, 0, 1, $7FFF, CMF_EXPLORE)) then
FillChar(CMD,SizeOf(CMD),#0);
with CMD do
begin
cbSize:=SizeOf(CMD);
hWND:=WC.Handle;
lpVerb:='Properties';
nShow:=SW_SHOWNORMAL;
end;
HR:=ICMenu.InvokeCommand(CMD);
if Assigned(SCV) then
SCV.CommandCompleted(Verb,HR=S_OK);
end;
finally
for i:=0 to Length(fNames)-1 do
if FilePIDLs[i]<>nil then
begin
SHGetMAlloc(M);
M.Free(FilePIDLs[i]);
M:=nil;
end;
if PathPIDL<>nil then
begin
SHGetMAlloc(M);
M.Free(PathPIDL);
M:=nil;
end;
dISF:=nil;
if cIE=S_OK then CoUninitialize;
end;
end;
end.
|
|
, а ещё лишний пункт присутствует - Rename? Можно это как-нибудь подправить? Что-то я не совсем тут понимаю 
.