Консультация № 116709
03.01.2008, 10:50
0.00 руб.
0 2 2
Доброго времени суток! Будьте добры, киньтесь примером кода на Дельфи, позволяющим определить активность пользователя, т.е. как это сделано в скринсейвере, если скажем 30 сек нет перемещения мыши или нажатия клавиш - то вызвать какое-либо событие.

Обсуждение

Неизвестный
03.01.2008, 11:03
общий
это ответ
Здравствуйте, Remnew Anatoliy!

Вам, скорее всего, необходим hook, т.е. "ловушки" на события системы.

Попробуйте использовать Hook-функции:
CallMsgFilter
CallNextHookEx
CallWndProc
CallWndRetProc
CBTProc
DebugProc
ForegroundIdleProc
GetMsgProc
JournalPlaybackProc
JournalRecordProc
KeyboardProc
MessageProc
MouseProc
SetWindowsHookEx
ShellProc
SysMsgProc
UnhookWindowsHookEx

есть еще пример кода (программа Sendkeys). Код не мой и не проверен, найден когда-то в интернете.

Приложение:
program Project1;uses Forms, Unit1 in ‘..\Hooks1\Unit1.pas‘ {Form1};{$R *.RES}begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run;end.// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //library SendKey;uses SysUtils, Classes, Windows, Messages;const {пользовательские сообщения} wm_LeftShow_Event = wm_User + 133; wm_RightShow_Event = wm_User + 134; wm_UpShow_Event = wm_User + 135; wm_DownShow_Event = wm_User + 136; {handle для ловушки} HookHandle: hHook = 0;var SaveExitProc: Pointer; {собственно ловушка}function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; stdcall; export;var H: HWND;begin {если Code>=0, то ловушка может обработать событие} if (Code >= 0) and (lParam and $40000000 = 0) then begin {ищем окно по имени класса и по заголовку (Caption формы управляющей программы должен быть равен ‘XXX‘ !!!!)} H := FindWindow(‘TForm1‘, ‘XXX‘); {это те клавиши?} case wParam of VK_Left: SendMessage(H, wm_LeftShow_Event, 0, 0); VK_Right: SendMessage(H, wm_RightShow_Event, 0, 0); VK_Up: SendMessage(H, wm_UpShow_Event, 0, 0); VK_Down: SendMessage(H, wm_DownShow_Event, 0, 0); end; {если 0, то система должна дальше обработать это событие} {если 1 - нет} Result := 0; end else if Code < 0 {если Code<0, то нужно вызвать следующую ловушку} then Result := CallNextHookEx(HookHandle, Code, wParam, lParam);end;{при выгрузке DLL надо снять ловушку}procedure LocalExitProc; far;begin if HookHandle <> 0 then begin UnhookWindowsHookEx(HookHandle); ExitProc := SaveExitProc; end;end;exports Key_Hook;{инициализация DLL при загрузке ее в память}begin {устанавливаем ловушку} HookHandle := SetWindowsHookEx(wh_Keyboard, @Key_Hook, hInstance, 0); if HookHandle = 0 then MessageBox(0, ‘Unable to set hook!‘, ‘Error‘, mb_Ok) else begin SaveExitProc := ExitProc; ExitProc := @LocalExitProc; end;end.// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //object Form1: TForm1 Left = 200 Top = 104 Width = 544 Height = 375 Caption = ‘XXX‘ Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = ‘MS Sans Serif‘ Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 128 Top = 68 Width = 32 Height = 13 Caption = ‘Label1‘ endend// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //unit Unit1;interfaceuses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;{пользовательские сообщения}const wm_LeftShow_Event = wm_User + 133; wm_RightShow_Event = wm_User + 134; wm_UpShow_Event = wm_User + 135; wm_DownShow_Event = wm_User + 136;type TForm1 = class(TForm) Label1: TLabel; procedure FormCreate(Sender: TObject); private //Обработчики сообщений procedure WM_LeftMSG(var M: TMessage); message wm_LeftShow_Event; procedure WM_RightMSG(var M: TMessage); message wm_RightShow_Event; procedure WM_UpMSG(var M: TMessage); message wm_UpShow_Event; procedure WM_DownMSG(var M: TMessage); message wm_DownShow_Event; end;var Form1: TForm1; P: Pointer;implementation{$R *.DFM}//Загрузка DLLfunction Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; stdcall; external ‘SendKey‘ name ‘Key_Hook‘;procedure TForm1.WM_LefttMSG(var M: TMessage);begin Label1.Caption := ‘Left‘;end;procedure TForm1.WM_RightMSG(var M: TMessage);begin Label1.Caption := ‘Right‘;end;procedure TForm1.WM_UptMSG(var M: TMessage);begin Label1.Caption := ‘Up‘;end;procedure TForm1.WM_DownMSG(var M: TMessage);begin Label1.Caption := ‘Down‘;end;procedure TForm1.FormCreate(Sender: TObject);begin {если не использовать вызов процедуры из DLL в программе, то компилятор удалит загрузку DLL из программы} P := @Key_Hook;end;end.
Неизвестный
03.01.2008, 11:13
общий
это ответ
Здравствуйте, Remnew Anatoliy!
можно по таймеру проверять активность пользователя с пом. ф-ции GetLastInputInfo - см. пример в приложении

Приложение:
procedure TfmMain.Timer1Timer(Sender: TObject);var LII:TLastInputInfo;begin try FillChar(LII,SizeOf(LII),0); LII.cbSize:=SizeOf(LII); GetLastInputInfo(LII); if GetTickCount-LII.dwTime<1000 then begin // пользователь активен. // тут можно выставлять флаг активности // или инициировать некое событие ... end; except end;end;
Форма ответа