Как вариант
| Код |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Menus, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
PopupMenu1: TPopupMenu;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TKeyMonitor = class(TControl)
private
FWnd: HWND;
FKey: TAtom;
protected
procedure WndProc(var Msg: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TKeyMonitor }
constructor TKeyMonitor.Create(AOwner: TComponent);
begin
inherited;
FWnd := Classes.AllocateHWnd(WndProc);
FKey := GlobalAddAtom('Hotkey_VK_APPS');
if FKey <> 0 then
if not RegisterHotkey(FWnd, FKey, 0, VK_APPS) then
RaiseLastOSError
else
else
RaiseLastOSError;
end;
destructor TKeyMonitor.Destroy;
begin
if not UnregisterHotKey(FWnd, FKey) then
RaiseLastOSError;
if FKey <> 0 then
begin
SetLastError(ERROR_SUCCESS);
GlobalDeleteAtom(FKey);
if GetLastError <> ERROR_SUCCESS then
RaiseLastOSError;
end;
Classes.DeallocateHWnd(FWnd);
inherited;
end;
procedure TKeyMonitor.WndProc(var Msg: TMessage);
begin
with Msg do
if Msg = WM_HOTKEY then
if wParam = FKey then
EndMenu
else
Result := DefWindowProc(FWnd, Msg, wParam, lParam);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ Показ меню под контролем }
with TKeyMonitor.Create(Self), Mouse.CursorPos do
try
{ Заполнение }
PopupMenu1.Items.Add(TMenuItem.Create(Self));
PopupMenu1.Popup(X, Y);
finally
Free;
end;
end;
end.
|
|
)
для TPopupMenu, но напрочь отказывается от работы с TTBPopupMenu из комплекта ToolBar 2000. 
.