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

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

Форум программистов > Delphi: Общие вопросы > Делаю ловушку на клаву

Автор: Budy 20.4.2005, 08:58

:Приветсвую
Делаю ловушку на клавиатуру. Использую Hook, использую DLL. Все норм работает, но есть проблема - при запуске проги все тормозит. TaskMan 100%ую загрузку ЦП показывает.
Видать получился глобальный Хук, а хотелось чтоб не тормозило. Помогите плз

Автор: Akella 20.4.2005, 09:48

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

Автор: Bes 20.4.2005, 12:50

Можно использовать getkeystate тогда и без дллки обойтись можно.

Автор: RA 20.4.2005, 15:32

Budy Покажи код.

Автор: Budy 20.4.2005, 17:21

Прога, запускающая DLL'ку:

Код


procedure StartHOOK; stdcall; external 'getkeys.dll' index 1;
begin
  StartHOOK;
  repeat until false;
end.

Прога в памяти весит, всего около 300 Кб имеет.
А вот DLL'ка:

Код


library getkeys;
uses windows;
type
   ca=array[0..255] of Char;
var
  HookHandle: hHook = 0;
  hook:hHook=0;
  Last_Key: String;

//Из заглавных в строчные
function DownKey(key: char): char;
begin
...
end;

//По клавиатуре с англ на русс
function lat_to_rus(key: char):char;
begin
...
end;

//Сохраняем полученную клавишу
procedure AddKey(Key: String);
begin
...
end;

function gethook(code: integer; wParam, lParam: longint): longword; StdCall;
var
  Key_Name: Char_array;
  WhatLan: Array[0..$FFF] of Char;
  CapsLock, Russian: Boolean;
  ResKey: Char;
  Key: String;
begin
  if Code<0 then begin
    Result:=CallNextHookEx(HK,Code,wParam,lParam);
    Exit;
  end;
  if(Code=HC_ACTION)and(((lParam shr 16) and KF_UP)=0)then
    begin
      CapsLock:=(GetKeyState(VK_CAPITAL) and $01)<>0;
      if GetKeyboardLayoutName(WhatLan)then if WhatLan='00000419' then Russian:=True else Russian:=False;
      GetKeyNameText(lParam, Key_Name, sizeof(Key_Name));
      Key:=Key_Name;
//Если буква или цифра (1 символ)
      if Length(Key)=1 then
        begin
          case Key[1] of
            '1'..'9','0':ResKey:=Key[1];
            'A'..'Z':begin
                      if Russian then ResKey:=lat_to_rus(Key[1])else ResKey:=Key[1];
                      if CapsLock=False then ResKey:=DownKey(ResKey);
                     end;
            else ResKey:=Key[1];
          end;
          Key:='';
        end else
          begin
            if Key='Space' then Key:=' ' else
            if Key='Page Up' then Key:=' [PUp] ' else
            if Key='Page Down' then Key:=' [PDown] ' else
            if Key='Right Shift' then Key:=' [RShift] ' else
            if Key='Right Alt' then Key:=' [RAlt] ' else
            if Key='Right Ctrl' then Key:=' [RCtrl] ' else
            if Key='Insert' then Key:=' [Ins] ' else
            if Key='Delete' then Key:=' [Del] ' else
            if Pos('Num ',Key)>0 then Key:=' [N'+Copy(Key,5,Length(Key)-4)+'] ' else
            Key:=' ['+Key+'] ';
          end;
      if Key='' then Key:=ResKey;
      if(Last_Key<>Key)or(Length(Key)=1) then AddKey(Key);
      if(Pos('Ctrl',Key)>0)or(Pos('Alt',Key)>0)or(Pos('Shift',Key)>0)then Last_Key:=Key else Last_Key:='';
    end;
  CallNextHookEx(HK,Code,wParam,lParam);
  Result:=0;
end;

procedure StartHOOK; StdCall;
begin
  hook:=SetWindowsHookEx(WH_KEYBOARD,@gethook,hInstance,0);
end;

exports
  StartHOOK;

end.

PS.В коде (здесь строки 75-76) пробовал писать Result:=CallNewxt...... Тогда клавиши не возращаются нужным приложениям.

Bes, расскажи поподробнее. Просто пробовал в EXE'шник пихнуть - когда на клаве щелкаешь кнопки при других окнах, они закрываются.

Автор: RA 20.4.2005, 17:28

Убери repeat until false;

Автор: Budy 20.4.2005, 19:20

RAdmin, дык тогда ничего работать и не будет

Автор: RA 20.4.2005, 20:15

Ты пробовал?

Автор: RA 20.4.2005, 20:48

То верхнее это моя оценка на вскидку.

А вот специально решил
посмотреть что к чему:

Почему в CallNextHookEx(HK,Code,wParam,lParam); переменная "HK"
а тут
hook:=SetWindowsHookEx(WH_KEYBOARD,@gethook,hInstance,0); hook ?

Они хоть потом связываются или как?
Я заменил HK на Hook.

Загузчик ......

implementation
function StartHOOK: Longint; external 'getkeys.dll' name 'StartHOOK';
{$R *.dfm}

procedure .....
begin
StartHOOK;
end;

И всё работает пучком.

ЗЫ: так как код процедуры "AddKey" ты не показал то я туда вставил бональный ShowMessage. (для теста)

Автор: Budy 21.4.2005, 14:43

RAdmin, я с "HK" и "hook" перепутал, короче это одна и та же переменная, иначе "hook: HHOOK;"
AddKey - здесь я сохраняю клавиши в оперативную память, пробовал в файл сохранять - возникают проблемы из за загрузки ЦП.
Добавлено @ 14:45

Цитата(RAdmin @ 20.4.2005, 20:28)

Убери repeat until false;

Цитата(RAdmin @ 20.4.2005, 23:15)

Ты пробовал?

Дак прога тогда закрывается.

Автор: Budy 21.4.2005, 15:23

Цитата(RAdmin @ 20.4.2005, 23:48)

И всё работает пучком

Работать то работает, да вот память сильно грузит :\

Автор: RA 21.4.2005, 15:52

Budy Ну не знаю, то что я проверял работало без напрягов.
Пришли мне на мыло весь исходник, или тут выложи (только в аттаче).
exxxxx [a] gmail.com

Автор: Budy 21.4.2005, 18:52

RAdmin, дак я весь и выложил. Есть прога (там всего 5 строчек), которая запускает DLL и держит его в памяти. DLL в свою очередь ставит ловушку, и проверяет на нажатие клавиш на клавиатуре. Три процедуры, что я не расписывал не представляют из себя ничего серьезного - у все сводил к минимуму, просто получал Key_Name (GetKeyNameText(lParam, Key_Name, sizeof(Key_Name));) и записывал в файл. Всеравно всю память использует.
Может ловушка "слишком много на себя берет"?

Автор: Budy 21.4.2005, 20:55

Цитата(Budy @ 21.4.2005, 17:43)

Цитата (RAdmin @ 20.4.2005, 20:28)
Убери repeat until false;
Цитата (RAdmin @ 20.4.2005, 23:15)
Ты пробовал?
Дак прога тогда закрывается.

Ага, в этом все и дело. Я переделал запускающую прогу чтоб без зацикливания была, все встало на место

Добавлено @ 20:57
А я себе в голову вбил, что ето все DLL'ька виновата smile

Автор: RA 22.4.2005, 15:44

ну вот и замечательно smile

Автор: Budy 25.4.2005, 06:25

А как мона сделать чтоб DLL передавала какието параметры вызвающей программе?
Ну например в этом случае, DLL получила клавишу и нужно ее передать программе..

Автор: RA 25.4.2005, 14:01

Вот есть хороший пример:

Автор: vintch 25.4.2005, 14:31

Цитата

repeat until false;

Это в Win-проге использовать просто нельзя! smile

Нужно:

Код


program Project1;

uses
  Windows, Messages;

var Msg: TMsg;

procedure Timer; stdcall;
begin
   MessageBox(0, 'Работаем!', 'Сообщение :)', MB_ICONINFORMATION);
end;

begin
   SetTimer(0, 0, 3000, @Timer);
   while GetMessage(Msg,0,0,0) do
    begin
       TranslateMessage(Msg);
       DispatchMessage(Msg);
    end;
end.

PS. SetTimer и всё что с ним связано - чисто для показухи smile

Автор: Budy 25.4.2005, 14:51

vintch, ага, я уже понял smile

Просто я между делом делал маленькую запускающую прогруамму

Автор: Dr.No_xXx 25.4.2005, 15:03

Цитата

Зачем? и какие именно?

Автор: Budy 25.4.2005, 16:36

RAdmin, я мона полегче примерчик? Я шото там запутался smile

Dr.No_xXx, посмотри эту тему. Я кидал код, там процедуре "procedure AddKey(Key: String);" я передаю полученную нажатую клавишу. Дак вот спрашиваю, как эту "Key: String" - клавишу передать в главную прогу?

Автор: Rouse_ 26.4.2005, 08:33

Цитата(Budy @ 25.4.2005, 16:36)

RAdmin, я мона полегче примерчик? Я шото там запутался

Ты работаешь под NT? Если так то не нужны никакие лишние DLL. Вот смотри примерчик:

Код


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

var
  hHook: THandle;

{$R *.dfm}

function LowLevelKeyboardProc(nCode: Integer;
  WParam: WPARAM; LParam: LPARAM): LRESULT stdcall;
type
  PKbdDllHookStrukt = ^TKbdDllHookStrukt;
  _KBDLLHOOKSTRUCT = record
    vkCode: DWORD;
    scanCode: DWORD;
    flags: DWORD;
    time: DWORD;
    dwExtraInfo: PDWORD;
  end;
  TKbdDllHookStrukt = _KBDLLHOOKSTRUCT;

const
  RPT_WPARAM_DATA = 'Keyboard message = %s ';
  RPT_LPARAM_DATA = 'scan code = %s [%d]';
var
  StrResult: String;
begin
  StrResult := '';
  if nCode = HC_ACTION then
    Result := CallNextHookEx(hHook, nCode, WParam, LParam);
  case WParam of
    WM_KEYDOWN: StrResult := Format(RPT_WPARAM_DATA, ['WM_KEYDOWN']);
    WM_KEYUP: StrResult := Format(RPT_WPARAM_DATA, ['WM_KEYUP']);
    WM_SYSKEYDOWN: StrResult := Format(RPT_WPARAM_DATA, ['WM_SYSKEYDOWN']);
    WM_SYSKEYUP: StrResult := Format(RPT_WPARAM_DATA, ['WM_SYSKEYUP']);
  end;

  StrResult := StrResult + Format(RPT_LPARAM_DATA, [
    Chr(PKbdDllHookStrukt(LParam)^.vkCode), PKbdDllHookStrukt(LParam)^.vkCode]);
  Form1.Memo1.Lines.Add(StrResult);
end;

procedure TForm1.FormCreate(Sender: TObject);
const
  WH_KEYBOARD_LL = 13;
begin
  hHook := SetWindowsHookEx(WH_KEYBOARD_LL, LowLevelKeyboardProc, hInstance, 0);
  if hHook = 0 then RaiseLastOSError;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if not UnhookWindowsHookEx(hHook) then RaiseLastOSError;
end;

end.

Автор: vintch 26.4.2005, 13:34

Да, признаться, давно я на MSDN небыл smile

Rouse, ещё новичком себя называет smile

PS. А можно ещё так: не repeat until false; а repeat sleep(10) until false; smile

И проц не на сотню smile

Автор: Rouse_ 26.4.2005, 15:29

Цитата(vintch @ 26.4.2005, 13:34)

А можно ещё так: не repeat until false; а repeat sleep(10) until false; И проц не на сотню

Ну можно и application.HandleMessage или ее аналог написать. Самый ненапряжный вариант smile

Автор: Rouse_ 26.4.2005, 20:03

Ну чтож, давайте теперь разберем ошибки.

dsergey:
Папка D6Hook1 файл hook.pas
смотрим код:

Код


function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;

Теперь вопрос. С каких пор WParam поменяло значение с двойного слова на одинарное? Правильней будет Longint(DWORD, Cardinal) но никак не word. Самое правильное - специально определенный тип для всех hook procedures объявленный в модуле Windows.pas под названием WPARAM;
Собстенно вот все используемые типы:

Код


type
  WPARAM = Longint;
  {$EXTERNALSYM WPARAM}
  LPARAM = Longint;
  {$EXTERNALSYM LPARAM}
  LRESULT = Longint;
  {$EXTERNALSYM LRESULT}

Исследуем далее код функции function HookProc того же модуля

Код


  if Code >= 0 then begin
    ...
  end else
    result := CallNextHookEx(HookHandle, code, WParam, LParam);

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

Ну и естестенно довольно странно видеть проверку при уничтожении хука:

Код


procedure TfmMain.FormDestroy(Sender: TObject);
begin
  if HookHandle > 0 then
    UnhookWindowsHookEx(HookHandle);
end;

...при ее полном отсутствии на момент создания:

Код


procedure TfmMain.FormCreate(Sender: TObject);
begin
...
  HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
...
end;

Папка D6Hook2DLL, модуль keyboardhook.dpr:
смотрим код:

Код


procedure DLLEntryPoint(dwReason: DWord); stdcall;

В данном случае из-за объявления stdcall, абсолютно здесь не уместного никогда в жизни не отработает сообщение DLL_PROCESS_DETACH

Далее абсолютно не понятен двойной вызов следующей функции на момент инициализации библиотеки.

Код


WM_MYKEYHOOK:=RegisterWindowMessage('WM_MYKEYHOOK');

Папка D6Hooks модуль HookDll.pas
Та же ошибка с word, ну и явно безграмотное написание библиотеки с разбитием цепочки хуков, так как автор видимо забывает что все экземпляры библиотеки разнесены по различным адресным пространствам приложений и не потрудился создать единые экземпляры констант чере отображаемые в память процесса файлы.
Предыдужий пример был написан намного лучше.

Примеры в архивах даже не хочется комментировать.

По поводу примера от RAdmin.
Ну это немного не из той серии, но очень грамотно написаный пример...

Мой пост собственно не указание на ошибки, а указание на возможные неприятности при бездумном использовании кода...

Автор: RA 26.4.2005, 20:54

Цитата(Rouse_ @ 26.4.2005, 20:03)

Ну это немного не из той серии, но очень грамотно написаный пример...

Дык человек вопрос задал :

Цитата(Budy @ 25.4.2005, 06:25)

Естесно потом возникнет вопрос а как текст передать. и тд.

А что касатется хука на клаву то мой пример уже давно пылится в кладовке.
(тотже принцип что и у тебя, толкьо с перламутровыми пуговицами )

Автор: Budy 27.4.2005, 10:33

RAdmin, Rouse_, пасибо, ребята! Оба помогли, у обоих код позаимствовал smile

Еще раз спасибо

Автор: Denis-delphist 27.4.2005, 18:28

Уменьшь её на сколько можно и пусть результат не в прогу пишется, а в LOG файл, не указывая время(Только беквы и цифры). Ещё можно эту штуку коммандной строкой сделать!!! Также можно сделать так, чтобы не все буквы запоминались, а некоторые. smile