Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Программирование на Delphi и Lazarus

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 3.307 RSS
←   Сентябрь 2013   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30


За последние 60 дней ни разу не выходила


Сайт рассылки: http://rusfaq.ru/
Открыта: 14-03-2002

Автор
Калашников О.А.

Статистика

3.307 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Программирование на Delphi и Lazarus


Хостинг портала RFpro.ru:
Московский хостер
Профессиональный ХОСТИНГ на базе Linux x64 и Windows x64

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Лучшие эксперты по данной тематике

Асмик Гаряка
Статус: Советник
Рейтинг: 10659
∙ повысить рейтинг » 		Орловский Дмитрий
Статус: Мастер-Эксперт
Рейтинг: 7150
∙ повысить рейтинг » 		Boriss
Статус: Академик
Рейтинг: 1321
∙ повысить рейтинг »

/ КОМПЬЮТЕРЫ И СОФТ / Программирование / Delphi и Lazarus

Номер выпуска:1650
Дата выхода:29.09.2013, 08:00
Администратор рассылки:Киселёва Алёна aka Verena (Академик)
Подписчиков / экспертов:71 / 44
Вопросов / ответов:1 / 1

Консультация # 187549: Здравствуйте! Для оживления ветки такой вопрос: Среда делфи 2010, для обработки момента прокрутки колеса мышки используется такие процедуры:

Код :
private
    { Private declarations }

    // обработка движения колеса мыши
    {procedu
...

Консультация # 187549:

Здравствуйте! Для оживления ветки такой вопрос:
Среда делфи 2010, для обработки момента прокрутки колеса мышки используется такие процедуры:

Код :
private
    { Private declarations }

    // обработка движения колеса мыши
    {procedure MouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);  }

    // обработка прокрутки колеса вниз
    procedure MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);

    // обработка прокрутки колеса вверх
    procedure MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);

..

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Назначаем обработчики для событий:
  // движение колеса мыши
  {Form1.OnMouseWheel:= MouseWheel;}
  // прокрутка колеса вниз
  Form1.OnMouseWheelDown:= MouseWheelDown;
  // прокрутка колеса вверх
  Form1.OnMouseWheelUp:= MouseWheelUp;
end;


Процедуры работают, но на разных компьютерах при одном шаге прокрутки колесика мышки эта процедура вызывается разное количество раз, на моём получается три раза подряд. Изменения системных настроек колеса мышки на прокрутку всего одной строки или одного листа к ожидаемому эффекту в виде вызова только раз этой процедуры не приводит. Как можно с этим справиться?
Спасибо.

Дата отправки: 26.09.2013, 07:23
Вопрос задал: Евгений/Genia007/ (Профессионал)
Всего ответов: 1
Страница онлайн-консультации »

Консультирует LanK (Профессионал):

Здравствуйте, Евгений/Genia007/!

Вопрос оказался не из простых, как кажется на первый взгляд.
Внимание! Проблема проявляется только в продуктах Delphi (!) и не проявляется в Lazarus.

Похоже это "глюк" который тянется из недр ядра Delphi... (проверялось на Delphi 7 и XE2)

Проблема заключается в том, что событие OnMouseWheel "перехватывают" несколько компонентов, начиная с самой формы, так и объектов Button, ListView и т.д. Каждый объект считает что событие OnMouseWheel произошло на нем и "увеличивает" счетчик срабатывания. В результате вместо прокрутки на один шаг, происходит прокрутка на 2, 3 шага.

Для того чтобы продемонстрировать указанную ошибку необходимо создать новый проект (на Delphi 7 - XE2).
Разместить на форму два Label (Label1, Label2).
Разместить на форму один Button (Button1).
Заменить текст unit1 на прилагаемый:

Код :
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
  private
    { Private declarations }

  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  id1:Integer = 0;
  id2:Integer = 0;

implementation

{$R *.dfm}

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Inc(id1);
  label1.Caption:=IntToStr(id1);
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Inc(id2);
  Label2.Caption:=IntToStr(id2);
end;

end.


Запустив проект и прокрутив колесо увидим приращения по ДВЕ цифры, а не по одной.
Удалив Button1 - приращение будет по ОДНОЙ цифре.


Предложенное решение - отобрать у формы событие OnMouseWheel...

(В таком же ключе можно в дальнейшем отобрать и у других "лишних" компонентов.
Либо поставить перехват сообщения OnMouseWheel для всего приложения)

Необходимо снова разместить Button1 на форму, добавить Label3 и заменить текст Unit1 на ниже следующий:

Код :
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Button1: TButton;
    procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }

//КЛЮЧЕВОЕ добавление:
    Procedure WMMOUSEWHEEL (Var Msg: TWMMOUSEWHEEL );
    Message WM_MOUSEWHEEL ;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  id1:Integer = 0;
  id2:Integer = 0;

implementation

{$R *.dfm}

Procedure TForm1.WMMOUSEWHEEL(Var Msg: TWMMOUSEWHEEL );
Begin
{
  //"захватили" сообщение и ничего по нему не делаем...
  //но если нужно... что то делать...
  //в общем, мы просто отобрали у самой формы это событие
  //и теперь OnWheel есть только у самих компонентов...
  //тем не менее если необходимо далее с этим сообщением работать
  //используйте код:
	If Msg.WheelDelta > 0 Then
		Label3.Caption:='UP'
	Else
		Label3.Caption:='DOWN';
}
End;

procedure TForm1.Button1Click(Sender: TObject);
  //функция позволяющая узнать что установлено в свойствах системы - 
  //Панель управления / Мышь / Закладка "Колесико" / Поворот на указанное количество строк.
  //т.е. как пользователь хотел... бы чтобы работало колесико:
  function GetNumScrollLines: Integer;
  begin
    SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @Result, 0);
  end;

begin
  //по хорошему это надо знать и "крутить" в соответствии с этим количеством:
  ShowMessage(IntToStr(GetNumScrollLines));
end;

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  //увеличиваем счетчик срабатывания и выводим значение в label1:
  Inc(id1);
  label1.Caption:=IntToStr(id1);
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  //увеличиваем счетчик срабатывания и выводим значение в label2:
  Inc(id2);
  Label2.Caption:=IntToStr(id2);
end;

end.


В результате указанных изменений событие OnMouseWheel больше не обрабатывается Form, при этом по прежнему обрабатывается Button и мы получаем приращение по "1".

Повторюсь, аналогично можно "отобрать" это событие у "не нужных компонентов".

P.S. Если Вам не хочется искать "не нужные компоненты" и отключать у них это событие...
Можно поступить проще - решение "в лоб":

Добавить Label1 Label2 посмотреть цифру приращения и заменить обработчик:

Код :
procedure TForm1.MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  inc(id1);
  if (id1 mod 2) <> 0 then exit;  //или 3... сколько у вас будет. Суть - "убрать" лишние срабатывания.
//Ниже ВАШ код который Вы хотите чтобы выполнялся с приращением "1":
//.....
end;

procedure TForm1.MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  inc(id2);
  if (id2 mod 2) <> 0 then exit;  //или 3... сколько у вас будет.
//Ниже ВАШ код который Вы хотите чтобы выполнялся:
//.....
end;


Всем УДАЧИ в борьбе smile

Консультировал: LanK (Профессионал)
Дата отправки: 27.09.2013, 12:27

5
Спасибо за подробное объяснение.
-----
Дата оценки: 27.09.2013, 13:00
Рейтинг ответа:

НЕ одобряю 0 одобряю!

Оценить выпуск | Задать вопрос экспертам

главная страница  |  стать участником  |  получить консультацию
техническая поддержка  |  восстановить логин/пароль

Дорогой читатель!
Команда портала RFPRO.RU благодарит Вас за то, что Вы пользуетесь нашими услугами. Вы только что прочли очередной выпуск рассылки. Мы старались. Пожалуйста, оцените его. Если совет помог Вам, если Вам понравился ответ, Вы можете поблагодарить автора - для этого в каждом ответе есть специальные ссылки. Вы можете оставить отзыв о работе портале. Нам очень важно знать Ваше мнение. Вы можете поближе познакомиться с жизнью портала, посетив наш форум, почитав журнал, который издают наши эксперты. Если у Вас есть желание помочь людям, поделиться своими знаниями, Вы можете зарегистрироваться экспертом. Заходите - у нас интересно!
МЫ РАБОТАЕМ ДЛЯ ВАС!

© 2001-2012, Портал RFPRO.RU, Россия
Авторское право: ООО "Мастер-Эксперт Про"
Калашников О.А. | Гладенюк А.Г.
Хостинг: Компания "Московский хостер"
Версия системы: 2011.6.36 от 26.01.2012
В избранное