Форум: "Система";
Текущий архив: 2002.02.04;
Скачать: [xml.tar.bz2];

Вниз

Проблема с Hook !!!!!!!   Найти похожие ветки 

← →
PavelS   (2001-10-18 10:48) [0]

Есть клиент и сервер.
Посылаю на клиент команду установить хук на клавиатуру (у меня это процедура HookOn), но хук почему-то не ставится. Еще если например добавить в обработчик хука вывод showmessage, то он начинает работать пока не закрыт showmessage.

Если же я в клиенте например кнопке на событие клик ставлю HookOn - то срабатывает.

Использую компоненты Indy.

---

← →
Виктор Щербаков   (2001-10-18 11:44) [1]

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

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

Для полной ясности всё равно исходник нужен.

---

← →
PavelS   (2001-10-18 13:22) [2]

Немного уточну - мне необходимо клавиатуру блокировать. Пробовал вместо хука использовать BlockInput – тоже самое – при посылке от клиента (на другом компе) к серверу блокирования клавиатуры не происходит.
Вот исходники клиента, сервера и библиотеки

Бибилиотека: hook.dpr


library Project1;
uses Windows,
Messages;
var
HookDeTeclado:HHook;

function CallBackDelHook(Code:Integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;
begin
beep(100,100);
Result:=1;
//CallNextHookEx(HookDeTeclado, Code, wParam, lParam)
end;

procedure HookOn;stdcall;
begin
HookDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelHook, HInstance , 0);
end;

procedure HookOff; stdcall;
begin
UnhookWindowsHookEx(HookDeTeclado);
end;
exports
HookOn,
HookOff;
begin
end.


Сервер: Server.dpr


program Server;
uses
Forms,
ServerMain in "ServerMain.pas" {frmServer};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TfrmServer, frmServer);
Application.Run;
end.


ServerMain.pas:


unit ServerMain;
interface
uses
SysUtils,Classes,forms,windows,IdBaseComponent,IdComponent,IdTCPServer;
const
HookDLL="hook.dll";
type
THookKeyboard=procedure;stdcall;
type
TfrmServer = class(TForm)
TCPServer: TIdTCPServer;
procedure FormCreate(Sender: TObject);
procedure TCPServerExecute(AThread: TIdPeerThread);
procedure FormDestroy(Sender: TObject);
private
HandleDLL:THandle;
HookOn,HookOff:THookKeyboard;
public
end;
var
frmServer:TfrmServer;

implementation
{$R *.dfm}

procedure TfrmServer.FormCreate(Sender: TObject);
begin
HandleDLL:=LoadLibrary(PChar(ExtractFilePath(Application.Exename)+HookDLL ) );
if HandleDLL = 0 then raise Exception.Create("NO DLL");
@HookOn :=GetProcAddress(HandleDLL, "HookOn");
@HookOff:=GetProcAddress(HandleDLL, "HookOff");

IF not assigned(HookOn) or not assigned(HookOff) then
raise Exception.Create("Cannot find the required DLL functions");
TCPServer.Active := True;
end;

procedure TfrmServer.TCPServerExecute(AThread: TIdPeerThread);
var s:string;
begin
with AThread.Connection do
begin
s:=ReadLn;
if s="Стоп" then
begin
hookon;
end;
if s="Старт" then
begin
hookoff;
end;
Disconnect;
end;
end;

procedure TfrmServer.FormDestroy(Sender: TObject);
begin
hookoff;
if HandleDLL<>0 then FreeLibrary(HandleDLL);
end;
end.


ServerMain.dfm


object frmServer: TfrmServer
Left = 359
Top = 227
BorderStyle = bsSingle
Caption = "RemoteServer"
ClientHeight = 98
ClientWidth = 205
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = "MS Sans Serif"
Font.Style = []
FormStyle = fsStayOnTop
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object TCPServer: TIdTCPServer
Bindings = <>
DefaultPort = 9999
OnExecute = TCPServerExecute
Left = 16
Top = 8
end
end


Клиент: client.dpr


program Client;
uses
Forms,
Unit1 in "Unit1.pas" {Form1};
{$R *.res}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.


Unit1.pas


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient;

type
TForm1 = class(TForm)
TCPClient: TIdTCPClient;
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
end;

var
Form1: TForm1;
implementation
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
TCPClient.Host:=Edit1.Text;
with TCPClient do
begin
try
Connect;
try
TCPClient.WriteLn("Стоп");
finally
Disconnect;
end;
except
ShowMessage("Компьютер не доступен или неверно введен адрес");
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TCPClient.Host:=Edit1.Text;
with TCPClient do
begin
try
Connect;
try
TCPClient.WriteLn("Старт");
finally
Disconnect;
end;
except
ShowMessage("Компьютер не доступен или неверно введен адрес");
end;
end;
end;
end.


Unit1.dfm – создайте сами, а то сообщение слишком большое

---

← →
Knight   (2001-10-18 17:18) [3]

Спасибо, пригодится!

---

← →
PavelS   (2001-10-19 16:00) [4]

ПОМОГИТЕ ПЛЗ !!!

Если я напрямую(например при щелчке на кнопку) из программы сервера ставлю хук, то все ОК. а если программа сама ставит (послаю команду на установку), то ничего не происходит. ХОТЯ процедура установки одна и таже

---

← →
PavelS   (2001-10-23 19:33) [5]

HELP !!

---

Страницы: 1 вся ветка

Форум: "Система";
Текущий архив: 2002.02.04;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.47 MB
Время: 0.005 c