VPF::Не закрывающееся всплывающее меню

bems

Дата 15.6.2007, 19:16 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 3400
Регистрация: 5.1.2006

Репутация: 31
Всего: 88

написал пример
вот такой модуль:

Код


unit MyMenus;

interface
uses Menus;

var OnMenuMouseMsg:procedure (Msg:cardinal;Item:TMenuItem;out Hide:boolean)=nil;

implementation
uses messages,windows,SysUtils;

type TMyPopupList=class(TPopupList)
                  private
                   FLastMenuItem:TMenuItem;
                   procedure Hook;
                   procedure Unhook;
                   function AllowHideMenu(msg:DWORD;Item:TMenuItem):boolean;
                  public
                   constructor Create(CreateFrom:TPopupList);
                   destructor Destroy;override;
                   procedure Assign(List:TPopupList);reintroduce;
                  protected
                   procedure WndProc(var Message:TMessage);override;
                  end;

var HHook:windows.HHOOK=0;

function TMyPopupList.AllowHideMenu(msg:DWORD;Item:TMenuItem):boolean;
begin
if (item=nil) or (@OnMenuMouseMsg=nil)
   then result:=true
   else OnMenuMouseMsg(msg,item,result);
end;

function FilterMenuMouseMsg(const msg:TMsg):integer;
begin
 if (msg.message>=WM_LBUTTONDOWN) and
    (msg.message<=WM_MBUTTONDBLCLK)
   then result:=SendMessage(PopupList.Window,msg.message,msg.wParam,msg.lParam)
   else result:=0;
end;

function HookProc(code:integer;wParam:WPARAM;var msg:TMSG):LRESULT;stdcall;
begin
result:=integer(code=MSGF_MENU);
if boolean(result) then result:=FilterMenuMouseMsg(msg);
if not boolean(result) then result:=CallNextHookEx(HHook,code,wParam,integer(@msg));
end;

procedure TMyPopupList.WndProc(var Message: TMessage);
var FindKind:TFindItemKind;i,Item:integer;info:TMenuInfo;
begin
case message.Msg of
 WM_EXITMENULOOP:FLastMenuItem:=nil;
 WM_LBUTTONDOWN..WM_MBUTTONDBLCLK:begin
                                  message.Result:=integer(not AllowHideMenu(message.msg,FLastMenuItem));
                                  if boolean(message.Result) then exit;
                                  end;
 WM_MENUSELECT:with TWMMenuSelect(Message) do//подглядел в menus.pas
                begin
                FindKind:=fkCommand;
                if MenuFlag and MF_POPUP<>0
                   then FindKind:=fkHandle;
                for i:=0 to Count-1 do
                    begin
                    if FindKind=fkHandle
                       then if Menu=0
                               then Item:=-1
                               else Item:=GetSubMenu(Menu,IDItem)
                       else Item:=IDItem;
                    FLastMenuItem:=TPopupMenu(Items[i]).FindItem(Item, FindKind);
                    end;
                end;
end;
inherited
end;

procedure TMyPopupList.Assign(List:TPopupList);
begin
inherited Assign(List);
FWindow:=List.Window;
end;

constructor TMyPopupList.Create(CreateFrom:TPopupList);
begin
inherited Create;
if assigned(CreateFrom)
   then begin
        Assign(CreateFrom);
        CreateFrom.Free
        end;
Hook;
end;

destructor TMyPopupList.Destroy;
begin
inherited;
Unhook
end;

procedure TMyPopupList.Hook;
begin
HHook:=SetWindowsHookEx(WH_MSGFILTER,@HookProc,0,GetCurrentThreadID);
end;

procedure TMyPopupList.Unhook;
begin
if HHook<>0 then begin
                 UnhookWindowsHookEx(HHook);
                 HHook:=0
                 end;
end;

initialization
PopupList:=TMyPopupList.Create(PopupList);

finalization

end.

в модуле формы:

Код


procedure MenuMsgHandler(Msg:cardinal;Item:TMenuItem;out Hide:boolean);
begin
hide:=(length(Item.Caption) mod 2) = 1 //тут твое решение
//а пока прячем при нажатии на пункты с нечетным числом букв :)
//или наоборот (в Item.Caption есть еще "&")
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OnMenuMouseMsg:=MenuMsgHandler; //устанавливаешь свой обработчик
end;

пример неправильно работает когда щелкаешь мимо меню. Но есть с чего начать

Добавлено через 2 минуты и 28 секунд
тестил только с TPopupMenu

--------------------

Обижено школьников: 8

Igor_thief

Дата 15.6.2007, 23:11 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 112
Регистрация: 12.9.2006
Где: Украина

Репутация: нет
Всего: нет

bems, большое спасибо за пример. Только что вернулся с тренировки и очень устал, поэтому код еще особо не разбирал. Сейчас лягу посплю, а завтра утричком, первым же делом изучу код и напишу комментарии.

ПС: я очень рад что есть начало! это дает надежду! спасибо!

--------------------

В каждом из нас спит гений, и с каждым днем все крепче ...delphigeek.blogspot.com | www.iskomorokh.com

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »