cpkeyhook.pas

键盘钩子程序及控件, C++ Builder 和DELPHI可用

keyreps := 0;
FKeyboardLayoutHandle := GetKeyboardLayout(0);
GetKeyboardLayoutName(@KLayout);
FKeyboardLayout := KLayout;
end;

destructor TCPKeyHook.Destroy;
begin
TRY
if (FHookLibLoaded and FEnabled) then begin
   if FLowLevelHook then PFncHookStopLL
   else PFncHookStop;
   end;
FINALLY
UnloadHookLib;
DeallocateHWnd(FWindowHandle);
END;
inherited Destroy;
end;

procedure TCPKeyHook.WndProc(var Msg: TMessage);
begin
if Msg.Msg = FUserHookMsg then
     try
     HookMsg(Msg);
     except
     MessageDlg('Application Exception:'+#13+#10+'Unit TCPKeyHook : WndProc : HookMsg', mtError, [mbOK], 0);
     //Application.HandleException(Self);
     end
  else Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

procedure TCPKeyHook.HookMsg(var msg : TMessage);
begin
 Try
  if FLowLevelHook then ProcessHookMsgLL(msg)
  else ProcessHookMsg(msg);
 Finally
  Msg.Result := 1;
 end;
end;

procedure TCPKeyHook.ProcessHookMsg(AMsg: TMessage);
var
FKeyState: TKeyStates;
FKeyNames: TKeyNames;
VKeyName : array[0..100] of Char;
VCharBuf : array[0..2] of Char;
//VWideCharBuf : array[1..127] of WideChar;
KBS: TKeyboardState;
vkcode,scancode,charcode,retcode: integer;
//KLayoutHandle: HKL;
begin
  vkcode := AMsg.WParam; //Virtual KeyCode
  scancode := AMsg.LParam; //Keyboard ScanCode
  GetKeyboardState(KBS);

  FKeyState.KeyInfo.vkCode := vkcode;
  FKeyState.KeyInfo.scanCode := scancode;

  //WriteToLog('c:\temp\keyhook.log','Ascii: '+Char(Msg.WParam)+' wParam: '+inttostr(Msg.WParam)+' lParam: '+inttostr(Msg.LParam));
  fillchar(VCharBuf,SizeOf(VCharBuf),#0);
  //fillchar(VWideCharBuf,SizeOf(VCharBuf),#0);
  fillchar(VKeyName,SizeOf(VKeyName),#0);
  fillchar(FKeyNames.KeyChar,SizeOf(FKeyNames.KeyChar), #0);
  FKeyNames.KeyChar := #0;

  FKeyState.KeyDown := (scancode AND (1 shl 31)) = 0;
  FKeyState.KeyRepeated := (scancode AND (1 shl 30)) <> 0;
  FKeyState.AltDown := (scancode AND (1 shl 29)) <> 0;
  FKeyState.MenuKey := (scancode AND (1 shl 28)) <> 0;
  FKeyState.ExtendedKey := (scancode AND (1 shl 24)) <> 0;
  FKeyState.CtrlDown := (GetKeyState(VK_CONTROL) AND (1 shl 15)) <> 0;
  FKeyState.ShiftDown  := (GetKeyState(VK_SHIFT) AND (1 shl 15)) <> 0;
  if (FKeyState.KeyRepeated and FKeyState.KeyDown) then inc(keyreps)
  else keyreps := 0;
  FKeyState.RepeatCount := keyreps;
  GetKeyNameText(scancode,@VKeyName,SizeOf(VKeyName));
  move(VKeyName,FKeyNames.KeyExtName,SizeOf(VKeyName));

  //GetKeyboardLayoutName(@KLayout);
  //klh := LoadKeyboardLayout(@KLayout,KLF_ACTIVATE);
  //if klh = 0 then raise exception.Create('LoadKeyboardLAyout: '+inttostr(klh));
  //KLayoutHandle := GetKeyboardLayout(0);
  charcode := MapVirtualKeyEx(VKCode,2,FKeyboardLayoutHandle);
  FKeyState.DeadKey := (charcode AND (1 shl 31) <> 0);

  {Not sure which functions are best to call here for obtaining Ascii Character ??
   Calling ToAscii or ToAsciiEx seem to have strange effects on dead-key characters.
   Not sure if this is caused by a Bug in the function calls as these functions
   alter the state and actual key being pressed.}
  if FKeyState.DeadKey then retcode := ToASCIIEx(vkcode, scancode, KBS, @VCharBuf, 0, FKeyboardLayoutHandle);
  retcode := ToASCIIEx(vkcode, scancode, KBS, @VCharBuf, 0, FKeyboardLayoutHandle);
  {retcode := ToAscii(vkcode, scancode, KBS, @VCharBuf, 0);}
  {retcode := ToUnicodeEx(vkcode, scancode, @KBS, @VWideCharBuf, SizeOf(VWideCharBuf), 0, KLayoutHandle);}

  case retcode of
       0: FKeyNames.KeyChar := #0; //no Ascii character for given keycode
       1: FKeyNames.KeyChar := Char(VCharBuf[0]); //one character in buffer
       2: begin
          //MultiByteToWideChar(CP_ACP,MB_PRECOMPOSED,@VWideCharBuf,SizeOf(VWideCharBuf),@VCharBuf,SizeOf(VCharBuf));
          FKeyNames.KeyChar := Char(VCharBuf[0]); //two characters in buffer, 1 is deadkey
          end;
       else begin
            //SendNotifyMessage(GetActiveWindow,WM_DEADCHAR,vkcode,scancode);
            FKeyNames.KeyChar := Char(VCharBuf[0]); //deadkey in character buffer
            end;
       end;

  FKeyState.DeadKey := (retcode <= -1);
  FKeyState.DoubleKey := (retcode = 2);

  { InjectedKey is not supported in the standard WH_KEYBOARD Hook.
    To detect Injected Keys you must set LowLevelHook to True and use the LL Functions }
  FKeyState.InjectedKey := False;

  FKeyState.KeyInfo.flags := 0;
  FKeyState.KeyInfo.time := 0;
  FKeyState.KeyInfo.dwExtraInfo := 0;
  AMsg.Result := 1;
  if Assigned(FOnKey) then FOnKey(self,FKeyState,FKeyNames);
end;

procedure TCPKeyHook.ProcessHookMsgLL(AMsg: TMessage);
var
FKeyState: TKeyStates;
FKeyNames: TKeyNames;
VKeyName : array[0..100] of char;
VCharBuf : array[0..2] of Char;
KBS : TKeyboardState;
KeyHookStruct : PKbDllHookStruct;
ScanCode: Integer;
WasInjected: Boolean;
retcode,charcode: Integer;
KLayoutHandle: HKL;
begin
  KeyHookStruct := PFncHookGetDataLL;
  FKeyState.KeyInfo.vkCode := KeyHookStruct.vkCode;
  FKeyState.KeyInfo.scanCode := KeyHookStruct.scanCode;
  FKeyState.KeyInfo.flags := KeyHookStruct.flags;
  FKeyState.KeyInfo.time := KeyHookStruct.time;
  FKeyState.KeyInfo.dwExtraInfo := KeyHookStruct.dwExtraInfo;

  fillchar(VKeyName,SizeOf(VKeyName),#0);
  fillchar(VCharBuf,SizeOf(VCharBuf),#0);
  FKeyNames.KeyChar := #0;

  FKeyState.InjectedKey := (FKeyState.keyinfo.flags and LLKHF_INJECTED) <> 0;

  //FKeyState.KeyDown := (KeyHookStruct.flags AND LLKHF_UP);
  FKeyState.KeyDown := (Amsg.WParam = WM_KEYDOWN) or (Amsg.WParam = WM_SYSKEYDOWN);

  FKeyState.CtrlDown := bool(GetAsyncKeyState(VK_CONTROL) AND $00008000);
  //FKeyState.CtrlDown := ((GetKeyState(VK_CONTROL) and (1 shl 15)) <> 0);

  //FKeyState.ShiftDown  := bool(KeyHookStruct.vkCode AND VK_SHIFT);
  FKeyState.ShiftDown  := bool(GetAsyncKeyState(VK_SHIFT) AND $00008000);

  //FKeyState.AltDown := bool(KeyHookStruct.flags AND LLKHF_ALTDOWN);
  FKeyState.AltDown := bool(GetAsyncKeyState(VK_MENU) AND $00008000);

  FKeyState.MenuKey := False; //bool(GetAsyncKeyState(VK_EXECUTE) AND $00008000);
  FKeyState.ExtendedKey := bool(KeyHookStruct.flags AND LLKHF_EXTENDED);

  //FKeyState.KeyRepeated := (msg.lParam AND (1 shl 30)) <> 0;
  FKeyState.KeyRepeated := FKeyState.KeyDown;
  if (FKeyState.KeyRepeated and FKeyState.KeyDown) then inc(keyreps)
  else keyreps := 0;
  FKeyState.RepeatCount := keyreps;

  //KLayoutHandle := GetKeyboardLayout(0);
  charcode := MapVirtualKeyEx(FKeyState.KeyInfo.vkCode,2,FKeyboardLayoutHandle);
  FKeyState.DeadKey := (charcode AND (1 shl 31) <> 0);

  ScanCode := MapVirtualKey(FKeyState.KeyInfo.vkCode, 0) shl 16;
  if FKeyState.ExtendedKey then ScanCode := ScanCode or $01000000;
  GetKeyNameText(ScanCode ,@VKeyName,SizeOf(VKeyName));
  move(VKeyName,FKeyNames.KeyExtName,SizeOf(VKeyName));

  GetKeyboardState(KBS);
  //if FKeyState.ShiftDown then KBS[16] := 129;
  //if FKeyState.ShiftDown then KBS[VK_SHIFT] := 1;
  if GetKeyState(VK_CAPITAL) = 1 then KBS[VK_SHIFT] := 1;
  //GetKeyState(VK_CAPITAL) and 1 = 1) then KBS[VK_SHIFT] := 129;
  //if bool(GetAsyncKeyState(VK_CAPITAL) AND $00008000) then KBS[VK_SHIFT] := 129;
  
  {Not sure which functions are best to call here for obtaining Ascii Character ??
   Calling ToAscii or ToAsciiEx seem to have strange effects on dead-key characters.
   Not sure if this is caused by a Bug in the function calls as these functions
   alter the state and actual key being pressed.}
  if FKeyState.DeadKey then retcode := ToASCIIEx(FKeyState.KeyInfo.vkCode, ScanCode, KBS, @VCharBuf, ord(FKeyState.MenuKey),FKeyboardLayoutHandle);
  retcode := ToASCIIEx(FKeyState.KeyInfo.vkCode, ScanCode, KBS, @VCharBuf, ord(FKeyState.MenuKey),FKeyboardLayoutHandle);
  {retcode := ToAscii(vkcode, scancode, KBS, @VCharBuf, 0);}
  {retcode := ToUnicodeEx(vkcode, scancode, @KBS, @VWideCharBuf, SizeOf(VWideCharBuf), 0, KLayoutHandle);}

  case retcode of
       0: FKeyNames.KeyChar := #0; //no Ascii character for given keycode
       1: FKeyNames.KeyChar := Char(VCharBuf[0]); //one character in buffer
       2: begin
          //MultiByteToWideChar(CP_ACP,MB_PRECOMPOSED,@VWideCharBuf,SizeOf(VWideCharBuf),@VCharBuf,SizeOf(VCharBuf));
          FKeyNames.KeyChar := Char(VCharBuf[0]); //two characters in buffer, 1 is deadkey
          end;
       else begin
            //SendNotifyMessage(GetActiveWindow,WM_DEADCHAR,vkcode,scancode);
            FKeyNames.KeyChar := Char(VCharBuf[0]); //deadkey in character buffer
            end;
       end;

  FKeyState.DeadKey := (retcode <= -1);
  FKeyState.DoubleKey := (retcode = 2);

  AMsg.Result := 1;
  if Assigned(FOnKey) then FOnKey(self,FKeyState,FKeyNames);
end;


function TCPKeyHook.Start_KeyHook: Boolean;
begin
Result := False;
if FEnabled then exit;
if Not LoadHookLib then exit;
if FLowLevelHook then FEnabled := PFncHookStartLL(FLicenceCode,FWindowHandle,FUserHookMsg, FDisableKeyboard, FHookInjected)
else FEnabled := PFncHookStart(FLicenceCode,FWindowHandle,FUserHookMsg, FDisableKeyboard);
Result := FEnabled;
end;

function TCPKeyHook.Stop_KeyHook: Boolean;
begin
Result := False;
Try
if FEnabled then begin
   if FLowLevelHook then Result := PFncHookStopLL
   else Result := PFncHookStop;
   end;
FEnabled := False;
Finally
UnloadHookLib;
End;
end;

function TCPKeyHook.UpdateHook: boolean;
begin
Result := False;
if FEnabled then begin
   if FLowLevelHook then Result := PFncHookUpdateHookLL(FDisableKeyboard,FHookInjected)
   else Result := PFncHookUpdateHook(FDisableKeyboard);
   end;
end;

function TCPKeyHook.LoadHookLib: boolean;
begin
result := false;
if FHookLibLoaded then exit;
DllHandle := LoadLibrary(PChar(HOOKLIBNAME));
if DllHandle <> 0 then
   begin
   { Get pointers to DLL Hook Functions }
   PFncHookStart := GetProcAddress(DllHandle, 'KeyboardHook_Start');
   PFncHookStop := GetProcAddress(DllHandle, 'KeyboardHook_Stop');
   PFncHookUpdateHook := GetProcAddress(DllHandle, 'KeyboardHook_UpdateHook');
   PFncHookStartLL := GetProcAddress(DllHandle, 'KeyboardHook_StartLL');
   PFncHookStopLL := GetProcAddress(DllHandle, 'KeyboardHook_StopLL');
   PFncHookUpdateHookLL := GetProcAddress(DllHandle, 'KeyboardHook_UpdateHookLL');
   PFncHookGetDataLL := GetProcAddress(DllHandle, 'KeyboardHook_GetDataLL');
   { Check DLL function pointers are valid }
   if CheckDLLFncPtrs then begin
      FHookLibLoaded := True;
      result := true;
      end else FreeLibrary(DllHandle);
   end;
end;

function TCPKeyHook.CheckDLLFncPtrs: boolean;
begin
Result := False;
if Assigned(PFncHookStart) and Assigned(PFncHookStop) and Assigned(PFncHookUpdateHook) and
   Assigned(PFncHookStartLL) and Assigned(PFncHookStopLL) and Assigned(PFncHookUpdateHookLL) and Assigned(PFncHookGetDataLL)
   then Result := True;
end;

function TCPKeyHook.UnloadHookLib: boolean;
begin
result := false;
if DllHandle <> 0 then
   begin
   FreeLibrary(DllHandle);
   FHookLibLoaded := false;
   result := true;
   end;
End;

initialization

finalization
 if DllHandle <> 0 then FreeLibrary(DllHandle);

end.