unit MenuUtils;

interface

uses
	Classes, Menus, Windows, Messages, AClasses, RefObjects;

type
	TContextItemState = (ciDisabled, ciChecked, ciDefault, ciHidden);
	TContextItemStates = set of TContextItemState;
	TContextItemList = class;
	TContextMenuItem = class;
	TContextEvent = procedure(aData: Longint) of object;

	TContextItem = class(TRefObject)
	private
		FCaption: String;
		FShortcut: TShortcut;
		FState: TContextItemStates;
		FGroup: Integer;
		FItems: TContextItemList;
		FData: Longint;

		FOnClick: TContextEvent;
	protected
		procedure Click; virtual;
	public
		constructor Create(aClick: TContextEvent; const aCaption: String;
			aShortcut: TShortcut; aState: TContextItemStates; aGroup: Integer; aData: Longint);
		destructor Destroy; override;

		property Items: TContextItemList read FItems;
	end;

	TContextItemList = class(TRefObjectList)
	private
		function GetItem(anIndex: Integer): TContextItem;
	public
		property Items[anIndex: Integer]: TContextItem read GetItem; default;
	end;

	TContextMenu = class(TContextItemList)
	private
		FMenuItem: TMenuItem;
		FUtilWindow: HWND;
		FNeedUpdate: Boolean;
		FVisible: Boolean;

		procedure UtilWindowProc(var aMsg: TMessage);
	public
		constructor Create;
		destructor Destroy; override;

		procedure Add(anItem: TContextItem; anAddToBottom: Boolean = True);
		function AddItem(aClick: TContextEvent; const aCaption: String;
			aShortcut: TShortcut; aState: TContextItemStates; aGroup: Integer; aData: Longint;
			anAddToBottom: Boolean = True): TContextItem;
		function AddSeparator(anAddToBottom: Boolean = True): TContextItem;

		procedure Popup(X, Y: Integer);

		procedure UpdateMenuItem;
		property  MenuItem: TMenuItem read FMenuItem write FMenuItem;
	end;

	TContextMenuItem = class(TMenuItem)
	private
		FUtilWindow: HWND;
		FContextItem: TContextItem;
	public
		constructor CreateStub(aContextItem: TContextItem; anUtilWindow: HWND);
		destructor Destroy; override;

		procedure Click; override;
	end;
	
procedure ClearPopup(aPopup: TPopupMenu);
procedure ClearMenu(aMenu: TMenuItem);

const
	DisabledIf: array[Boolean] of TContextItemStates = ([], [ciDisabled]);
	CheckedIf: array[Boolean] of TContextItemStates = ([], [ciChecked]);

procedure ParsePath(const aPath: String; anItems: TStrings);
procedure AddSubItem(aMenu, anItem: TMenuItem);

implementation

uses
	SysUtils, Forms;

var
	FMenuPath: TStringList = nil;

function MenuPath: TStringList;
begin
	if not Assigned(FMenuPath) then
		FMenuPath := TStringList.Create;
	Result := FMenuPath;
end;

procedure ParsePath(const aPath: String; anItems: TStrings);
var
	i, j: Integer;
	s: String;
begin
	i := 1;
	while i <= Length(aPath) do begin
		j := i;
		s := '';
		while j <= Length(aPath) do 
			if aPath[j] = '\' then
				if ((j + 1) > Length(aPath)) or (aPath[j + 1] <> '\') then
					break
				else begin
					s := s + '\';
					Inc(j, 2);
				end
			else begin
				s := s + aPath[j];
				Inc(j);
			end;
		anItems.Add(s);
		i := j + 1;
	end;
end;

procedure ParseMenuPath(const aPath: String);
begin
	MenuPath.Clear;
	ParsePath(aPath, MenuPath);
end;

function FindSubMenu(aParent: TMenuItem; const aCaption: String): TMenuItem;
var
	i: Integer;
begin
	for i := 0 to aParent.Count - 1 do
		if aParent.Items[i].Caption = aCaption then begin
			Result := aParent.Items[i];
			Exit
		end;
	Result := nil;
end;

function CreateSubMenu(aParent: TMenuItem; const aCaption: String): TMenuItem;
begin
	Result := TMenuItem.Create(nil);
	Result.Caption := aCaption;
	aParent.Add(Result);
end;

procedure AddSubItem(aMenu, anItem: TMenuItem);
var
	i: Integer;
	aSubMenu: TMenuItem;
begin
	ParseMenuPath(anItem.Caption);
	i := 0;

	//	Поиск родительского меню
	while i < MenuPath.Count - 1 do begin
		aSubMenu := FindSubMenu(aMenu, MenuPath[i]);
		if Assigned(aSubMenu) then begin
			aMenu := aSubMenu;
			Inc(i);
		end
		else
			break
	end;

	//	Создание недостающих подменю
	while i < MenuPath.Count - 1 do begin
		aMenu := CreateSubMenu(aMenu, MenuPath[i]);
		Inc(i);
	end;

	//	Добавление элемента
	if i < MenuPath.Count then begin
		anItem.Caption := MenuPath[i];
		aMenu.Add(anItem);
	end;
end;

procedure ClearPopup(aPopup: TPopupMenu);
begin
	if Assigned(aPopup) then
		ClearMenu(aPopup.Items);
end;

procedure ClearMenu(aMenu: TMenuItem);
begin
	if Assigned(aMenu) then
		while aMenu.Count > 0 do
			aMenu[0].Free;
end;

{	TContextItem }

constructor TContextItem.Create(aClick: TContextEvent; const aCaption: String;
	aShortcut: TShortcut; aState: TContextItemStates; aGroup: Integer; aData: Longint);
begin
	inherited Create;
	FOnClick := aClick;
	FCaption := aCaption;
	FShortcut := aShortcut;
	FState := aState;
	FGroup := aGroup;
	FData := aData;
	FItems := TContextItemList.Create;
end;

destructor TContextItem.Destroy;
begin
	FItems.Free;
	inherited Destroy;
end;

procedure TContextItem.Click;
begin
	if Assigned(FOnClick) then
		FOnClick(FData);
end;

{	TContextItemList }

function TContextItemList.GetItem(anIndex: Integer): TContextItem;
begin
	Result := inherited Items[anIndex];
end;

{	TContextMenu }

function ReleaseContextRequest(const aMsg: TMsg): Boolean;
begin
	Result := (aMsg.Message = WM_COMMAND) and (aMsg.WParam = 1);
	if Result then
		TContextItem(aMsg.LParam).Release;
end;

function HandleContextRequest(const aMsg: TMessage): Boolean;
var
	anItem: TContextItem;
begin
	Result := (aMsg.Msg = WM_COMMAND) and (aMsg.WParam = 1);
	if Result then begin
		anItem := TContextItem(aMsg.LParam);
		try
			anItem.Click;
		finally
			anItem.Release;
		end;
	end;
end;

{ TContextMenu }

constructor TContextMenu.Create;
begin
	inherited Create;
	FUtilWindow := Classes.AllocateHWnd(UtilWindowProc);
end;

destructor TContextMenu.Destroy;
var
	aMsg: TMsg;
begin
	while PeekMessage(aMsg, FUtilWindow, 0, 0, PM_REMOVE) do
		if not ReleaseContextRequest(aMsg) then
			DispatchMessage(aMsg);
	Classes.DeallocateHWnd(FUtilWindow);
	inherited Destroy;
end;

procedure TContextMenu.UtilWindowProc(var aMsg: TMessage);
begin
	try
		if not HandleContextRequest(aMsg) then
			inherited;
	except
		on e: Exception do
			Application.HandleException(Self)
	end
end;

procedure TContextMenu.UpdateMenuItem;
var
	i: Integer;
begin
	if FVisible then
		FNeedUpdate := True
	else begin
		Assert(Assigned(FMenuItem));
		ClearMenu(FMenuItem);
		for i := 0 to Count - 1 do
			FMenuItem.Add(TContextMenuItem.CreateStub(Items[i], FUtilWindow));

		FNeedUpdate := False;
	end;
end;

function CtxFindSubMenu(aParent: TContextItemList; const aCaption: String): TContextItemList;
var
	i: Integer;
begin
	for i := 0 to aParent.Count - 1 do
		if aParent[i].FCaption = aCaption then begin
			Result := aParent[i].FItems;
			Exit
		end;
	Result := nil;
end;

function CtxCreateSubMenu(aParent: TContextItemList; const aCaption: String;
	anAddToBottom: Boolean): TContextItemList;
var
	anItem: TContextItem;
begin
	anItem := TContextItem.Create(nil, aCaption, 0, [], 0, 0);
	if anAddToBottom then
		aParent.Add(anItem)
	else
		aParent.Insert(0, anItem);
	Result := anItem.FItems;
end;

procedure TContextMenu.Add(anItem: TContextItem; anAddToBottom: Boolean = True);
var
	i: Integer;
	aParentItems,
	anItems: TContextItemList;
begin
	ParseMenuPath(anItem.FCaption);
	i := 0;

	//	Поиск родительского меню
	aParentItems := Self;
	while i < MenuPath.Count - 1 do begin
		anItems := CtxFindSubMenu(aParentItems, MenuPath[i]);
		if Assigned(anItems) then begin
			aParentItems := anItems;
			Inc(i);
		end
		else
			break
	end;

	//	Создание недостающих подменю
	while i < MenuPath.Count - 1 do begin
		aParentItems := CtxCreateSubMenu(aParentItems, MenuPath[i],
			anAddToBottom or (aParentItems <> Self));
		Inc(i);
	end;

	//	Добавление элемента
	if i < MenuPath.Count then begin
		anItem.FCaption := MenuPath[i];
		if anAddToBottom or (aParentItems <> Self) then
			aParentItems.Add(anItem)
		else
			aParentItems.Insert(0, anItem);
	end;
end;

function TContextMenu.AddItem(aClick: TContextEvent; const aCaption: String;
	aShortcut: TShortcut; aState: TContextItemStates; aGroup: Integer; aData: Longint;
	anAddToBottom: Boolean = True): TContextItem;
begin
	Result := TContextItem.Create(aClick, aCaption, aShortcut, aState, aGroup, aData);
	Add(Result, anAddToBottom);
end;

function TContextMenu.AddSeparator(anAddToBottom: Boolean = True): TContextItem;
begin
	Result := TContextItem.Create(nil, '-', 0, [], 0, 0);
	Add(Result, anAddToBottom);
end;


procedure TContextMenu.Popup(X, Y: Integer);
begin
	Assert(Assigned(FMenuItem));
	FVisible := True;
	try
		(FMenuItem.GetParentMenu as TPopupMenu).Popup(X, Y)
	finally
		FVisible := False;
	end;

	if FNeedUpdate then
		UpdateMenuItem;
end;

{	TContextMenuItem }

constructor TContextMenuItem.CreateStub(aContextItem: TContextItem; anUtilWindow: HWND);
var
	i: Integer;
begin
	inherited Create(nil);
	FUtilWindow := anUtilWindow;
	FContextItem := aContextItem;
	FContextItem.AddRef;

	Caption := aContextItem.FCaption;
	ShortCut := aContextItem.FShortCut;
	Enabled := not (ciDisabled in aContextItem.FState);
	Checked := ciChecked in aContextItem.FState;
  Visible := not (ciHidden in aContextItem.FState);

	if aContextItem.FGroup <> 0 then begin
		GroupIndex := aContextItem.FGroup;
		RadioItem := True;
	end;
	Default := ciDefault in aContextItem.FState;
	for i := 0 to aContextItem.Items.Count - 1 do
		Add(TContextMenuItem.CreateStub(aContextItem.Items[i], anUtilWindow));
end;

destructor TContextMenuItem.Destroy;
begin
	if Assigned(FContextItem) then begin
		FContextItem.Release;
		FContextItem := nil;
	end;
	inherited Destroy;
end;

procedure TContextMenuItem.Click;
begin
	if Assigned(FContextItem) and (FUtilWindow <> 0) then begin
		FContextItem.AddRef;
		PostMessage(FUtilWindow, WM_COMMAND, 1, Longint(FContextItem));
	end
end;


initialization
finalization
	FMenuPath.Free;
	FMenuPath := nil;
end.

