Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Delphi: Общие вопросы > "подменить" функцию WindowProc


Автор: Teleport 7.5.2009, 22:33
Как-то раз мне требовалось, чтобы компонент не реагировал на действия пользователя вообще никак, если курсор мышки находится над определенными координатами на компоненте. Вот какое решение мне предложили (на примере Button):

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    FOldWindowProc: TWndMethod;
    procedure NewWindowProc(var Message: TMessage);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  sanction: boolean;

implementation

{$R *.dfm}

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if (x<100) and (y<100) then
  sanction:= false
  else
   sanction:= true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FOldWindowProc := Button1.WindowProc;
  Button1.WindowProc := NewWindowProc;
end;

procedure TForm1.NewWindowProc(var Message: TMessage);
begin
if sanction= false then
  if (Message.Msg = WM_LBUTTONDOWN) or ( Message.Msg = WM_RBUTTONDOWN)   or
     (Message.Msg =wm_LButtonDblClk) or (Message.Msg =wm_MButtonDblClk) or
     (Message.Msg =wm_MButtonDown)
     then
     Exit;
  FOldWindowProc(Message);
end;

end.



Все работает замечательно. Но сейчас мне требуется для многих компонетов сделать такое ограничение реагирования. Например для Button2 - не реагировать, если координаты x и y меньше 75. А для Button3 - не реагировать, если координаты курсора x и y менее  50. Попробовал просто продублировать код для других компонентов, например для Button2 и Button3, - да не тут то было. Компоненты не отображаются вообще. А при завершении приложения - выскакивают ошибки. Я и ожидал, что такое не сработает, так как у нас в FormCreate присваивание происходит...  
Как сделать?  smile

Автор: kami 7.5.2009, 22:52
Цитата(Teleport @  7.5.2009,  22:33 Найти цитируемый пост)
Попробовал просто продублировать код для других компонентов, например для Button2 и Button3, - да не тут то было.

Как пробовал? Показывай.
Цитата(Teleport @  7.5.2009,  22:33 Найти цитируемый пост)
для многих компонетов сделать такое ограничение реагирования.

Дублировать код для каждого компонента - убиться можно.
Разве нельзя вывести единый принцип/формулу для определения необходимости вмешательства?
Потому что интерфейс приложения в стадии разработки обычно не является окончательным. А если придется добавлять/удалять кнопки? И если напутаешь с тем, чьи перекрытые оконные процедуры удалил?

Автор: Teleport 7.5.2009, 23:23
2 kami
 
Код

Дублировать код для каждого компонента - убиться можно.
 - это я понимаю. 

Дублировал я не очень много. Сейчас покажу:
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Button2MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    FOldWindowProc, FOldWindowProc2: TWndMethod;
    procedure NewWindowProc(var Message: TMessage);
    
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  sanction: boolean;

implementation

{$R *.dfm}

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if (x<100) and (y<100) then
  sanction:= false
  else
   sanction:= true;
end;



procedure TForm1.Button2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if (x<75) and (y<75) then
  sanction:= false
  else
   sanction:= true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FOldWindowProc := Button1.WindowProc;
  Button1.WindowProc := NewWindowProc;
FOldWindowProc2 := Button2.WindowProc;
  Button2.WindowProc := NewWindowProc;

end;

procedure TForm1.NewWindowProc(var Message: TMessage);
begin
if sanction= false then
  if (Message.Msg = WM_LBUTTONDOWN) or ( Message.Msg = WM_RBUTTONDOWN)   or
     (Message.Msg =wm_LButtonDblClk) or (Message.Msg =wm_MButtonDblClk) or
     (Message.Msg =wm_MButtonDown)
     then
     Exit;
  FOldWindowProc(Message);
end;

end.


я понимаю, что написано внутри NewWindowProc. Это и есть тот самый единый принцип/формуа. Пробовал присваивание:
Код

FOldWindowProc := Button1.WindowProc;
  Button1.WindowProc := NewWindowProc;
FOldWindowProc2 := Button2.WindowProc;
  Button2.WindowProc := NewWindowProc;


делать в событии MouseMove для каждого компонента- тоже не помогает...

Автор: kami 7.5.2009, 23:41
А теперь посмотри внимательнее на NewWndProc.
Она:
1. Становится стандартной виндовой процедурой для Button1 и Button2.
2. Вызвается при каждом сообщении, которое пришло для Button1 и Button2
3. А ВНУТРИ СЕБЯ ВЫЗЫВАЕТ СТАРУЮ ОКОННУЮ ФУНКЦИЮ Button1. Даже если это было сообщение для Button2.

И чего же ты хочешь, собственно говоря от второй кнопки, когда ей ничего не доходит?

Добавлено через 1 минуту и 55 секунд
Цитата(Teleport @  7.5.2009,  23:23 Найти цитируемый пост)
Дублировал я не очень много.

Вот именно, что "недопередублировал".  smile

Добавлено через 4 минуты и 55 секунд
Цитата(Teleport @  7.5.2009,  23:23 Найти цитируемый пост)
я понимаю, что написано внутри NewWindowProc.

Видимо, не совсем понимаешь.

Цитата(Teleport @  7.5.2009,  23:23 Найти цитируемый пост)
Это и есть тот самый единый принцип/формуа.

Увы - нет.
Принцип должен "выплыть" из Button1MouseMove и Button2MouseMove, которые должны слиться в одну и работать с тем, что за кнопка/другой компонент вызывал событие через Sender.

Автор: Teleport 7.5.2009, 23:51
как дорога в тумане...)) почему второй кнопке ничего не доходит?

Автор: kami 7.5.2009, 23:58
Цитата(Teleport @  7.5.2009,  23:51 Найти цитируемый пост)
почему второй кнопке ничего не доходит?

Диктую по буквам, голосом, выпуклыми буквами, русским по экрану.
1. В FormCreate ты сохраняешь старые оконные функции для кнопки1 и для кнопки2.
2. Присваиваешь одну на двоих новую оконную функцию.
3. Теперь сообщения, которые пришли для кнопки1 и для кнопки2 будут проходить через NewWindowProc.
4. Смотрим в код NewWindowProc. Внимательно смотрим.
5. Проверяется куча условий, после чего если ни одно не выполнено вызываем "старую" оконную процедуру кнопки1.
НО! Читаем внимательно пункт 3.
Что будет, когда придет сообщение для кнопки2? (например, WM_Paint) ?
Правильно, проверится куча условий и вызовется оконная процедура кнопки1.
А на кой кнопке1 сообщение, которое должно было дойти кнопке2?

Как результат - у кнопки1 пухнет голова от избытка информации, которая ей не нужна.
Кнопка2 находится в неведении, что происходит - она не получила ни одного сообщения, не знает, в каком состоянии она находится, и тем более не может отслеживать ничего.

Автор: Teleport 8.5.2009, 00:42
Тему считаю закрытой. 

Автор: Rrader 8.5.2009, 06:42
Teleport, если это для кнопки, то дело решается 0 строк кода, я тебе уже давал код.

Автор: kami 8.5.2009, 07:36
Цитата(Rrader @  8.5.2009,  06:42 Найти цитируемый пост)
 дело решается 0 строк кода, я тебе уже давал код

Можно ссылку?
Мне тоже интересно.

Автор: Teleport 8.5.2009, 12:31
2 Rrader - это когда я про прыжки ползунков на ScrollBox спрашивал? Типа хитрое наследование?
Мне не для кнопки, а для листа TNextSheet. Вот в первом посту моем - рабочий код и для кнопки и для листа TNextSheet - если по отдельности. Но я не могу понять, как для двух компонетов сделать-то? 

по советам kami пришел к единой процедуре MouseMove:
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure comp_mouse_move(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    FOldWindowProc : TWndMethod;
    procedure NewWindowProc(var Message: TMessage);

    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  sanction: boolean;

implementation

{$R *.dfm}

procedure TForm1.comp_mouse_move(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if TButton(Sender).name= 'Button1' then
   if (x<100) and (y<100) then
      sanction:= false
   else
      sanction:= true;

 if TButton(Sender).name= 'Button2' then
   if (x<75) and (y<75) then
      sanction:= false
   else
      sanction:= true;
 end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//FOldWindowProc := TButton(Sender).WindowProc;  //не прокатило
  //TButton(Sender).WindowProc := NewWindowProc;
end;

procedure TForm1.NewWindowProc(var Message: TMessage);
begin
if sanction= false then
  if (Message.Msg = WM_LBUTTONDOWN) or ( Message.Msg = WM_RBUTTONDOWN)   or
     (Message.Msg =wm_LButtonDblClk) or (Message.Msg =wm_MButtonDblClk) or
     (Message.Msg =wm_MButtonDown)
     then
     Exit;
  FOldWindowProc(Message);
end;

end.


 но где сделать присваивание
Код

FOldWindowProc := TButton(Sender).WindowProc; 
 TButton(Sender).WindowProc := NewWindowProc;


и такое ли оно - не пойму. Пихал его в MouseMove - не прокатывает. Одни ошибки.

Автор: Rrader 8.5.2009, 13:27
Цитата(Teleport @  8.5.2009,  18:31 Найти цитируемый пост)
2 Rrader - это когда я про прыжки ползунков на ScrollBox спрашивал? Типа хитрое наследование?

 smile 
Цитата(Teleport @  8.5.2009,  18:31 Найти цитируемый пост)
Мне не для кнопки, а для листа TNextSheet.

Вот, я это имел в виду. Надо сразу об этом говорить, потому что так легко запутать отвечающих.

kami, имелось в виду сделать единую процедуру. И при каждой новодобавленной кнопке работать только в Object Inspector.

Для этого примера - проставить Button1.Tag = 100, Button2.Tag = 75. Для второй кнопки выставляем OnMouseDown = Button1MouseDown.
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with (Sender as TComponent) do
    if (X < Tag) and (Y < Tag) then
      ReleaseCapture;
end;

end.

Но Teleport нас обманул, поэтому для TNextSheet пусть сам думает smile 

Автор: Teleport 8.5.2009, 15:28
вопрос как подменить WindowProc для нескольких компонетов.  ReleaseCapture - это я знаю. Но оно мне не надо. smile

Автор: kami 8.5.2009, 18:36
Цитата(Teleport @  8.5.2009,  12:31 Найти цитируемый пост)
procedure TForm1.FormCreate(Sender: TObject);begin//FOldWindowProc := TButton(Sender).WindowProc;  //не прокатило  //TButton(Sender).WindowProc := NewWindowProc;end;

Гхм.
А вы вообще представляете, что такое Sender?
На всякий случай поясню - это компонент, вызывавший событие.
В данном случае, в событии  TForm1.FormCreate это Form1.
И поясните тогда, свой код в этой процедуре, с учетом Sender=Form1.

Ладно, поясню сам:
1. В этом событии Sender - это Form1.
2. C учетом (1) получаем FOldWindowProc := TButton(Form1).WindowProc;
3. Ничего не смущает? А именно - где Form1 и где TButton?

В остальном, если comp_mouse_move - это OnMouseMove для Button1 и Button2 все нормально.

Сделай прямое присваивание новых оконных ф-й в FormCreate для каждой кнопки и будет счастье. Вопрос "кому оно будет" - другой и подлежит переносу в другую ветку smile 

Автор: Teleport 8.5.2009, 21:11
вобщем, обойдусь дублированием для каждого компонента. 

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)