unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, ShellCtrls, Messages, ShlObj;
type
{ TForm1 }
TForm1 = class(TForm)
ShellTreeView1: TShellTreeView;
procedure FormCreate(Sender: TObject);
procedure ShellTreeView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FICM2: IContextMenu2;
FICM3: IContextMenu3;
procedure DoExplorerContextMenu(ScreenPos: TPoint; const Path: string);
protected
procedure WndProc(var Message: TMessage); override;
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses Windows;
function GetItemIdList(const InFolder: IShellFolder;
const ByFileName: string; out ToItem: PItemIdList): Boolean;
begin
Result := (InFolder <> nil) and (ByFileName <> '') and
(InFolder.ParseDisplayName(0, nil, Pointer(WideString(ByFileName)),
ULONG(nil^), ToItem, ULONG(nil^)) = S_OK);
end;
function GetContextMenu(const Path: string; out Menu: IContextMenu): Boolean;
var
PathAsDir, ParentPath: string;
Desktop, Parent: IShellFolder;
P: PItemIdList;
begin
Result := False;
PathAsDir := ExcludeTrailingPathDelimiter(Path);
if DirectoryExists(PathAsDir) then
begin
ParentPath := ExtractFilePath(PathAsDir);
if (SHGetDesktopFolder(Desktop) = S_OK) and
GetItemIdList(Desktop, ParentPath, P) and
(Desktop.BindToObject(P, nil, IID_IShellFolder, Parent) = S_OK) and
GetItemIdList(Parent, ExtractFileName(PathAsDir), P) then
begin
Result := Parent.GetUIObjectOf(0, 1, P, IID_IContextMenu, nil, Menu) = S_OK;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ShellTreeView1.Root := 'C:\';
ShellTreeView1.RightClickSelect := True;
end;
procedure TForm1.ShellTreeView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbRight then
begin
DoExplorerContextMenu(ShellTreeView1.ClientToScreen(Classes.Point(X, Y)),
ShellTreeView1.Path);
end;
end;
procedure TForm1.DoExplorerContextMenu(ScreenPos: TPoint; const Path: string);
var
ICM: IContextMenu;
SysMenu: HMenu;
Ok: LongBool;
Info: ShlObj.TCMInvokeCommandInfo;
begin
if not GetContextMenu(Path, ICM) then
Exit;
SysMenu := CreatePopupMenu;
try
if not Succeeded(ICM.QueryContextMenu(SysMenu, 0, 1, $7FFF, CMF_EXPLORE)) then
Exit;
try
ICM.QueryInterface(IContextMenu3, FICM3); // For submenus
if not Assigned(FICM3) then
ICM.QueryInterface(IContextMenu2, FICM2); // For submenus
Ok := TrackPopupMenu(SysMenu, TPM_LEFTALIGN or TPM_LEFTBUTTON or
TPM_RIGHTBUTTON or TPM_RETURNCMD, ScreenPos.X, ScreenPos.Y, 0,
Handle, nil);
finally
FICM2 := nil;
FICM3 := nil;
end;
if Ok then
begin
ZeroMemory(@Info, SizeOf(Info));
with Info do
begin
cbSize := SizeOf(Info);
hWND := Handle;
lpVerb := MakeIntResource(LongInt(Ok) - 1);
nShow := SW_SHOWNORMAL;
end;
ICM.InvokeCommand(Info);
end;
finally
DestroyMenu(SysMenu);
end;
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
with Message do
if Assigned(FICM3) then
begin
if FICM3.HandleMenuMsg2(Msg, WParam, LParam, @Result) = S_OK then
Exit;
end
else
if Assigned(FICM2) then
begin
if FICM2.HandleMenuMsg(Msg, WParam, LParam) = S_OK then
Exit;
end;
inherited;
end;
end.