VPF::Как отследить бездействие пользователя

zetxi815eb

Дата 22.3.2009, 12:39 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 95
Регистрация: 17.1.2007

Репутация: нет
Всего: нет

Нужна написать прогу, подобную той, которая запускает скринсейвер в Винде.

Т.е. Если пользователь не шевелит мышкой и клавиатурой в течении - 10 минут - то запускаем процедуру - будильник.

Только вот как и какими средствами это реализовать?..подскажите пожалуйста. Как отследить бездействие пользователя?

Alexeis

Дата 22.3.2009, 12:43 (ссылка)

(голосов:1)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

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

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

zetxi815eb

Дата 22.3.2009, 12:50 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 95
Регистрация: 17.1.2007

Репутация: нет
Всего: нет

Цитата(Alexeis @ 22.3.2009, 12:43)

это я понимаю... а в виде кода можно?
желательно с комментами...а то я новичек
smile

Dmi3ev

Дата 22.3.2009, 13:13 (ссылка)

(голосов:1)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1698
Регистрация: 28.11.2007

Репутация: нет
Всего: 41

Цитата

это я понимаю... а в виде кода можно?
желательно с комментами...а то я новичек

1) есть компонент ApplicationEvents
2) у него есть событие OnIdle, как раз оно и отвечает за бездействие...
3) код ты должен придумывать, а мы поможем, если что... smile

Так что давай...
а такие штуки, что дайте мне код, я новичок, да еще и с комментами (типа без комментов мне не надо) smile

тут не проканают, иначе в Центр помощи, там хныч... smile

--------------------

zetxi815eb

Дата 22.3.2009, 13:26 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 95
Регистрация: 17.1.2007

Репутация: нет
Всего: нет

Нашел такую библиотеку

Код


library AtomHook;



uses
  Windows,
  Messages;

const
  MAX_CLIENTS = 256;



type
  PHookData = ^THookData;
  THookData = record

    KeyboardHookHandle: HHOOK;

    MouseHookHandle: HHOOK;

    UsageCount: integer;

    ClientIndex: integer;

    Clients: array[0..MAX_CLIENTS-1] of HWND;

  end;



var

  MapFile: THandle;

  WM_INDICATORKEY: UINT;

  HookData: PHookData;





procedure MapFileMemory;

var

  ZeroMem: boolean;

begin

  MapFile := CreateFileMapping($FFFFFFFF, NIL, PAGE_READWRITE, 0,

     SizeOf(THookData), 'AtomHook Client List');

  if (MapFile = 0) then

  begin

    MessageBox(0, 'AtomHook DLL', 'Could not create file map object', MB_OK);

  end else begin

    ZeroMem := GetLastError <> ERROR_ALREADY_EXISTS;

    HookData := MapViewOfFile(MapFile, FILE_MAP_ALL_ACCESS, 0, 0,

       SizeOf(THookData));

    if (HookData = NIL) then

    begin

      CloseHandle(MapFile);

      MessageBox(0, 'AtomHook DLL', 'Could not map file', MB_OK);

    end else

      if ZeroMem then

        FillChar(HookData^, SizeOf(THookData), #0);

  end;

end;



procedure UnmapFileMemory;

begin

  if (HookData <> NIL) then

  begin

    UnMapViewOfFile(HookData);

    HookData := NIL;

  end;

  if (MapFile <> 0) then

  begin

    CloseHandle(MapFile);

    MapFile := 0;

  end;

end;



procedure AddClient(Wnd: HWND);

begin

  if (HookData <> NIL) then

  begin

    HookData^.Clients[HookData^.ClientIndex] := Wnd;

    inc(HookData^.ClientIndex);

  end;

end;



procedure RemoveClient(Wnd: HWND);

var

  x: integer;

begin

  if (HookData <> NIL) then

  begin

    for x := 0 to HookData^.ClientIndex-1 do

    begin

      if HookData^.Clients[x] = Wnd then

      begin

        if x < HookData^.ClientIndex-1 then

          Move(HookData^.Clients[x+1], HookData^.Clients[x],

             (HookData^.ClientIndex - x - 1) * SizeOf(HWND));

        dec(HookData^.ClientIndex);

        break;

      end;

    end;

  end;

end;







// Keyboard hook callback

function KeyboardHookCallBack(Code: integer; KeyCode: WPARAM; KeyInfo: LPARAM): LRESULT; stdcall;

var

  x: integer;

begin

  if (Code = HC_ACTION) and (HookData <> NIL) then begin

    for x := 0 to HookData^.ClientIndex-1 do

      PostMessage(HookData^.Clients[x], WM_INDICATORKEY, 0, 0);

  end;

  if Code < 0 then Result := CallNextHookEx(HookData^.KeyboardHookHandle, Code, KeyCode, KeyInfo)

              else Result := 0;

end;



// Mouse hook callback

function MouseHookCallBack(Code: integer; KeyCode: WPARAM; KeyInfo: LPARAM): LRESULT; stdcall;

var

  x: integer;

begin

  if (Code = HC_ACTION) and (HookData <> NIL)then begin

    for x := 0 to HookData^.ClientIndex-1 do

      PostMessage(HookData^.Clients[x], WM_INDICATORKEY, 1, 1);

  end;

  if Code < 0 then Result := CallNextHookEx(HookData^.MouseHookHandle, Code, KeyCode, KeyInfo)

              else Result := 0;

end;



// Utility routins for installing the windows hook for keypresses

function REGISTERHOOK(Handle: HWND): UINT; stdcall;

  function GetModuleHandleFromInstance: THandle;

  var

    s: array[0..512] of char;

  begin

    GetModuleFileName(hInstance, s, sizeof(s)-1);

    Result := GetModuleHandle(s);

  end;

begin

  if (HookData <> NIL) then

  begin

    if HookData^.KeyboardHookHandle = 0 then

      HookData^.KeyboardHookHandle := SetWindowsHookEx(WH_KEYBOARD,

         KeyboardHookCallBack, GetModuleHandleFromInstance, 0);

      HookData^.MouseHookHandle := SetWindowsHookEx(WH_MOUSE,

         MouseHookCallBack, GetModuleHandleFromInstance, 0);



    inc(HookData^.UsageCount);

    AddClient(Handle);



    Result := WM_INDICATORKEY;

  end else

    Result := 0;

end;



procedure DEREGISTERHOOK(Handle: HWND); stdcall;

begin

  if (HookData <> NIL) then

  begin

    dec(HookData^.UsageCount);

    RemoveClient(Handle);

    if HookData^.UsageCount < 1 then

    begin

      UnhookWindowsHookEx(HookData^.KeyboardHookHandle);

      UnhookWindowsHookEx(HookData^.MouseHookHandle);

      HookData^.KeyboardHookHandle := 0;

      HookData^.MouseHookHandle := 0;

    end;

  end;

end;



procedure LibraryProc(Reason: Integer);

begin

  case Reason of

    DLL_PROCESS_ATTACH:

    begin

      MapFile := 0;

      HookData := NIL;

      MapFileMemory;

    end;

    DLL_PROCESS_DETACH:

    begin

      UnmapFileMemory;

    end;

  end;

end;



exports

  REGISTERHOOK,

  DEREGISTERHOOK;





begin

  WM_INDICATORKEY := RegisterWindowMessage('AtomHook.WM_INDICATORKEY');

  DLLProc := @LibraryProc;

  LibraryProc(DLL_PROCESS_ATTACH);

end.

И пример использования

Код


var

  HookDLLHandle: THandle;

  RegisterHook: function (Handle: HWND): UINT; stdcall;

  DeregisterHook: procedure (Handle: HWND); stdcall;



TForm.OnCreate:

  HookDLLHandle := LoadLibrary('ATOMHOOK.DLL');

  if HookDLLHandle <> 0 then begin

    @RegisterHook := GetProcAddress(HookDLLHandle, 'REGISTERHOOK');

    @DeregisterHook := GetProcAddress(HookDLLHandle, 'DEREGISTERHOOK');

  end else begin

    @RegisterHook := nil;

    @DeregisterHook := nil;

  end;

  if AutoAwayTimer.Enabled and Assigned(@RegisterHook) then begin

    wm_Indicator := RegisterHook(Self.Handle);



TForm.WndProc(var Msg: TMessage);

  if Msg.Msg = wm_Indicator then begin

    // это значит, что юзверь где-то трогает клавиатуру или мышь (не обязательно в твоем приложнии)

  end;

Сейчас попробую попробую. Только вот не знаю как код библиотеки в dll файл превратить.

Dmi3ev

Дата 22.3.2009, 13:34 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1698
Регистрация: 28.11.2007

Репутация: нет
Всего: 41

Цитата

Нашел такую библиотеку

мне кажется, что лучше

Цитата

компонент ApplicationEvents

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

--------------------

MetalFan

Дата 22.3.2009, 16:36 (ссылка)

(голосов:3)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

народ, а не сильно ли усложняете?
GetLastInputInfo
пример пользования:

Код


//кидаем таймер. в OnTimer примерно такой код
procedure TForm1.TimerTimer(Sender: TObject);
var
  lLastInpInfo: TLastInputInfo;
begin
  ZeroMemory( @lLastInpInfo, SizeOf( lLastInpInfo ));
  lLastInpInfo.cbSize := SizeOf( lLastInpInfo );
  if GetLastInputInfo(lLastInpInfo) then
    Caption := IntToStr( GetTickCount - lLastInpInfo.dwTime );
end;

в кэпшн формы получаем кол-во мсек с последнего шевеления мышой или нажатии клавиш.

Добавлено через 7 минут и 37 секунд

Цитата(Dmi3ev @ 22.3.2009, 13:13

)

1) есть компонент ApplicationEvents
2) у него есть событие OnIdle, как раз оно и отвечает за бездействие...

а здесь под Idle имеется ввиду то, что бездействует приложение, а не пользователь ;)

Это сообщение отредактировал(а) MetalFan - 22.3.2009, 16:42

--------------------

There are always someone smarter than you...

Dmi3ev

Дата 22.3.2009, 16:53 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1698
Регистрация: 28.11.2007

Репутация: нет
Всего: 41

MetalFan, а я об этом даже не подумал! Точняк!

--------------------

MadCoder

Дата 22.3.2009, 16:55 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 478
Регистрация: 24.8.2007
Где: Москва

Репутация: 1
Всего: 2

Пишем функцию, которая определяет количество миллисекунд простоя:

Код


function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
  LInput.cbSize := SizeOf(TLastInputInfo);
  GetLastInputInfo(LInput);
  Result := GetTickCount - LInput.dwTime;
end;

И используем ее, например в Timer:

Код


// Проверяем время простоя
If Round(LastInput)>=600000 then
// Если больше 10 минут, ругаемся
ShowMessage('Работать, мля!')
// Иначе -ждем
else
exit;

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

--------------------

Домашняя страничка | Как скопировать настройки | Умный оптимизатор

MetalFan

Дата 22.3.2009, 17:23 (ссылка)

(нет голосов)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

MadCoder, ну просто разжевал и в рот положил)
но, кстати, заметил следующее: если спролить точпадом, то GetLastInputInfo не считает это действием пользователя smile

--------------------

There are always someone smarter than you...

MadCoder

Дата 22.3.2009, 17:27 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 478
Регистрация: 24.8.2007
Где: Москва

Репутация: 1
Всего: 2

Цитата(MetalFan @ 22.3.2009, 17:23)

Скопипастил из своего проекта на самом деле smile

.

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

--------------------

Домашняя страничка | Как скопировать настройки | Умный оптимизатор

zetxi815eb

Дата 23.3.2009, 12:38 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 95
Регистрация: 17.1.2007

Репутация: нет
Всего: нет

Цитата(MadCoder @ 22.3.2009, 16:55)

Пишем функцию, которая определяет количество миллисекунд простоя:

Код


function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
  LInput.cbSize := SizeOf(TLastInputInfo);
  GetLastInputInfo(LInput);
  Result := GetTickCount - LInput.dwTime;
end;

И используем ее, например в Timer:

Код


// Проверяем время простоя
If Round(LastInput)>=600000 then
// Если больше 10 минут, ругаемся
ShowMessage('Работать, мля!')
// Иначе -ждем
else
exit;

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

сделал вот так

Код


implementation

{$R *.dfm}
function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
  LInput.cbSize := SizeOf(TLastInputInfo);
  GetLastInputInfo(LInput);
  Result := GetTickCount - LInput.dwTime;
end;

procedure action;
var s:string;
begin
 If Round(LastInput)>=600000 then
    // Если больше 10 минут, ругаемся
    ShowMessage('Работать, мля!');
    // Иначе -ждем
end;

//При нажатии кнопки запускаем таймер
procedure TForm1.Button2Click(Sender: TObject);
var
   IE : OleVariant;
   s:string;
begin
  Timer1.Enabled:=true;
  Timer1.Interval:=900000;
  Timer1.OnTimer := action; // выдает ошибку [Error] Unit1.pas(58): Incompatible types: 'Parameter lists differ'
end;

end.

Но компилятор ругается
[Error] Unit1.pas(58): Incompatible types: 'Parameter lists differ'

Не пойму что именно ему надо

MadCoder

Дата 23.3.2009, 13:43 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 478
Регистрация: 24.8.2007
Где: Москва

Репутация: 1
Всего: 2

Так работает:

Код


function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
  LInput.cbSize := SizeOf(TLastInputInfo);
  GetLastInputInfo(LInput);
  Result := GetTickCount - LInput.dwTime;
end;

procedure TForm1.action(Sender: TObject);
var s:string;
begin
 If Round(LastInput)>=600000 then
    // Если больше 10 минут, ругаемся
    ShowMessage('Работать, мля!');
    // Иначе -ждем
end;

procedure TForm1.Button2Click(Sender: TObject);
var
   IE : OleVariant;
   s:string;
begin
  Timer1.Enabled:=true;
  Timer1.Interval:=900000;
  Timer1.OnTimer := action;
end;

--------------------

Домашняя страничка | Как скопировать настройки | Умный оптимизатор

MetalFan

Дата 23.3.2009, 13:59 (ссылка)

(нет голосов)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

Цитата(zetxi815eb @ 23.3.2009, 12:38

)

Timer1.OnTimer := action;

OnTimer = TNotifyEvent = procedure (Sender: TObject ) of object;
все верно. но не проще ли "создать" обработчик события OnTimer даблкликом на компонент таймера?

--------------------

There are always someone smarter than you...

zetxi815eb

Дата 24.3.2009, 13:36 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 95
Регистрация: 17.1.2007

Репутация: нет
Всего: нет

Всем огромное спасибо!!! smile

Все работает! smile

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »