ukeyhookdemo.pas

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

unit UKeyHookDemo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, ExtCtrls, ShellAPI, CPKeyHook;

type
  TForm1 = class(TForm)
    Label2: TLabel;
    Panel1: TPanel;
    skey: TShape;
    salt: TShape;
    sctrl: TShape;
    sshift: TShape;
    sxkey: TShape;
    smenukey: TShape;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label8: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    skeyrepeat: TShape;
    lbkeyrepeat: TLabel;
    Panel2: TPanel;
    Label6: TLabel;
    Label7: TLabel;
    Panel3: TPanel;
    memokeylog: TMemo;
    GroupBox1: TGroupBox;
    lemail: TLabel;
    lwebpage: TLabel;
    GroupBox2: TGroupBox;
    btStart: TButton;
    btStop: TButton;
    ltotcalls: TLabel;
    lbvkey: TLabel;
    Label1: TLabel;
    lbakey: TLabel;
    lbkeylayout: TLabel;
    lwindowhandle: TLabel;
    luserhookmsg: TLabel;
    lbapp: TLabel;
    Panel4: TPanel;
    Label9: TLabel;
    cbdisablekeyboard: TCheckBox;
    btUpdate: TButton;
    sdeadkey: TShape;
    Label12: TLabel;
    KeyHook1: TCPKeyHook;
    procedure btStartClick(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure lwebpageClick(Sender: TObject);
    procedure lemailClick(Sender: TObject);
    procedure cbdisablekeyboardClick(Sender: TObject);
    procedure btUpdateClick(Sender: TObject);
    procedure KeyHook1Key(Sender: TObject; AKeyStates: TKeyStates;
      AKeyNames: TKeyNames);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

Const
  KH_WEB = 'http://www.bitlogic.co.uk';
  KH_EMAIL = 'mailto:[e-mail]?subject=TCPKeyHook';
var
  Form1: TForm1;
  callcount: integer = 0;

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.btStartClick(Sender: TObject);
begin
if KeyHook1.Start_KeyHook then begin
   label1.caption := 'KeyHook Status: Enabled';
   btStart.Enabled := False;
   btStop.Enabled := True;
   btUpdate.Enabled := True;
   end
   else begin
   label1.caption := 'KeyHook Status: Error Starting Hook DLL';
   btStart.Enabled := True;
   btStop.Enabled := False;
   btUpdate.Enabled := False;
   end;
end;

procedure TForm1.btStopClick(Sender: TObject);
begin
if KeyHook1.Stop_KeyHook then begin
   label1.caption := 'KeyHook Status: Disabled';
   btStart.Enabled := True;
   btStop.Enabled := False;
   btUpdate.Enabled := False;
   end
   else begin
   label1.caption := 'KeyHook Status: Error Starting Hook DLL';
   btStart.Enabled := False;
   btStop.Enabled := True;
   btUpdate.Enabled := True;   
   end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
KeyHook1.LicenceCode := 'YOUR-LICENCEKEY-HERE';
KeyHook1.HookInjected := False;
KeyHook1.LowLevelHook := False;
KeyHook1.DisableKeyboard := false;
KeyHook1.UserHookMsg := RegisterWindowMessage('keyhook_msg'); //WM_USER+100;
lwindowhandle.Caption := 'KeyHook WindowHandle: '+inttostr(KeyHook1.WindowHandle);
luserhookmsg.Caption := 'Custom UserHookMsg: '+inttostr(KeyHook1.UserHookMsg);
lbkeylayout.Caption := 'KeyboardLayout Code: '+KeyHook1.KeyboardLayout;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if KeyHook1.Enabled then KeyHook1.Stop_KeyHook;
end;

procedure TForm1.lwebpageClick(Sender: TObject);
begin
ShellExecute(GetDesktopWindow(), 'open', PChar(KH_WEB), nil, nil, SW_SHOWNORMAL);
end;

procedure TForm1.lemailClick(Sender: TObject);
begin
ShellExecute(GetDesktopWindow(), 'open', PChar(KH_EMAIL), nil, nil, SW_SHOWNORMAL);
end;

procedure TForm1.cbdisablekeyboardClick(Sender: TObject);
begin
KeyHook1.DisableKeyboard := cbdisablekeyboard.Checked;
end;

procedure TForm1.btUpdateClick(Sender: TObject);
begin
if KeyHook1.UpdateHook then MessageDlg('Hook Updated.'+#13+#10+''+#13+#10+'The Hook has been updated with the selected properties.'+#13+#10+'Updates take effect immediately.', mtInformation, [mbOK], 0)
else MessageDlg('Error Updating Hook.'+#13+#10+''+#13+#10+'It was not possible to update the Hook. The Hook must be'+#13+#10+'Enabled and Started to update the properties.', mtError, [mbOK], 0);
end;

procedure TForm1.KeyHook1Key(Sender: TObject; AKeyStates: TKeyStates;
  AKeyNames: TKeyNames);
begin
  inc(callcount);
  ltotcalls.caption := 'Total Hook Calls Processed: '+inttostr(callcount);
  { Show The Current State of each Key Pressed }
  if AKeyStates.KeyDown then skey.Brush.Color := clLime else skey.Brush.Color := clWhite;

  if AKeyStates.DeadKey then sdeadkey.Brush.Color := clRed else sdeadkey.Brush.Color := clWhite;
  //if AKeyStates.DoubleKey then sdoublekey.Brush.Color := clRed else sdoublekey.Brush.Color := clWhite;

  if (AKeyStates.KeyRepeated and AKeyStates.KeyDown) then skeyrepeat.Brush.Color := clYellow
  else skeyrepeat.Brush.Color := clWhite;
  lbkeyrepeat.Caption := 'Repeat '+inttostr(AKeyStates.RepeatCount);
  if AKeyStates.AltDown then salt.Brush.Color := clLime else salt.Brush.Color := clWhite;
  if AKeyStates.CtrlDown then sctrl.Brush.Color := clLime else sctrl.Brush.Color := clWhite;
  if AKeyStates.ShiftDown then sshift.Brush.Color := clLime else sshift.Brush.Color := clWhite;
  if (AKeyStates.ExtendedKey and AKeyStates.KeyDown) then sxkey.Brush.Color := clRed else sxkey.Brush.Color := clWhite;
  if (AKeyStates.MenuKey and AKeyStates.KeyDown) then smenukey.Brush.Color := clBlue else smenukey.Brush.Color := clWhite;
  lbapp.Caption := 'Active Window: '+GetActiveWindowTitle;
  lbvkey.Caption := 'Last Virtual Key: '+AKeyNames.KeyExtName;
  lbakey.Caption := 'Last Ascii Key: '+AKeyNames.KeyChar;

  if (AKeyStates.DeadKey) then Exit; { If Key is DeadKey Character then ignore it }
  if AKeyStates.KeyDown then begin   { If Key is Down then log ASCII Character to memo }
  if AKeyNames.KeyChar = #13 then memokeylog.Text := memokeylog.Text+#13#10
  else memokeylog.Text := memokeylog.Text+AKeyNames.KeyChar;
  end;
end;

end.