Remy's answer is correct, but I'm providing this answer because I have written a little unit to do Project Menu (context menu) integration, and as well, as a bonus, this demo also shows main menu and IDE insight.
The code snippet in my answer covers how to actually write the code which is in several layers of classes, one of which must implement IOTAProjectMenuItemCreatorNotifier interface.
The demo on bitbucket actually does several things that are useful:
- As this question asks, it puts a custom item in the project right click context menu.
- It also registers a global keyboard shortcut (hotkey).
- It also makes the same action visible in the IDE insight search.
- It also adds a menu to the main menu.
Handling the interfaces that Remy's answer discusses is non-trivial, so I have made a working example.
unit HelloExpertContextMenu;
// Example of a Project Right Click (Context) menu for Delphi 10 Seattle
// using OTAPI. Must be provided an action list full of actions with valid
// unique names.
//
// Register menu:
//
// Similar code would work in RAD Studio 2010 and newer, but not in older
// Delphi versions.
interface
uses Classes,
SysUtils,
Generics.Collections,
Vcl.ActnList,
ToolsAPI,
Menus,
Windows,
Messages;
type
TProjectManagerMenu = class(TNotifierObject, IOTANotifier, IOTAProjectMenuItemCreatorNotifier)
private
FActionList: TActionList; // reference only.
FProject: IOTAProject; // Reference valid ONLY during MenuExecute
FNotifierIndex: Integer;
FFault:Boolean; // nicer than raising inside the IDE.
{ IOTAProjectMenuItemCreatorNotifier }
procedure AddMenu(const Project: IOTAProject; const Ident: TStrings;
const ProjectManagerMenuList: IInterfaceList; IsMultiSelect: Boolean);
protected
procedure ExecuteVerb(const Verb:string);
public
procedure InstallMenu;
constructor Create(ActionList:TActionList);
procedure MenuExecute(const MenuContextList: IInterfaceList);
property Project: IOTAProject read FProject; // Reference valid ONLY during MenuExecute
property Fault: Boolean read FFault; // InstallMenu fail.
end;
TOTAActionMenu = class(TInterfacedObject, IOTANotifier, IOTALocalMenu)
private
FAction:TAction;
FParent: string;
FPosition: Integer;
public
{ IOTANotifier }
procedure AfterSave;
procedure BeforeSave;
procedure Destroyed;
procedure Modified;
public
{ IOTALocalMenu }
function GetCaption: string;
function GetChecked: Boolean;
function GetEnabled: Boolean;
function GetHelpContext: Integer;
function GetName: string;
function GetParent: string;
function GetPosition: Integer;
function GetVerb: string;
procedure SetChecked(Value: Boolean);
procedure SetEnabled(Value: Boolean);
procedure SetHelpContext(Value: Integer);
procedure SetName(const Value: string);
procedure SetParent(const Value: string);
procedure SetPosition(Value: Integer);
procedure SetVerb(const Value: string);
procedure SetCaption(const Value: string);
property Action: TAction read FAction write FAction; // MUST NOT BE NIL!
property Caption: string read GetCaption write SetCaption;
property Checked: Boolean read GetChecked write SetChecked;
property Enabled: Boolean read GetEnabled write SetEnabled;
property HelpContext: Integer read GetHelpContext write SetHelpContext;
property Name: string read GetName write SetName;
property Parent: string read GetParent write SetParent;
property Position: Integer read GetPosition write SetPosition;
property Verb: string read GetVerb write SetVerb;
end;
TProjectManagerMenuExecuteEvent = procedure (const MenuContextList: IInterfaceList) of object;
TOTAProjectManagerActionMenu = class(TOTAActionMenu, IOTANotifier, IOTALocalMenu, IOTAProjectManagerMenu)
private
FIsMultiSelectable: Boolean;
public
{ IOTAProjectManagerMenu }
function GetIsMultiSelectable: Boolean;
procedure SetIsMultiSelectable(Value: Boolean);
procedure Execute(const MenuContextList: IInterfaceList); overload;
function PreExecute(const MenuContextList: IInterfaceList): Boolean;
function PostExecute(const MenuContextList: IInterfaceList): Boolean;
property IsMultiSelectable: Boolean read GetIsMultiSelectable write SetIsMultiSelectable;
end;
implementation
constructor TProjectManagerMenu.Create(ActionList:TActionList);
begin
inherited Create;
FActionList := ActionList;
end;
procedure TProjectManagerMenu.ExecuteVerb(const Verb: string);
var
AnAction: TAction;
begin
if Assigned(FActionList) then
begin
AnAction := FActionList.FindComponent(Verb) as TAction;
if Assigned(AnAction) then
AnAction.Execute();
end;
end;
procedure TProjectManagerMenu.InstallMenu;
var
OTAProjectManager: IOTAProjectManager;
begin
if Supports(BorlandIDEServices, IOTAProjectManager, OTAProjectManager) then
FNotifierIndex := OTAProjectManager.AddMenuItemCreatorNotifier(Self)
else
FFault := True;
end;
procedure TProjectManagerMenu.AddMenu(const Project: IOTAProject; const Ident: TStrings;
const ProjectManagerMenuList: IInterfaceList; IsMultiSelect: Boolean);
var
AMenu: TOTAProjectManagerActionMenu;
Action:TAction;
n:Integer;
begin
if (not IsMultiSelect) and Assigned(Project) and (Ident.IndexOf(sProjectContainer) <> -1) then
begin
for n := 0 to FActionList.ActionCount-1 do
begin
Action := FActionList.Actions[n] as TAction;
if Action.Name ='' then
Action.Name := 'HelloExpertContextMenuAction'+IntToStr(n+1);
AMenu := TOTAProjectManagerActionMenu.Create;
AMenu.Action := Action;
if AMenu.Caption='' then
AMenu.Caption := 'Menu Item Text Missing'+IntToStr(n);
AMenu.IsMultiSelectable := True;
AMenu.Position := pmmpUserBuild;
ProjectManagerMenuList.Add(AMenu);
end;
end;
end;
procedure TProjectManagerMenu.MenuExecute(const MenuContextList: IInterfaceList);
var
Index: Integer;
MenuContext: IOTAProjectMenuContext;
Verb: string;
begin
try
for Index := 0 to MenuContextList.Count - 1 do
begin
MenuContext := MenuContextList.Items[Index] as IOTAProjectMenuContext;
FProject := MenuContext.Project;
try
Verb := MenuContext.Verb;
ExecuteVerb(Verb);
finally
FProject := nil;
end;
end;
except
on E:Exception do
begin
OutputDebugString(PChar(E.Message));
end;
end;
end;
procedure TOTAActionMenu.AfterSave;
begin
end;
procedure TOTAActionMenu.BeforeSave;
begin
end;
procedure TOTAActionMenu.Destroyed;
begin
end;
procedure TOTAActionMenu.Modified;
begin
end;
function TOTAActionMenu.GetCaption: string;
begin
Result := FAction.Caption;
end;
function TOTAActionMenu.GetChecked: Boolean;
begin
Result := FAction.Checked;
end;
function TOTAActionMenu.GetEnabled: Boolean;
begin
Result := FAction.Enabled;
end;
function TOTAActionMenu.GetHelpContext: Integer;
begin
Result := FAction.HelpContext;
end;
function TOTAActionMenu.GetName: string;
begin
Result := FAction.Name;
end;
function TOTAActionMenu.GetParent: string;
begin
Result := FParent;
end;
function TOTAActionMenu.GetPosition: Integer;
begin
Result := FPosition;
end;
function TOTAActionMenu.GetVerb: string;
begin
Result := FAction.Name; // Name is also Verb
end;
procedure TOTAActionMenu.SetCaption(const Value: string);
begin
FAction.Caption := Value;
end;
procedure TOTAActionMenu.SetChecked(Value: Boolean);
begin
FAction.Checked := Value;
end;
procedure TOTAActionMenu.SetEnabled(Value: Boolean);
begin
FAction.Enabled := Value;
end;
procedure TOTAActionMenu.SetHelpContext(Value: Integer);
begin
FAction.HelpContext := Value;
end;
procedure TOTAActionMenu.SetName(const Value: string);
begin
FAction.Name := Value;
end;
procedure TOTAActionMenu.SetParent(const Value: string);
begin
FParent := Value;
end;
procedure TOTAActionMenu.SetPosition(Value: Integer);
begin
FPosition := Value;
end;
procedure TOTAActionMenu.SetVerb(const Value: string);
begin
FAction.Name := Value; // NAME == VERB!
end;
//=== { TOTAProjectManagerActionMenu } ==========================================
function TOTAProjectManagerActionMenu.GetIsMultiSelectable: Boolean;
begin
Result := FIsMultiSelectable;
end;
procedure TOTAProjectManagerActionMenu.SetIsMultiSelectable(Value: Boolean);
begin
FIsMultiSelectable := Value;
end;
procedure TOTAProjectManagerActionMenu.Execute(const MenuContextList: IInterfaceList);
begin
if Assigned(FAction) then
begin
FAction.Execute;
end;
end;
function TOTAProjectManagerActionMenu.PreExecute(const MenuContextList: IInterfaceList): Boolean;
begin
Result := True;
end;
function TOTAProjectManagerActionMenu.PostExecute(const MenuContextList: IInterfaceList): Boolean;
begin
Result := True;
end;
end.
complete working example on bitbucket at https://bitbucket.org/wpostma/helloworldexpert
