Вверх ↑
Этот топик читают: Гость, nesco
Разработчик
Ответов: 26086
Рейтинг: 2124
#16: 2024-07-10 04:21:37 ЛС | профиль | цитата
Вот, переделан модуль XPMenus.pas для EX-версий Меню. Можете проверять. Если все нормально, то буду добавлять на SVN

Редактировалось 1 раз(а), последний 2024-07-10 04:22:57
карма: 22

0
файлы: 1XPMenus.zip [9.5KB] [37]
Разработчик
Ответов: 26086
Рейтинг: 2124
#17: 2024-07-12 17:25:27 ЛС | профиль | цитата
Всем Привет!
Че молчим? Тестировали или как? Добавлять будем?
карма: 22

0
Ответов: 8897
Рейтинг: 823
#18: 2024-07-12 19:01:52 ЛС | профиль | цитата
nesco, привет!
Я этими (и не только) фичами никогда не пользовался, но осуж..., ой, но считаю, что добавить надо
карма: 19

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#19: 2024-07-12 19:32:24 ЛС | профиль | цитата
Леонид писал(а):
nesco, привет!
Я этими (и не только) фичами никогда не пользовался, но осуж..., ой, но считаю, что добавить надо

Тут вопрос не в нужности добавления. Тут вопрос в тестировании исправлений, что бы их потом по нескольку раз не править.
карма: 22

0
Ответов: 4627
Рейтинг: 747
#20: 2024-07-13 07:37:51 ЛС | профиль | цитата
nesco писал(а):
MenuEx не требует запуска всплывающего окна, которое и перехватывает сообщения

Ну, и обычный не должен был требовать.
Уточнить как реализовано в MenuEx.
TrackPopupMenu() требуется окно. Такое окно у нас есть - это Applet или форма, на которой лежит меню. С помощью имеющихся функций KOL добавить свою оконную процедуру для обработки сообщений в Applet.

Отдельное окно, предполагаю, может требоваться в невизуальных приложениях, когда меню отображается в произвольном месте экрана. Тогда в Init() можно определить наличие Applet и использовать либо старый, либо новый метод.
Ага, ещё надо учесть работу, когда все окна программы невидимы, а меню надо отобразить на иконке в трее. Вот для этого могло быть нужно отдельное окно.

В оригинальном компоненте можно попробовать вызывать TrackPopupMenu с флагами TPM_NONOTIFY+TPM_RETURNCMD. Тогда функция будет сама возвращать выбранный пункт без необходимости оконной процедуры.

Редактировалось 2 раз(а), последний 2024-07-13 07:47:22
карма: 26

0
Ответов: 2214
Рейтинг: 676
#21: 2024-07-14 10:08:03 ЛС | профиль | цитата
nesco,
nesco писал(а):
Че молчим? Тестировали или как? Добавлять будем?
Что-то желающих помочь просто обычным тестированием маловато.
nesco, что-то пошло не так:

Add(MainForm,12346102,259,189)
{
Width=815
Height=655
Caption="test 1"
WindowsState=2
Point(Close)
}
Add(MTStrTbl,5800875,329,189)
{
Left=60
Top=120
Width=365
Height=240
Font=[MS Sans Serif,12,0,0,1]
Name="Table1"
Layout="ver_Table"
HeightScale=100
Columns=#7:1=54==2|7:2=50==2|5:3=400|5:4=100|5:5=120|5:6=120|7:7=90==2|3:8=0|
Grid=0
MultiSelect=0
Point(onMouseDown)
Point(doVisible)
link(onMouseDown,7054046:doPopupHere,[])
}
Add(PopupMenuEx,7054046,385,217)
{
Menu=#1:1|1:2|1:3|
Font=[MS Sans Serif,12,0,0,1]
Bitmaps=[]
Point(Array)
link(MenuItemIdx,1631073:doText,[])
}
Add(ChildFormEx,2300527,434,322)
{
}
BEGIN_SDK
Add(EditMultiEx,6167279,21,21)
{
WorkCount=#6:doShow|
Width=503
Height=557
link(doShow,3451375:doShowModal,[(119,27)(119,90)])
}
Add(MainForm,3451375,217,56)
{
Left=35
Top=105
Width=981
Height=727
Visible=1
Caption="test 2"
Position=1
Point(doShowModal)
}
Add(Button,14999685,266,504)
{
Left=250
Top=540
Width=110
Height=35
Font=[MS Sans Serif,12,0,0,1]
TabOrder=9
Layout="gor_buttons"
Caption="Отмена"
link(onClick,6311228:In,[(298,510)])
}
Add(HBoxLayout,16029822,308,427)
{
Name="gor_buttons"
Space=30
Padding=10
Layout="ver"
}
Add(LayoutSpacer,11853030,350,427)
{
Left=530
Top=540
Layout="gor_buttons"
WidthScale=50
}
Add(LayoutSpacer,8885556,266,427)
{
Left=130
Top=540
Layout="gor_buttons"
WidthScale=50
}
Add(VBoxLayout,13052431,308,378)
{
Name="ver"
}
Add(MTStrTbl,4197214,217,182)
{
Left=190
Top=65
Width=455
Height=140
Font=[MS Sans Serif,12,0,0,1]
Name="Table2"
Layout="ver"
Columns=#7:1=54==2|7:2=50==2|5:3=400|5:4=100|5:5=120|5:6=120|7:7=90==2|3:8=0|
Grid=0
Point(onMouseDown)
}
Add(LineBreak,12971073,168,77)
{
Caption="close"
link(Out,3451375:doClose,[])
Primary=[6311228,196,427]
}
END_SDK
Add(PopupMenuEx,13923346,385,322)
{
Menu=#1:1|1:2|1:3|
Font=[MS Sans Serif,12,0,0,1]
Bitmaps=[]
Point(Array)
link(MenuItemIdx,2300527:doShow,[])
}
Add(Edit,1631073,441,217)
{
Left=300
Top=65
Width=150
}
Если кликнуть на таблицу и выбрать пункт меню, то откроется дочерняя форма, а не должна.
карма: 11

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#22: 2024-07-14 15:55:23 ЛС | профиль | цитата
Всем Привет!
sla8a писал(а):
Если кликнуть на таблицу и выбрать пункт меню, то откроется дочерняя форма, а не должна.

Ага, интересно. А это точно связано с доработкой, или так и раньше работало?
карма: 22

0
Ответов: 2214
Рейтинг: 676
#23: 2024-07-14 16:23:03 ЛС | профиль | цитата
nesco, до замены XPMenus.pas у меня такого не было. Жаль что остальные молчат, может и я чего перепутал при тестировании. Сейчас нет под рукой компьютера чтоб перепроверить.
nesco, а попробуйте поменять в моем примере z-координата у меню (у каждой по разу), предположу что результат будет разный.
карма: 11

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#24: 2024-07-14 16:34:38 ЛС | профиль | цитата
sla8a, вообще вся проблем кроется в том, что крайне нежелательно использовать MouseDown для вызова Меню. Посмотри в системе, Меню всегда вызывается по отпусканию мыша, те по MouseUp

--- Добавлено в 2024-07-14 16:38:39

sla8a писал(а):
а попробуйте поменять в моем примере z-координата у меню (у каждой по разу), предположу что результат будет разный

Попробовал, чешуя продолжает твориться. То на первом срабатывает, то на втором, то на третьем.
И это, кстати, творится и с обычным Меню.
Пока оставляем все как есть.

Редактировалось 1 раз(а), последний 2024-07-14 16:38:39
карма: 22

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#25: 2024-07-14 18:00:51 ЛС | профиль | цитата
Вот новый код обычного PopUpMenu без оконного обработчика по рекомендациям Netspirit-а. Вроде как у меня Модал отрабатывается нормально.

unit hiPopupMenu;

interface

uses Windows,Kol,Share,Messages,Debug;
(*
const
US_APP = WM_APP + 1000;
US_DEFERREDEVENT = US_APP + 51;
*)
type
THIPopupMenu = class(TDebug)
private
PM:PMenu;
FC:PControl;
Old:TOnMessage;
FMenuList: string;
ListMenuStr: array of string;
_Arr: PArray;

procedure SetMenu(const Value:string);
procedure AddMenuItem(const Caption:string);
// function _OnDraw( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
// DrawAction: TDrawAction; ItemState: TDrawState ): Boolean;
// function _OnMes( var Msg: TMsg; var Rslt: Integer ): Boolean;
procedure RefBMP;
procedure RefBMPall;

procedure Init;
public
_prop_TranspIcon:boolean;
_event_onClick:THI_Event;
_event_onSelectStr:THI_Event;
_event_onEndPopup:THI_Event;
_data_Bitmaps:THI_Event;

property _prop_Menu: string write SetMenu;

constructor Create(Control:PControl);
destructor Destroy; override;
procedure _work_doPopup(var _Data:TData; Index:word);
procedure _work_doPopupHere(var _Data:TData; Index:word);
procedure _work_doAddItem(var _Data:TData; Index:word);
procedure _work_doClear(var _Data:TData; Index:word);
procedure _var_Handle(var _Data:TData; Index:word);

procedure _Add(var Val:TData);
procedure _Set(var Item: TData; var Val: TData);
function _Get(Var Item: TData; var Val: TData): boolean;
function _Count:integer;

procedure _var_Array(var _Data:TData; Index:word);

end;

implementation

constructor THIPopupMenu.Create;
begin
inherited Create;
FC := Control;
old := FC.OnMessage;
// PM := NewMenu(nil,0,[],nil);
end;

{$ifdef F_P}
var ListMenu: array[0..200] of PChar;
{$endif}

procedure THIPopupMenu.Init;
type TPCharArray = array[0..0] of PChar;
// PPCharArray = ^TPCharArray;
var i:integer;
List:PStrList;
{$ifndef F_P}
ListMenu: array of PChar;
{$endif}
//k:PPCharArray;
begin
List := NewStrList;
List.text := FMenuList;
if List.Count > 0 then
begin
SetLength(ListMenuStr,List.Count);
{$ifndef F_P}
SetLength(ListMenu,List.Count);
{$endif}
//getmem(k,4*10);
for i := 0 to List.Count-1 do
begin
ListMenuStr[i] := List.Items[i];
ListMenu[i] := PChar(@ListMenuStr[i][1]);
//k[i] := PChar(ListMenuStr[i]);
end;
end;
if Assigned(PM) then PM.free;
PM := NewMenu( nil, 0, ListMenu, nil );
List.free;
end;


(*
procedure THIPopupMenu.Init;
var List:PStrList;
i:integer;
begin
List := NewStrList;
List.text := _prop_Menu;
for i := 0 to List.Count-1 do
AddmenuItem(List.Items[i]);
List.Free;
end;
*)

destructor THIPopupMenu.Destroy;
begin
FC.OnMessage := old;
PM.Free;
inherited;
end;

(*
function THIPopupMenu._OnMes;
var m:PMenu;
begin
case Msg.message of
WM_COMMAND: begin
m := PM.Items[Msg.WParam];
if m <> nil then begin
_hi_OnEvent(_event_onSelectStr,PM.Items[PM.IndexOf(m)].Caption);
_hi_OnEvent(_event_onClick,PM.IndexOf(m));
end;
end;
US_DEFERREDEVENT: begin
TrackPopupMenu(PM.Handle,0,Msg.WParam,Msg.LParam,0,FC.Handle,nil);
_hi_OnEvent(_event_onEndPopup);
end;
end;
Result := Old(Msg,Rslt);
end;
*)

procedure THIPopupMenu.AddMenuItem;
begin
if Caption = '-' then
PM.AddItem('-',nil,[moSeparator])
else
PM.AddItem(PChar(Caption),nil,[]);
Refbmp;
end;

procedure THIPopupMenu.RefBMP;
var dt,Ind:TData;
bmp:PBitmap;
arr:PArray;
i,j:integer;
c:TColor;
begin
Arr := ReadArray(_data_Bitmaps);
if Arr = nil then exit;
Ind := _DoData(PM.Count-1);
Arr._Get(Ind,dt);
bmp := PBitmap(dt.idata);
if (_IsBitmap(dt)) and (bmp <> nil) and not bmp.Empty then begin
// BmpTransparent(bmp);
if _prop_TranspIcon then begin
c := Bmp.Pixels[0,0];
for i := 0 to Bmp.Width-1 do
for j := 0 to Bmp.Height-1 do
if Bmp.Pixels[i,j] = c then
// Bmp.Pixels[i,j] := clMenu;
Bmp.Pixels[i,j] := clNone;
end;
PM.Items[PM.Count-1].BitmapItem := CopyImage(bmp.Handle,IMAGE_BITMAP,0,0,LR_CREATEDIBSECTION);
end;
end;

procedure THIPopupMenu.RefBMPall;
var dt,Ind:TData;
bmp:PBitmap;
arr:PArray;
i,j,k:integer;
c:TColor;
begin
Arr := ReadArray(_data_Bitmaps);
if Arr = nil then exit;

for k := 0 to min(Arr._Count - 1, PM.Count - 1) do
begin
Ind := _DoData(k);
Arr._Get(Ind,dt);
bmp := PBitmap(dt.idata);
if (_IsBitmap(dt)) and (bmp <> nil) and not bmp.Empty then
begin
if _prop_TranspIcon then
begin
c := Bmp.Pixels[0,0];
for i := 0 to Bmp.Width-1 do
for j := 0 to Bmp.Height-1 do
if Bmp.Pixels[i,j] = c then
// Bmp.Pixels[i,j] := clMenu;
Bmp.Pixels[i,j] := clNone;
end;
PM.Items[k].BitmapItem := CopyImage(bmp.Handle,IMAGE_BITMAP,0,0,LR_CREATEDIBSECTION);
end;
end;
end;

procedure THIPopupMenu.SetMenu;
begin
FMenuList := Value;
Init;
// FC.OnMessage := _OnMes;
end;

(*
function THIPopupMenu._OnDraw;
var bmp:PBitmap;
begin // debug('ok');
bmp := NewBitmap(0,0);
bmp.Handle := Pm.ItemBitmap[ItemIdx];
bmp.Draw(dc,1,Rect.Top);
//with PM.Items[PM.Count-1]^ do
// TextOut(dc,Rect.Left + 18,Rect.Top,PChar(Caption),Length(Caption));
bmp.Handle := 0;
bmp.Free;
Result := true;
end;
*)

procedure THIPopupMenu._work_doPopup;
var
pos:cardinal;
m:PMenu;
Idx:LongBool;
begin
pos := Cardinal(ToInteger(_data));
RefBMPall;
Idx := TrackPopupMenu(PM.Handle,TPM_NONOTIFY+TPM_RETURNCMD,pos and $ffff,pos shr 16,0,FC.Handle,nil);
_hi_OnEvent(_event_onEndPopup);
if Idx then
begin
m := PM.Items[integer(Idx)];
if m <> nil then
begin
_hi_OnEvent(_event_onSelectStr,PM.Items[PM.IndexOf(m)].Caption);
_hi_OnEvent(_event_onClick,PM.IndexOf(m));
end;
end;
end;

procedure THIPopupMenu._work_doAddItem;
begin
AddMenuItem(ToString(_Data));
end;

procedure THIPopupMenu._work_doClear;
begin
if Assigned(PM) then PM.Free;
PM := NewMenu(nil,200,[],nil);
end;

procedure THIPopupMenu._work_doPopupHere;
var
pos:TPoint;
m:PMenu;
Idx:LongBool;
begin
GetCursorPos(pos);
SetForegroundWindow( FC.Handle );
RefBMPall;
with pos do
Idx := TrackPopupMenu(PM.Handle,TPM_NONOTIFY+TPM_RETURNCMD,x,y,0,FC.Handle,nil);
_hi_OnEvent(_event_onEndPopup);
if Idx then
begin
m := PM.Items[integer(Idx)];
if m <> nil then
begin
_hi_OnEvent(_event_onSelectStr,PM.Items[PM.IndexOf(m)].Caption);
_hi_OnEvent(_event_onClick,PM.IndexOf(m));
end;
end;
end;

procedure THIPopupMenu._var_Handle;
begin
dtInteger(_Data,PM.ItemHandle[0]);
end;

procedure THIPopupMenu._Set;
var
ind:integer;
begin
ind := ToInteger(Item);
if (ind < 0) and (ind > PM.Count - 1) then exit;
PM.ItemText[ind] := ToString(Val);
end;

function THIPopupMenu._Get;
var
ind: integer;
begin
ind := ToInteger(Item);
if (ind >= 0 ) and (ind < PM.Count) then
begin
dtString(Val, PM.ItemText[ind]);
Result := true;
end
else
Result := false;
end;

function THIPopupMenu._Count:integer;
begin
Result := PM.Count;
end;

procedure THIPopupMenu._Add;
var
sdt: string;
begin
sdt := ToString(Val);

if sdt = '-' then
PM.AddItem('-',nil,[moSeparator])
else
PM.AddItem(PChar(sdt),nil,[]);
Refbmp;
end;

procedure THIPopupMenu._var_Array;
begin
if _Arr = nil then
_Arr := CreateArray(_Set,_Get,_Count,_Add);
dtArray(_Data, _Arr);
end;

end.
Проверьте еще на индексацию. Вроде тоже как отрабатывает.
Исправил по последним рекомендациям Netspirit-а

Редактировалось 4 раз(а), последний 2024-07-14 19:42:38
карма: 22

0
Ответов: 4627
Рейтинг: 747
#26: 2024-07-14 18:49:42 ЛС | профиль | цитата
Надо проверить работу меню по иконке в трее, когда все окна программы невидимы.

Кроме того, функция TrackPopupMenu возвращает 0, когда меню закрывается без выбора пункта - а это может выдаваться как событие выбора первого пункта списка.
Нужно сохранять значение в переменную и обрабатывать результат.

Событие onEndPopup может утратить свой функционал, так как сработает только после выбора пункта.
карма: 26

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#27: 2024-07-14 19:10:59 ЛС | профиль | цитата
Netspirit писал(а):
Кроме того, функция TrackPopupMenu возвращает 0, когда меню закрывается без выбора пункта - а это может выдаваться как событие выбора первого пункта списка

Да действительно, индекс отличается от 0, но PM.Items[Idx] выдает 0 даже на несуществующий пункт Меню, хотя не должен.
А onEndPopup вроде же так и должен работать по закрытию списка до выдачи сообщений по пункту. Он сейчас так и работает.

--- Добавлено в 2024-07-14 19:13:16

Насчет иконки надо будет проверить, это не сложно. Начало положено, дальше будем допиливать напильником.

--- Добавлено в 2024-07-14 19:44:19

Исправил код. Добавил проверку на валидность выбора и проверил на иконке в трее. На иконке тоже работает

Редактировалось 2 раз(а), последний 2024-07-14 19:44:19
карма: 22

0
Ответов: 2214
Рейтинг: 676
#28: 2024-07-15 10:31:56 ЛС | профиль | цитата
nesco писал(а):
Исправил код.
Последняя версия кода для тестирования это в предпредпоследнем посте который?
карма: 11

0
Разработчик
Ответов: 26086
Рейтинг: 2124
#29: 2024-07-16 15:56:05 ЛС | профиль | цитата
Всем Привет!
sla8a писал(а):
Последняя версия кода для тестирования это в предпредпоследнем посте который?

Да. Уточнение там еще красным помечено.

--- Добавлено в 2024-07-16 15:58:32

С Ex версией сложней оказалось. Но пока потестите обычную.

Редактировалось 1 раз(а), последний 2024-07-16 15:58:32
карма: 22

0
Ответов: 2214
Рейтинг: 676
#30: 2024-07-17 09:48:06 ЛС | профиль | цитата
nesco, на данный момент тестирование ошибок не выявило.
карма: 11

0
30
Сообщение
...
Прикрепленные файлы
(файлы не залиты)