umain.pas

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

{*****************************************************************************
 * Purpose:   Predictive Text Demo using TCPKeyHook DLL
 * Developer: BITLOGIC Software
 * Email:     [e-mail]
 * WebPage:   http://www.bitlogic.co.uk
 *****************************************************************************}

{*****************************************************************************
  This Demonstration requires the latest version of TCPKeyHook Component/DLL
  which can be downloaded from the website above.

  The purpose of this demonstration project is to show how the keyboard hook
  dll functions could be used for a predictive text or spelling application.

  Each key is buffered and when a terminating key such as Enter, Space or Tab
  is detected the character buffer will contain a word which can then be
  processed as required.
*****************************************************************************}

unit UMain;

interface

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

const
  KEYHOOKLIBNAME = 'keyhook.dll';  //Name of the Keyboard Hook DLL
  WM_KEYHOOKMSG = WM_USER + 100;   //Event Msg for Keyboard Hook
  KEYBUFSIZE = 232;                //Keyboard Character Buffer Size
  KEY_BACKSPACE = '[BACKSPACE]';
  KEY_TAB = '[TAB]';
  KEY_ENTER = '[ENTER]';
  KEY_SPACE = '[SPACE]';

type
TKeyStates = packed record
  KeyTickMsg : Boolean;
  KeyDown : Boolean;
  ShiftDown: Boolean;
  AltDown: Boolean;
  CtrlDown: Boolean;
  ExtendedKey: Boolean;
  MenuKey: Boolean;
  KeyRepeated: Boolean;
  RepeatCount: integer;
  end;

TKeyNames = packed record
 KeyChar: array[0..1] of Char;
 KeyExtName: array[0..100] of Char;
 end;

TForm1 = class(TForm)
    Panel1: TPanel;
    bstart: TButton;
    bstop: TButton;
    bsave: TButton;
    bclear: TButton;
    memolog: TMemo;
    SaveDialog1: TSaveDialog;
    cballkeys: TCheckBox;
    Label1: TLabel;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure bstartClick(Sender: TObject);
    procedure bstopClick(Sender: TObject);
    procedure bsaveClick(Sender: TObject);
    procedure bclearClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    procedure WMKeyHookMsg(var Msg : TMessage); message WM_KEYHOOKMSG;
    procedure Exception_Handler(Sender: TObject; E: Exception);
  public
    { Public declarations }
    procedure ProcessKeyEvent(AKeyName: string; isVirtual: boolean);
  end;
function Start_KeyHook(LicenceCode: string; WinHandle : HWND; MsgToSend : DWORD; DisableKeyboard: Boolean): boolean;
  stdcall external KEYHOOKLIBNAME name 'KeyboardHook_Start';
function Stop_KeyHook : boolean;
  stdcall external KEYHOOKLIBNAME name 'KeyboardHook_Stop';
function Update_Hook(DisableKeyboard: boolean): boolean;
  stdcall external KEYHOOKLIBNAME name 'KeyboardHook_UpdateHook';

var
  Form1: TForm1;
  KeysBuffer: TMemoryStream;


implementation

{$R *.dfm}

function GetActiveWindowTitle: string;
var
Wnd: Thandle;
PC: Array[0..$FFF] of Char;
begin
Result := '';
Wnd := GetForeGroundWindow; {GetActiveWindow}
GetWindowText(Wnd, PC, sizeof(PC)); {SendMessage(Wnd, wm_GetText, $FFF, LongInt(@PC));}
Result := StrPas(PC);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := Exception_Handler;
KeysBuffer := TMemoryStream.Create;
end;

procedure TForm1.Exception_Handler(Sender: TObject; E: Exception);
begin
Memolog.Lines.Add('[EXCEPTION] '+E.Message+'_'+Sender.ClassName);
end;

procedure TForm1.WMKeyHookMsg(var msg : TMessage);
const
KEYTICK_MSG : Integer = $C0000001;
KEYWAIT_MSG : integer = $00000001;
var
KBS : TKeyboardState;
VKeyName : array[0..100] of char;
VKeyChar : array[0..1] of char;
VKeyDown,VKeyRepeat,VMenuKey,VExtkey,VAlt,VCtrl,VShift: Boolean;
begin
  TRY
  if (msg.lParam = KEYTICK_MSG) or (msg.lParam = KEYWAIT_MSG) then exit;
  VKeyDown := (msg.lParam AND (1 shl 31)) = 0;
  if Not VKeyDown then exit;
  VMenuKey := (msg.lParam AND (1 shl 28)) <> 0;
  VExtKey := (msg.lParam AND (1 shl 24)) <> 0;
  VKeyRepeat := (msg.lParam AND (1 shl 30)) <> 0;
  VAlt := (msg.lParam AND (1 shl 29)) <> 0;
  //if (VMenuKey {or VExtKey or VAlt or VCtrl}) then exit;
  VCtrl := (GetKeyState(VK_CONTROL) AND (1 shl 15)) <> 0;
  VShift := (GetKeyState(VK_SHIFT) AND (1 shl 15)) <> 0;
  fillchar(VKeyName,SizeOf(VKeyName),#0);
  fillchar(VKeyChar,SizeOf(VKeyChar),#0);
  GetKeyboardState(KBS);
  if ToAscii(Msg.WParam, Msg.LParam, KBS, @VKeyChar, 0) > 0 then
     begin
     if Not (VMenuKey or VExtKey or VAlt or VCtrl) then ProcessKeyEvent(VKeyChar,False);
     end else
     begin
     if GetKeyNameText(msg.LParam,@VKeyName,SizeOf(VKeyName)) > 0 then
     if Not VKeyRepeat then ProcessKeyEvent(VKeyName,True);
     end;
  FINALLY
  inherited;
  END;
end;

procedure TForm1.ProcessKeyEvent(AKeyName: string; isVirtual: boolean);
var
BufStr: string;
AKey: string;
AWinTitle: string;
BufSize: integer;
begin
AKey := AKeyName;
if isVirtual then begin
   if Not cballkeys.Checked then exit;
   AKey := '['+AKey+']';
   memolog.Lines.Add(AKey);
   end else begin
   if Ord(AKey[1]) = 8 then AKey := KEY_BACKSPACE;   //BACKSPACE
   if Ord(AKey[1]) = 9 then AKey := KEY_TAB;         //TAB
   if Ord(AKey[1]) = 13 then AKey := KEY_ENTER;      //ENTER #13#10
   if Ord(AKey[1]) = 32 then AKey := KEY_SPACE;      //SPACE
   if cballkeys.Checked then begin
      memolog.Lines.Add(AKey);
      exit;
      end;
   if AKey = KEY_BACKSPACE then exit;   //PROCESS DELETE HERE
   if (AKey = KEY_ENTER) or (AKey = KEY_SPACE) or (AKey = KEY_TAB) then begin
      TRY
      BufSize := KeysBuffer.Size;
      if BufSize <= 0 then exit;
      SetLength(BufStr,BufSize);
      KeysBuffer.Seek(0, soFromBeginning);
      KeysBuffer.Read(BufStr[1],BufSize);
      AWinTitle := GetActiveWindowTitle;
      memolog.Lines.Add('['+AWinTitle+'] '+BufStr);
      FINALLY
      KeysBuffer.Clear;
      KeysBuffer.Position := 0;
      END;
      end else begin
      KeysBuffer.Write(AKey[1],Length(AKey));
      //if KeysBuffer.Size >= KEYBUFSIZE then FlushKeyBuffer;
      end;
   end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(KeysBuffer) then KeysBuffer.Free;
KeysBuffer := Nil;
end;

procedure TForm1.bstartClick(Sender: TObject);
begin
if Start_KeyHook('YOUR-LICENCE-KEY',Handle,WM_KEYHOOKMSG,false) then begin
   bstart.Enabled := False;
   bstop.Enabled := True;
   end else begin
   bstart.Enabled := True;
   bstop.Enabled := False;
   MessageDlg('Unable to Start the Keyboard Hook !', mtError, [mbOK], 0);
   end;
end;

procedure TForm1.bstopClick(Sender: TObject);
begin
if Stop_KeyHook then begin
   bstart.Enabled := True;
   bstop.Enabled := False;
   end else begin
   bstart.Enabled := False;
   bstop.Enabled := True;
   MessageDlg('Unable to Stop the Keyboard Hook !', mtError, [mbOK], 0);
   end;
end;

procedure TForm1.bsaveClick(Sender: TObject);
begin
if SaveDialog1.Execute then begin
   memolog.Lines.SaveToFile(SaveDialog1.FileName);
   end;
end;

procedure TForm1.bclearClick(Sender: TObject);
begin
memolog.Lines.Clear;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Stop_KeyHook;
end;

end.