घर
Top.Mail.Ru Yandeks.Metrika
मंच: "अन्य";
वर्तमान संग्रह: 2017.10.01;
डाउनलोड करें: [xml.tar.bz2];

नीचे

VCL गहराई इसी तरह की शाखाएँ खोजें


Pavia ©   (2016-06-11 09:36) [0]

सभी मानक घटकों के लिए एक बार ऑनक्लिक घटना को कैसे बदलें? यह कहे बिना जाता है कि आप घटकों को फिर से नहीं लिख सकते, लेकिन आप 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]


> पाविया © (11.06.16 09: 36)

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

[3] + 100500

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

--
सादर, 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*

--
सादर, LVT



Leonid Troyanovsky ©   (2016-06-12 10:50) [8]


> लियोनिद ट्रायोनोव्स्की © (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;

--
सादर, LVT



Leonid Troyanovsky ©   (2016-06-13 09:59) [9]


> लियोनिद ट्रायोनोव्स्की © (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;

--
सादर, LVT



Rouse_ ©   (2016-06-14 11:15) [10]

तब टीसीटोनोल से डायनामिक क्लिक को इंटरसेप्ट करना आसान होता है



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);
था
 Dmt: PDmt;
 DmtMethods: PDmtMethods;
i: पूर्णांक;
 protect: Dword;
शुरू करना
 while Assigned(AClass) do
शुरू करना
   Dmt := GetDmt(AClass);
   if Assigned(Dmt) then
     for i := 0 to Dmt.Count-1 do
       if DMTIndex = Dmt.Indicies[i] then
शुरू करना
         DmtMethods := @Dmt.Indicies[Dmt.Count];
         Win32Check(VirtualProtect(@DmtMethods[i], 4, PAGE_READWRITE, protect));
         DmtMethods[i]:= newmethod;
         VirtualProtect(@DmtMethods[i], 4, protect, protect);
बाहर निकलें;
अंत;
   // Не в этом классе - поднимаемся по иерархии
   AClass := AClass.ClassParent;
अंत;
अंत;
Наконец, делаю  ReplaceDynamicMethod(TControl, -21, @newClick).

Но, в результате получаю, что на кнопках (TButton, TRadioButton, TCheckBox) оно не срабатывает.
Видимо, не все так просто. По крайней мере для меня :)

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

--
सादर, LVT



Leonid Troyanovsky ©   (2016-06-15 10:42) [12]


> लियोनिद ट्रायोनोव्स्की © (15.06.16 10: 31) [11]

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

Путем procedure DumpDynamicMethods, sorry.

--
सादर, LVT



Rouse_ ©   (2016-06-15 12:43) [13]


> लियोनिद ट्रायोनोव्स्की © (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]

हाँ, जानवर बल को ऐसे मामलों के लिए करना होगा + नए गैर-मानक नियंत्रण के निर्माण को नियंत्रित करें (क्लिक बंद के साथ)



Юрий Зотов ©   (2016-06-15 14:29) [19]

> Rouse_ © (15.06.16 14: 25) [18]
> контролировать создание контролов с перекрытым Click


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



Юрий Зотов ©   (2016-06-15 14:33) [20]

वैसे, एक और दिलचस्प काम रन-टाइम में परियोजना में उपयोग किए जाने वाले सभी वर्गों की एक सूची प्राप्त करना है। वंशानुक्रम के वृक्ष के रूप में वांछनीय है।



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;
था
// a : array [1..cl] of Byte;
t : TTest;
शुरू करना
// t := @a;
t := StackAlloc(TTest.InstanceSize);

TTest.InitInstance(t);

अंत;

Не? , а 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]


> लियोनिद ट्रायोनोव्स्की © (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 делать мне уже влом.

Для желающих поупражняться могу выложить юнит целиком.

--
सादर, LVT



Leonid Troyanovsky ©   (2016-06-16 12:38) [27]


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

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

--
सादर, LVT



Rouse_ ©   (2016-06-16 17:35) [28]


> लियोनिद ट्रायोनोव्स्की © (16.06.16 12: 38) [27]
> С вертолета, танка - все это неспортивно ;)

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



पन्ने: 1 पूरी शाखा

मंच: "अन्य";
वर्तमान संग्रह: 2017.10.01;
डाउनलोड करें: [xml.tar.bz2];

ऊपर









मेमोरी: 0.68 एमबी
समय: 0.031 c
2-1446463756
Valya
2015-11-02 14:29
2017.10.01
स्क्रॉल बटन


4-1283746765
स्पेलर
2010-09-06 08:19
2017.10.01
यह कैसे निर्धारित करें कि एक कार्यक्रम RemoteApp मोड में चल रहा है?


2-1446543628
Gedevan
2015-11-03 12:40
2017.10.01
प्रोग्राम को प्रपत्र Oncreate ईवेंट कैसे असाइन करें?


15-1465627000
Pavia
2016-06-11 09:36
2017.10.01
VCL गहराई


15-1465914259
pavel_guzhanov
2016-06-14 17:24
2017.10.01
फ्लैश ड्राइव के बारे में सवाल





अफ्रीकी अल्बानियन अरबी भाषा अर्मेनियाई आज़रबाइजानी बस्क बेलारूसी बल्गेरियाई कैटलन सरलीकृत चीनी) चीनी पारंपरिक) क्रोएशियाई चेक डेनिश डच अंग्रेज़ी एस्तोनियावासी फिलिपिनो फिनिश फ्रेंच
गैलिशियन् जॉर्जियाई जर्मन यूनानी हाईटियन यहूदी हिंदी हंगरी आइसलैंड का इन्डोनेशियाई आयरिश इतालवी जापानी कोरियाई लात्वीयावासी लिथुआनियाई मेसीडोनियन मलायी मोलतिज़ नार्वेजियन
फ़ारसी पोलिश पुर्तगाली रोमानियाई रूसी सर्बियाई स्लोवाक स्लोवेनियाई स्पेनिश स्वाहिली स्वीडिश थाई तुर्की यूक्रेनी उर्दू वियतनामी वेल्श यहूदी बंगाली बोस्नियाई
सिबुआनो एस्पेरांतो गुजराती हौसा हमोंग ईग्बो जावानीस कन्नड़ खमेर लाओ लैटिन माओरी मराठी मंगोलियन नेपाली पंजाबी सोमाली तामिल तेलुगु योरूबा
ज़ुलु
Английский Французский Немецкий Итальянский Португальский Русский Испанский