Глубины 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

Не обязательно. Если клик не перекрыт, то в предке он просто хакнется еще раз. Не страшно.

Кстати, тоже интересная задачка - в run-time получить список всех использованных в проекте классов. Желательно, в виде дерева наследования.

У меня такая задачка:
Как создать экземпляр класса в стеке?
(по аналогии с C++).

> Юрий Зотов © (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;
из справки )

> 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/ ))

> StackAlloc можно взять тут http://sourceforge.net/projects/graphics32/files/graphics32/
> ))
>
>

А точнее.
Мне пока не ясно кто будет освобождать стек при выходе из функции.

GR32_LowLevel.pas -> StackFree(t);

зы, там в 64bit asm вроде поправимая, но ошибка.

> 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 © (16.06.16 12:38) [27]
> С вертолета, танка - все это неспортивно ;)

Зависит от задачи :) Иногда муху реально проще убить из пушки :)

Глубины VCL Найти похожие ветки