Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: WinAPI и системное программирование > Событие на прокрутку колесика мыши

Автор: DragonFire 20.2.2006, 12:44

Не подскажет кто-нибудь?

Автор: Snowy 20.2.2006, 12:45

WM_MOUSEWHEEL
Добавлено @ 12:51
Пример использования: http://forum.vingrad.ru/index.php?showtopic=84096&view=findpost&p=647038

Автор: DragonFire 20.2.2006, 12:58

Спасибо

Автор: DragonFire 20.2.2006, 15:17

Посмотрел я и что-то у меня не пашет smile

Почему не работает такой код:

Код


WM_MOUSEWHEEL: begin
    if HIWORD(WParam)-WHEEL_DELTA>0 then ZScroll:=ZScroll-1
    else ZScroll:=ZScroll+1;
end;

Автор: Romikgy 20.2.2006, 15:48

Код


WM_MOUSEWHEEL: begin
    if ((HIWORD(WParam)-WHEEL_DELTA)>0) then ZScroll:=ZScroll-1
    else ZScroll:=ZScroll+1;
end;

Мож так будет работать?
Добавлено @ 15:54

Код


WM_MOUSEWHEEL: begin
    if (abs(HIWORD(WParam))>WHEEL_DELTA) then ZScroll:=ZScroll-floor(HIWORD(WParam)/WHEEL_DELTA)
    else ZScroll:=ZScroll+floor(HIWORD(WParam)/WHEEL_DELTA);
end;

Автор: Snowy 20.2.2006, 16:32

Только что проверил.
Твой код полностью рабочий.
Видимо ты просто не в том месте ловишь.

Автор: DragonFire 20.2.2006, 20:46

Нифига ничего не пашет smile

Romikgy:
Комп не понимает, что такое floor. Попробовал заменить на Round - тоже не пашет.
В обоих случаях, в моем и что предложил Romikgy срабатывает только строка с минусом:

Код


ZScroll:=ZScroll-floor(HIWORD(WParam)/WHEEL_DELTA)
ZScroll:=ZScroll-1

Неважно, в какую сторону повернуто колесико - всегда только это действие...
Насчет ловлю:

Код


function WindowProc (Window : HWnd; Message, WParam : Word; LParam : LongInt) : LongInt; stdcall;
begin
  WindowProc:=0;
  case Message of
       WM_MOUSEWHEEL: begin
                      if HIWORD(WParam)-WHEEL_DELTA>0 then ZScroll:=ZScroll-1
                      else ZScroll:=ZScroll+1;     
                                       end;
  end;               
end;

Автор: Snowy 20.2.2006, 22:04

function WindowProc она чья?
Это у тебя API приложение или VCL?

Автор: DragonFire 20.2.2006, 22:19

VCL нету...
Чистый API

Автор: Snowy 20.2.2006, 23:23

Давай сюдавесь код. У меня все отлично отрабатывает, если WindowProc - обработчик сообщений главного окна.
P.S. операционка какая?

Автор: DragonFire 21.2.2006, 08:49

Ну вот примерно так... вырезал из кода все ненужно...
Операционка - WindowsXP

Код


Library GameL;
uses
  Windows,
  Messages,
var
  Window:HWnd;  
  Message:TMsg;
  WindowClass:TWndClass;
   ZScroll:integer;
  
function WindowProc (Window : HWnd; Message, WParam : Word; LParam : LongInt) : LongInt; stdcall;
begin
  WindowProc:=0;
  case Message of
      wm_Destroy:begin
                  PostQuitMessage (0);
                  end;
       WM_MOUSEWHEEL: begin
                      {if HIWORD(WParam)-WHEEL_DELTA>0 then ZScroll:=ZScroll-1
                      else ZScroll:=ZScroll+1;  }
                      //if (abs(HIWORD(WParam))>WHEEL_DELTA) then ZScroll:=ZScroll-1//round(HIWORD(WParam)/WHEEL_DELTA)
                      //else ZScroll:=ZScroll+1;//round(HIWORD(WParam)/WHEEL_DELTA);

                      if ZScroll>0 then ZScroll:=0;
                      if ZScroll<-15 then ZScroll:=-15
                  end;
  end;
  WindowProc := DefWindowProc (Window, Message, WParam, LParam);
end;

procedure Game(Inst:Cardinal);
begin
  with WindowClass do begin
    Style:=cs_HRedraw or cs_VRedraw; 
    cbClsExtra := 0; 
    cbWndExtra := 0;
    hInstance := 0; 
    hIcon := LoadIcon (0, idi_Application); 
    hCursor := LoadCursor (0, idc_Arrow); 
    hbrBackground := GetStockObject(White_Brush); 
    lpszMenuName := '';             
    lpszClassName := 'GameInGame';  
  end;

   If RegisterClass (WindowClass) = 0 then
     Halt (255); 
     Window := CreateWindow
     ('GameInGame',            
      'Game',          
      WS_MAXIMIZE or WS_VISIBLE or WS_POPUP or WS_CLIPCHILDREN or WS_CLIPSIBLINGS, 
      0,
      0,
      1024,
      768, 
      0,     
      0,     
      Inst, 
      nil);  
  
   ShowWindow(Window, CmdShow); 
  UpdateWindow(Window);
  
  While GetMessage(Message,0,0,0) do begin 

    TranslateMessage (Message); 
    DispatchMessage (Message);   

    end;

   UnRegisterClass('GameInGame',Inst);
end;

      exports
        Game;
begin
end.

Автор: Romikgy 21.2.2006, 10:32

Цитата(DragonFire @ 20.2.2006, 19:46

)

что такое floor

для нее надо uses Math;
А в дебагере посмотреть что приходит в HIWORD(WParam) ?

Автор: DragonFire 21.2.2006, 11:22

HIWORD(WParam) - ничего не пишет...
WParam - всегда равен 0

Автор: Romikgy 21.2.2006, 11:29

Цитата(DragonFire @ 21.2.2006, 10:22

)

WParam - всегда равен 0

Хм ... странно это ...
Добавлено @ 11:35
попробуй этим воспользоватся
int GetSystemMetrics(

int nIndex // system metric or configuration setting to retrieve
);
с флагом
SM_MOUSEWHEELPRESENT Windows NT only: TRUE or nonzero if a mouse with a wheel is installed; FALSE, or zero, otherwise.

Автор: DragonFire 22.2.2006, 12:30

Че это за фишка?

Автор: Snowy 22.2.2006, 12:39

Сам код какой-то кривой.
Странно, что вообще хоть что-то работает.

Автор: DragonFire 22.2.2006, 14:33

В смысле? Что в нем кривого?

Автор: Snowy 22.2.2006, 14:42

У меня вообще не заработал.

Автор: DragonFire 22.2.2006, 15:40

Это просто код из библиотеки...
Для приложения он буден другим...

Автор: mes 26.2.2006, 02:57

У меня была подобная проблема. При событии программа не распозновала отрицателный поворот колеса. У тебя похоже таже проблема. Дело в типе. Delta должна быт' smallint.
кроме того непонятно зачем отнимать WHEEL_DELTA на неё надо делить.

Вот смотри:

Код




var zDelta:integer;
....

  WM_MOUSEWHEEL: begin
                       zDelta := smallint (hiword(wParam)) div WHEEL_DELTA; {Кол-во щелчков колесика}

                       zScroll:=zScroll+zDelta ;  {положителное прибавит, отрицательное отнимет}
                   
                      if zScroll>0 then zScroll:=0;
                      if zScroll<-15 then zScroll:=-15
                  end;

Автор: DragonFire 26.2.2006, 11:37

Всеравно не пашет...
У меня почему то всевремя lParam равен 0 smile

Автор: mes 26.2.2006, 13:04

Цитата(DragonFire @ 26.2.2006, 11:37

)

Всеравно не пашет...

Как именно не пашет?
Насколько я понял, событие у тебя есть но параметры нулевые.
Или как?

Автор: mes 26.2.2006, 14:09

Цитата(DragonFire @ 26.2.2006, 11:37

)

У меня почему то всевремя lParam равен 0

может wParam равен 0 ?

попробуй так (вместо Word поставь WParam):

Код


function WindowProc (Window : HWnd; Message, WParam : WParam; LParam : LParam) : LongInt; stdcall;

Автор: DragonFire 26.2.2006, 19:29

Неа, компу пофигу smile

Автор: Snowy 26.2.2006, 19:40

Код

program wmmwheel;

uses
  Windows, Messages;

var
  wClass:     TWndClass;
  hAppHandle: HWND;
  wMsg:       TMSG;
  zScroll:    integer = 1024;

function IntToStr(i: integer): string;
begin
  str(i, result);
end;

function WndMessageProc(hWnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;
begin
 Result := 0;
  case Msg of
    WM_DESTROY:
      PostQuitMessage(0);
    WM_MOUSEWHEEL:
      begin
        if HIWORD(WParam)-WHEEL_DELTA > 0 then ZScroll:=ZScroll-1
        else ZScroll:=ZScroll+1;
        SendMessage(hWnd, WM_SETTEXT, 0, integer(PChar(IntToStr(ZScroll))));
      end;
  else
    result := DefWindowProc(hWnd, Msg, wParam, lParam);
  end;
end;

begin
  wClass.hInstance := hInstance;
  with wClass do begin
    style         := 0;
    hIcon         := 0;
    lpfnWndProc   := @WndMessageProc;
    hbrBackground := COLOR_BTNFACE + 1;
    lpszClassName := 'MYCLASS';
    hCursor       := LoadCursor(0,IDC_ARROW);
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    lpszMenuName  := '';
  end;
  RegisterClass(wClass);
  hAppHandle := CreateWindow(wClass.lpszClassName, nil,
   WS_OVERLAPPEDWINDOW or WS_VISIBLE, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    320, 200, 0, 0, hInstance, nil);

  if hAppHandle = 0 then begin
   UnRegisterClass(wClass.lpszClassName, hInstance);
   Exit;
  end;
  ShowWindow(hAppHandle, SW_SHOWNORMAL);
  UpdateWindow(hAppHandle);

  while GetMessage(wMsg,0,0,0) do begin
    TranslateMessage(wMsg);
    DispatchMessage(wMsg);
  end;

end.

Добавлено @ 19:41
Приаттачиваю откомпилированный exe.
Он ничего не делает, кроме реакции на колесо мыши.

Автор: mes 26.2.2006, 21:28

Цитата(DragonFire @ 26.2.2006, 11:37

)

Всеравно не пашет...

в моём коде была опечатка: вместо HiWord, я написал hi. ( Исправил в коде).

Цитата(Snowy @ 26.2.2006, 19:40

)

if HIWORD(WParam)-WHEEL_DELTA > 0 then ZScroll:=ZScroll-1
else ZScroll:=ZScroll+1;

не согласен с этой строчкой, так как подобное применение противоречит "замыслу" параметра Wheel_Delta.
Должен признать, что такой код работает, но не могу согласится с тем , что он работает и будет работат правильно.
Wheel_Delta введена для обратной совместимости, когда мышки будут за одно сообщение передавать не один шелчок, а группу.

WParam в зависимости от направления должен быть равен Wheel_delta или -Wheel_Delta (120 или -120). Однако "проверив" значения WParam мы обнаруживаем, что он равен либо 120 или 65416. Причина етого недоразумения в несоответствии типов.
Word (65416) = 65416
Integer(65416) = 65416
Smallint(65416)=-120 !

Обратили внимание что при преобразовании в тип Integer,( который может принимать отрицательные значения), значение остается положительным, а преобразовании в тип SmallInt даёт то, что мы утеряли. smile

Добавлено @ 21:30
Еше хотелось бы сказать по поводу сообщениa WM_MOUSEWHEEL:
его может получат только активное окно. поэтому используйте SetFocus.

Автор: Snowy 26.2.2006, 22:43

Цитата(mes @ 26.2.2006, 21:28

)

не согласен с этой строчкой, так как подобное применение противоречит "замыслу" параметра Wheel_Delta.

Согласен. Но такое применение - стандартная практика.
Хотя, конечно, если все делать по честному, то код будет выглядеть так:

Код


program wmmwheel;
uses    
  Windows, Messages;    
var    
  wClass:     TWndClass;    
  hAppHandle: HWND;    
  wMsg:       TMSG;    
  zScroll:    integer = 1024;    
function IntToStr(i: integer): string;    
begin    
  str(i, result);    
end;    
function WndMessageProc(hWnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;    
begin    
 Result := 0;    
  case Msg of    
    WM_DESTROY:    
      PostQuitMessage(0);    
    WM_MOUSEWHEEL:    
      begin    
        ZScroll:=ZScroll+(shortint(HIWORD(WParam)) div WHEEL_DELTA);
        SendMessage(hWnd, WM_SETTEXT, 0, integer(PChar(IntToStr(ZScroll))));
      end;    
  else    
    result := DefWindowProc(hWnd, Msg, wParam, lParam);    
  end;    
end;    
begin    
  wClass.hInstance := hInstance;    
  with wClass do begin    
    style         := 0;    
    hIcon         := 0;    
    lpfnWndProc   := @WndMessageProc;    
    hbrBackground := COLOR_BTNFACE + 1;    
    lpszClassName := 'MYCLASS';    
    hCursor       := LoadCursor(0,IDC_ARROW);    
    cbClsExtra    := 0;    
    cbWndExtra    := 0;    
    lpszMenuName  := '';    
  end;    
  RegisterClass(wClass);    
  hAppHandle := CreateWindow(wClass.lpszClassName, nil,    
   WS_OVERLAPPEDWINDOW or WS_VISIBLE, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),    
    320, 200, 0, 0, hInstance, nil);    
  if hAppHandle = 0 then begin    
   UnRegisterClass(wClass.lpszClassName, hInstance);    
   Exit;    
  end;    
  ShowWindow(hAppHandle, SW_SHOWNORMAL);    
  UpdateWindow(hAppHandle);    
  while GetMessage(wMsg,0,0,0) do begin    
    TranslateMessage(wMsg);    
    DispatchMessage(wMsg);    
  end;    
end.

Цитата(mes @ 26.2.2006, 21:28

)

когда мышки будут за одно сообщение передавать не один шелчок, а группу.

Насколько я помню, изначально предполагалось, что разница будет давать кол-во строк, которые нужно прокручивать за один ход колеса. Но мне как-то не попадались ситуации, чтобы значение отличалось от 120. Может в 98-х так и есть...

Автор: mes 26.2.2006, 23:40

Цитата(Snowy @ 26.2.2006, 22:43

)

Но такое применение - стандартная практика.

Цитата(Snowy @ 26.2.2006, 22:43

)

Хотя, конечно, если все делать по честному, то код будет выглядеть так:

Цитата(Snowy @ 26.2.2006, 22:43

)

Не могу точно сказать, но вроде предусмотрено для более чуствител'ных мышек, у которых несколько шелчков соответствуют
одному щелчку колесика обычной мышки.

Автор: DragonFire 28.2.2006, 14:40

mes
Я еще раз все попробовал, но всеравно не пашет - как ни крути в любом случае значение ZScroll только увеличивается...
Snowy
Архив скачал - ща буду разбиратся...

Автор: DragonFire 28.2.2006, 15:19

Все, я понял!
Оба кода рабочие, тока везде надо писать так:

Код


function WindowProc (Window : HWnd; Message, WParam : WParam; LParam : LParam) : LongInt; stdcall;

Все, отладил smile

Спасибо обоим большое smile

Автор: Snowy 28.2.2006, 16:05

Конечно оба рабочие.
Просто второй честный, а первый быстрый.
Правда в данном случае данный выигрыш в скорости ничего не значит.

Цитата(DragonFire @ 28.2.2006, 15:19

)

Спасибо обоим большое

Большое пожалуйста smile

Автор: mes 1.3.2006, 00:00

Цитата(Snowy @ 28.2.2006, 16:05

)

Конечно оба рабочие.
Просто второй честный, а первый быстрый.

В скоростном примере есть недостаток, что в опеределенных ситуациях(которых конечно может и не быть, но всё же)
вероятна ситуация, когда программа неправильно оценит направление врашения колесика.
Во втором примере есть деление, которое само по себе медленое.
Предлагаю такое компромиссное решение:

Код


 if HIWORD(WParam) > $7FFF  then ZScroll:=ZScroll-1
        else ZScroll:=ZScroll+1;

Значение $7FFF наибольшее положительное при преобразовании формата из Word в Smallint.

Автор: Snowy 1.3.2006, 10:23

Скорость здесь совсем не критична.
Не могу представить, чтобы юзер крутил колесом с такой скоростью, что система не будет успевать отвечать smile

Мыша задымится smile

Но такой вариант имеет смысл. На всякий случай, пусть даже он никогда и не наступит.
Хотя придумывать можно еще много всякого ;)

Автор: mes 30.10.2006, 20:29

Цитата(mes @ 1.3.2006, 00:00

)

Код


 if HIWORD(WParam) > $7FFF  then ZScroll:=ZScroll-1
        else ZScroll:=ZScroll+1;

Я понимаю, что поднимаю старую тему, но всё же считаю, что инфа может быть полезна:
Имхо правильный код:

Код


  if (Smallint(HIWORD(WParam))> 0)  then ZScroll:=ZScroll-1
                                    else ZScroll:=ZScroll+1;

либо:

Код


var zDelta: Smallint;
...
zDelta:=HIWORD(WParam);
  if (zDelta > 0)  then ZScroll:=ZScroll-1
                   else ZScroll:=ZScroll+1;

Автор: Snowy 30.10.2006, 21:55

mes, этот вариант - то же самое, только с приведением типов.
Разница только в знаковости или беззнаковости типов.
Оптимизатор Delphi всё равно приведёт её к предыдущему виду.

Автор: mes 2.11.2006, 15:41

Цитата(Snowy @ 30.10.2006, 21:55

)

mes, этот вариант - то же самое, только с приведением типов.
Разница только в знаковости или беззнаковости типов.
Оптимизатор Delphi всё равно приведёт её к предыдущему виду.

Ну да, для компа будет один и тот же код, но програмисту удобнее, понятнее и логичнее последний. Именно поэтому я его и привёл, несмотря на давность темы smile

.

P.S. А у начинающих и вопросов не будет: " почему именно $7FFF ? " ;)

Автор: blackkot32 28.10.2018, 00:34

пишу глобальный хук на колесо мыши, т.к. нужно отслеживать прокрутку в другой программе. никак не получается определить в какую сторону крутится колесо мыши. куда ни крути - одно и тоже. подскажите, что не так, пожалуйста.

Код


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);


  private
    { Private declarations }
     FHookStarted : Boolean;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
var

  JHook: THandle;



{$R *.dfm}



function JournalProc(Code, wParam: Integer; var Msg: TEventMsg): Integer; stdcall;
var s: string;  zDelta:integer;
begin
  Result := CallNextHookEx(JHook, Code, wParam, Longint(@Msg));
  if Code < 0 then Exit;
  if Code = HC_SYSMODALON then Exit;
  if Msg.message = WM_MOUSEWHEEL then
    begin
    s := '';

    if HIWORD(WParam)-WHEEL_DELTA > 0 then s:='up' else s:='down';    //куда ни крути - здесь всё равно down

    if s <> '' then Form1.ListBox1.ItemIndex :=  Form1.ListBox1.Items.Add(s);
    end;


end;





procedure TForm1.Button1Click(Sender: TObject);
begin
 if FHookStarted then

  begin

    ShowMessage('Mouse is already being Journaled, can not restart');

    Exit;

  end;

  JHook := SetWindowsHookEx(WH_JOURNALRECORD, @JournalProc, hInstance, 0);

  {SetWindowsHookEx starts the Hook}

  if JHook > 0 then

  begin

    FHookStarted := True;

  end

  else

    ShowMessage('No Journal Hook availible');


end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FHookStarted := False;

  UnhookWindowsHookEx(JHook);

  JHook := 0;


end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  {make sure you unhook it if the app closes}

  if FHookStarted then

    UnhookWindowsHookEx(JHook);

end;


end.

Автор: Snowy 29.10.2018, 14:49

Цитата(blackkot32 @ 28.10.2018, 01:34

)

if HIWORD(WParam)-WHEEL_DELTA > 0 then s:='up' else s:='down'; //куда ни крути - здесь всё равно down

Потому что нужно не вычитать, а делить