Форум: "Прочее";
Текущий архив: 2017.10.01;
Скачать: [xml.tar.bz2];
ВнизГлубины VCL Найти похожие ветки
← →
Pavia © (2016-06-11 09:36) [0]Как подменить событие OnClick разом у всех стандартных компонентов? Само-собой подразумевается, что компоненты переписывать нельзя, а вот править VCL можно.
← →
K-1000 © (2016-06-11 09:40) [1]В цикле присвоить другое событие.
Можно и через инспектор.
← →
K-1000 © (2016-06-11 09:41) [2]
> Само-собой подразумевается, что компоненты переписывать
> нельзя, а вот править VCL можно.
Как это?
Если компоненты это и есть VCL? :)
← →
Игорь Шевченко © (2016-06-11 10:03) [3]Не трожь генофонд, зараза!
← →
Юрий Зотов © (2016-06-11 10:11) [4]Application.OnMessage.
А переписывать глубины - не стоит.
← →
Leonid Troyanovsky © (2016-06-11 10:39) [5]
> Pavia © (11.06.16 09:36)
> а вот править VCL можно.
[3] +100500
See also: http://rsdn.ru/forum/delphi/480838.1
--
Regards, LVT.
← →
Юрий Зотов © (2016-06-12 08:52) [6]> Application.OnMessage.
Еще лучше - хук на мышь (с учетом того, что форма может быть модальной).
В любом варианте, главное - глубины не трогать. Там и без нас баги найдутся.
← →
Leonid Troyanovsky © (2016-06-12 08:58) [7]
> Юрий Зотов © (12.06.16 08:52) [6]
> Еще лучше - хук на мышь
Клик может быть и клавой.
Тогда уж WH_GETMESSAGE or WH_CALLWNDPROC*
--
Regards, LVT.
← →
Leonid Troyanovsky © (2016-06-12 10:50) [8]
> Leonid Troyanovsky © (11.06.16 10:39) [5]
Вот процедура, заполняющая список контролов с назначенным OnClick,
лежащих на паренте.
uses
typinfo;
procedure EnumControls(AControl: TControl; List: TStrings);
var
i: Longint;
pi: PPropInfo;
onc: TNotifyEvent;
begin
pi := GetPropInfo(AControl, "OnClick");
if Assigned(pi) then
begin
onc := TNotifyEvent(GetMethodProp(AControl, pi));
if Assigned(onc) then
List.Add(AControl.Name);
end;
if AControl is TWincontrol then
for i := 0 to TWinControl(AControl).ControlCount -1 do
EnumControls(TWinControl(AControl).Controls[i], List);
end;
Например, на форме:
procedure TForm1.Button1Click(Sender: TObject);
begin
EnumControls(Self, ListBox1.Items);
end;
--
Regards, LVT.
← →
Leonid Troyanovsky © (2016-06-13 09:59) [9]
> Leonid Troyanovsky © (12.06.16 10:50) [8]
И вот процедура внедрения в OnClick.
uses
typinfo;
type
PMethod = ^TMethod;
procedure CommonClick (old: PMethod; Sender: TObject);
begin
OutputDebugString("Come on!");
TNotifyEvent(old^)(Sender);
end;
procedure SetControlsCommonClick(AControl: TControl);
var
i: Longint;
pi: PPropInfo;
onc: TMethod;
old: PMethod;
begin
pi := GetPropInfo(AControl, "OnClick");
if Assigned(pi) then
begin
onc := GetMethodProp(AControl, pi);
if (onc.Data <> nil) or (onc.Code <> nil) then
begin
New(old);
old^ := onc;
onc.Data := old;
onc.Code := @CommonClick;
SetMethodProp(AControl, pi, onc);
end;
end;
if AControl is TWincontrol then
for i := 0 to TWinControl(AControl).ControlCount -1 do
SetControlsCommonClick(TWinControl(AControl).Controls[i]);
end;
--
Regards, LVT.
← →
Rouse_ © (2016-06-14 11:15) [10]Проще тогда динамический Click у TControl перехватить на себя
← →
Leonid Troyanovsky © (2016-06-15 10:31) [11]
> Rouse_ © (14.06.16 11:15) [10]
> Проще тогда динамический Click у TControl перехватить на
Попробовал.
Взял описание DMT
http://www.transl-gunsmoker.ru/2011/07/hack-9-dynamic-method-table-structure.html
Нахожу индекс Click на своем наследнике
type
TMyControl = class(TControl)
public
procedure Click; override;
end;
procedure TMyControl.Click;
begin
inherited;
end;
путем
function FindDynamicMethod(AClass: TClass; DMTIndex: TDMTIndex): Pointer;
// Pascal-вариант более быстрой BASM-версии подпрограммы System.GetDynaMethod
var
Dmt: PDmt;
DmtMethods: PDmtMethods;
i: integer;
begin
while Assigned(AClass) do
begin
Dmt := GetDmt(AClass);
if Assigned(Dmt) then
for i := 0 to Dmt.Count-1 do
if DMTIndex = Dmt.Indicies[i] then
begin
DmtMethods := @Dmt.Indicies[Dmt.Count];
Result := DmtMethods[i];
Exit;
end;
// Не в этом классе - поднимаемся по иерархии
AClass := AClass.ClassParent;
end;
Result := nil;
end;
На моей D6 получается -21.
Пробую на кошках:
var
oldproc: TClickproc;
procedure NewClick(ASelf: TObject; Sender: TObject);
begin
OutputDebugString("ooch");
oldproc(ASelf, Sender);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
oldproc := FindDynamicMethod(TControl, -21);
newclick(Self, Button3);
end;
Наконец, делаю из FindDynamicMethod процедуру модификации:
procedure ReplaceDynamicMethod(AClass: TClass; DMTIndex: TDMTIndex; newmethod: Pointer);
var
Dmt: PDmt;
DmtMethods: PDmtMethods;
i: integer;
protect: Dword;
begin
while Assigned(AClass) do
begin
Dmt := GetDmt(AClass);
if Assigned(Dmt) then
for i := 0 to Dmt.Count-1 do
if DMTIndex = Dmt.Indicies[i] then
begin
DmtMethods := @Dmt.Indicies[Dmt.Count];
Win32Check(VirtualProtect(@DmtMethods[i], 4, PAGE_READWRITE, protect));
DmtMethods[i]:= newmethod;
VirtualProtect(@DmtMethods[i], 4, protect, protect);
Exit;
end;
// Не в этом классе - поднимаемся по иерархии
AClass := AClass.ClassParent;
end;
end;
Наконец, делаю ReplaceDynamicMethod(TControl, -21, @newClick).
Но, в результате получаю, что на кнопках (TButton, TRadioButton, TCheckBox) оно не срабатывает.
Видимо, не все так просто. По крайней мере для меня :)
Не знаю, что у меня не так, но уже ясно, что сделать подобное,
скажем, из длл вряд ли получится.
--
Regards, LVT.
← →
Leonid Troyanovsky © (2016-06-15 10:42) [12]
> Leonid Troyanovsky © (15.06.16 10:31) [11]
> путем function FindDynamicMethod(AClass: TClass; DMTIndex:
Путем procedure DumpDynamicMethods, sorry.
--
Regards, LVT.
← →
Rouse_ © (2016-06-15 12:43) [13]
> Leonid Troyanovsky © (15.06.16 10:42) [12]
Да к чему такие сложности - грязный хак и все дела :)type
TForm7 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
end;
var
Form7: TForm7;
implementation
uses
SpliceHelper;
{$R *.dfm}
procedure ClickHandler(Self, Sender: TObject);
begin
ShowMessage((Self as TComponent).Name + " clicked");
end;
procedure TForm7.FormCreate(Sender: TObject);
function GetControlClickAddr: Pointer;
asm
{$IFDEF WIN32}
lea eax, TControl.Click
{$ELSE}
lea rax, TControl.Click
{$ENDIF}
end;
var
HotPathSpliceRec: THotPachSpliceData;
OldProtect: DWORD;
TrampolineSplice: TNearJmpSpliceRec;
TrampolineAddr, ClickHandlerAddr: Pointer;
begin
ClickHandlerAddr := @ClickHandler;
HotPathSpliceRec.FuncAddr := GetControlClickAddr;
Move(HotPathSpliceRec.FuncAddr^, HotPathSpliceRec.LockJmp, LockJmpOpcodeSize);
HotPathSpliceRec.SpliceRec.JmpOpcode := JMP_OPKODE;
HotPathSpliceRec.SpliceRec.Offset :=
PAnsiChar(ClickHandlerAddr) - PAnsiChar(HotPathSpliceRec.FuncAddr);
SpliceNearJmp(PAnsiChar(HotPathSpliceRec.FuncAddr) - NearJmpSpliceRecSize,
HotPathSpliceRec.SpliceRec);
SpliceLockJmp(HotPathSpliceRec.FuncAddr, LOCK_JMP_OPKODE);
end;
SpliceHelper.pas лежит тут:
http://rouse.drkb.ru/blog/intercept2.zip
← →
Rouse_ © (2016-06-15 13:18) [14]Даже вот так, чтоб все по феншую было :)
type
TForm7 = class(TForm)
Button1: TButton;
Button2: TButton;
ActionList1: TActionList;
Action1: TAction;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Action1Execute(Sender: TObject);
end;
var
Form7: TForm7;
implementation
uses
SpliceHelper;
{$R *.dfm}
type
TControlFriendly = class(TControl);
procedure ClickHandler(Self: TObject);
var
AControl: TControlFriendly;
begin
AControl := TControlFriendly(Self);
ShowMessage(AControl.Name + " clicked");
if Assigned(AControl.OnClick) and (AControl.Action <> nil) and not
DelegatesEqual(@AControl.OnClick, @AControl.Action.OnExecute) then
AControl.OnClick(Self)
else if not (csDesigning in AControl.ComponentState) and (AControl.ActionLink <> nil) then
AControl.ActionLink.Execute(TComponent(Self))
else if Assigned(AControl.OnClick) then
AControl.OnClick(Self);
end;
procedure TForm7.Action1Execute(Sender: TObject);
begin
ShowMessage((Sender as TComponent).Name + " clicked 2");
end;
procedure TForm7.Button1Click(Sender: TObject);
begin
ShowMessage((Sender as TComponent).Name + " clicked 2");
end;
procedure TForm7.FormCreate(Sender: TObject);
function GetControlClickAddr: Pointer;
asm
{$IFDEF WIN32}
lea eax, TControl.Click
{$ELSE}
lea rax, TControl.Click
{$ENDIF}
end;
var
ClickHandlerAddr: Pointer;
HotPathSpliceRec: THotPachSpliceData;
begin
ClickHandlerAddr := @ClickHandler;
HotPathSpliceRec.FuncAddr := GetControlClickAddr;
Move(HotPathSpliceRec.FuncAddr^, HotPathSpliceRec.LockJmp, LockJmpOpcodeSize);
HotPathSpliceRec.SpliceRec.JmpOpcode := JMP_OPKODE;
HotPathSpliceRec.SpliceRec.Offset :=
PAnsiChar(ClickHandlerAddr) - PAnsiChar(HotPathSpliceRec.FuncAddr);
SpliceNearJmp(PAnsiChar(HotPathSpliceRec.FuncAddr) - NearJmpSpliceRecSize,
HotPathSpliceRec.SpliceRec);
SpliceLockJmp(HotPathSpliceRec.FuncAddr, LOCK_JMP_OPKODE);
end;
← →
Юрий Зотов © (2016-06-15 13:56) [15]
type
TMyLabel = class(TLabel)
protected
procedure Click; override;
end;
procedure TMyLabel.Click;
begin
ShowMessage("WOW!");
end;
Розыч, какое сообщение (твое или мое) я увижу при клике по этой метке?
← →
Rouse_ © (2016-06-15 14:00) [16]Мдя... твое :)
← →
Юрий Зотов © (2016-06-15 14:11) [17]> Rouse_ © (15.06.16 14:00) [16]
В том и фокус, что вызывается не тот клик, который ты хакнул. Значит, надо пройтись по всем использованным в проекте контролам и применить твой хак к каждому.
Сделать, наверное, можно, но геморроя будет побольше.
← →
Rouse_ © (2016-06-15 14:25) [18]Угу, перебор придется делать для таких случаев + контролировать создание новых нестандартных контролов (с перекрытым Click)
← →
Юрий Зотов © (2016-06-15 14:29) [19]> Rouse_ © (15.06.16 14:25) [18]
> контролировать создание контролов с перекрытым Click
Не обязательно. Если клик не перекрыт, то в предке он просто хакнется еще раз. Не страшно.
← →
Юрий Зотов © (2016-06-15 14:33) [20]Кстати, тоже интересная задачка - в run-time получить список всех использованных в проекте классов. Желательно, в виде дерева наследования.
← →
DayGaykin © (2016-06-15 15:40) [21]У меня такая задачка:
Как создать экземпляр класса в стеке?
(по аналогии с C++).
← →
Eraser © (2016-06-15 16:06) [22]
> Юрий Зотов © (15.06.16 14:33) [20]var
LContext: TRttiContext;
LType: TRttiType;
begin
{ Obtain the RTTI context }
LContext := TRttiContext.Create;
{ Enumerate all types declared in the application }
for LType in LContext.GetTypes() do
OutputDebugString(PChar(LType.Name));
LContext.Free;
из справки )
← →
NoUser © (2016-06-15 18:56) [23]> DayGaykin © (15.06.16 15:40) [21]
procedure Test2;
//const
// cl = TTest.InstanceSize;
var
// a : array [1..cl] of Byte;
t : TTest;
begin
// t := @a;
t := StackAlloc(TTest.InstanceSize);
TTest.InitInstance(t);
end;
Не? , а StackAlloc можно взять тут http://sourceforge.net/projects/graphics32/files/graphics32/ ))
← →
DayGaykin © (2016-06-15 20:27) [24]
> StackAlloc можно взять тут http://sourceforge.net/projects/graphics32/files/graphics32/
> ))
>
>
А точнее.
Мне пока не ясно кто будет освобождать стек при выходе из функции.
← →
NoUser © (2016-06-15 21:13) [25]GR32_LowLevel.pas -> StackFree(t);
зы, там в 64bit asm вроде поправимая, но ошибка.
← →
Leonid Troyanovsky © (2016-06-16 12:05) [26]
> Leonid Troyanovsky © (15.06.16 10:31) [11]
> Но, в результате получаю, что на кнопках (TButton, TRadioButton,
> TCheckBox) оно не срабатывает.
На TRadioButton оно работает, а для TButton новую процедуру
надо делать (по аналогии с TButton.Click) примерно так:
type
TClickproc = procedure(ASelf: TObject);
var
oldproc: TClickproc;
procedure TControlClick(ASelf: TObject);
var
s: String;
begin
oldproc(ASelf);
s := "control "+TComponent(ASelf).Name;
OutputDebugString(PChar(s));
end;
procedure TButtonClick(ASelf: TObject);
var
Form: TCustomForm;
begin
Form := GetParentForm(TControl(ASelf));
if Form <> nil then Form.ModalResult := TButton(ASelf).ModalResult;
TControlClick(ASelf);
end;
затем
oldproc := FindDynamicMethod(TControl, -21);
ReplaceDynamicMethod(TControl, -21, @TControlClick);
ReplaceDynamicMethod(TButton, -21, @TButtonClick);
Для TCheckBox делать мне уже влом.
Для желающих поупражняться могу выложить юнит целиком.
--
Regards, LVT.
← →
Leonid Troyanovsky © (2016-06-16 12:38) [27]
> Rouse_ © (15.06.16 12:43) [13]
С вертолета, танка - все это неспортивно ;)
--
Regards, LVT.
← →
Rouse_ © (2016-06-16 17:35) [28]
> Leonid Troyanovsky © (16.06.16 12:38) [27]
> С вертолета, танка - все это неспортивно ;)
Зависит от задачи :) Иногда муху реально проще убить из пушки :)
Страницы: 1 вся ветка
Форум: "Прочее";
Текущий архив: 2017.10.01;
Скачать: [xml.tar.bz2];
Память: 0.53 MB
Время: 0.002 c