Как подменить событие OnClick разом у всех стандартных компонентов? Само-собой подразумевается, что компоненты переписывать нельзя, а вот править VCL можно.

В цикле присвоить другое событие.
Можно и через инспектор.

> Само-собой подразумевается, что компоненты переписывать
> нельзя, а вот править VCL можно.


Как это?
Если компоненты это и есть VCL? :)

Не трожь генофонд, зараза!

Application.OnMessage.

А переписывать глубины - не стоит.

> Pavia ©   (11.06.16 09:36)

> а вот править VCL можно.

[3] +100500

See also: http://rsdn.ru/forum/delphi/480838.1

--
Regards, LVT.

> Application.OnMessage.

Еще лучше - хук на мышь (с учетом того, что форма может быть модальной).

В любом варианте, главное - глубины не трогать. Там и без нас баги найдутся.

> Юрий Зотов ©   (12.06.16 08:52) [6]

> Еще лучше - хук на мышь

Клик может быть и клавой.
Тогда уж WH_GETMESSAGE or WH_CALLWNDPROC*

--
Regards, LVT.

> 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 ©   (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.

Проще тогда динамический Click у TControl перехватить на себя

> 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 на своем наследнике


путем


На моей D6 получается -21.
Пробую на кошках:


Наконец, делаю из 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 ©   (15.06.16 10:31) [11]

> путем function FindDynamicMethod(AClass: TClass; DMTIndex:

Путем procedure DumpDynamicMethods, sorry.

--
Regards, LVT.

> 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

Даже вот так, чтоб все по феншую было :)

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;

type
 TMyLabel = class(TLabel)
   protected
     procedure Click; override;
   end;

procedure TMyLabel.Click;
begin
 ShowMessage('WOW!');
end;

Розыч, какое сообщение (твое или мое) я увижу при клике по этой метке?

Мдя... твое :)

> Rouse_ ©   (15.06.16 14:00) [16]

В том и фокус, что вызывается не тот клик, который ты хакнул. Значит, надо пройтись по всем использованным в проекте контролам и применить твой хак к каждому.

Сделать, наверное, можно, но геморроя будет побольше.

Угу, перебор придется делать для таких случаев + контролировать создание новых нестандартных контролов (с перекрытым Click)

> 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.

> Rouse_ ©   (15.06.16 12:43) [13]

С вертолета, танка - все это неспортивно ;)

--
Regards, LVT.

> Leonid Troyanovsky ©   (16.06.16 12:38) [27]
> С вертолета, танка - все это неспортивно ;)

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