umain.pas

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

unit UMain;

interface

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

const
  KEYBUFSIZE = 232;  //Key Capture Buffer Size
  VK_0 = 48;                //0 Number key
  VK_1 = 49;                //1 Number key
  VK_2 = 50;                //2 Number key
  VK_3 = 51;                //3 Number key
  VK_4 = 52;                //4 Number key
  VK_5 = 53;                //5 Number key
  VK_6 = 54;                //6 Number key
  VK_7 = 55;                //7 Number key
  VK_8 = 56;                //8 Number key
  VK_9 = 57;                //9 Number key
  VK_A = 65;                //A key
  VK_B = 66;                //B key
  VK_C = 67;                //C key
  VK_D = 68;                //D key
  VK_E = 69;                //E key
  VK_F = 70;                //F key
  VK_G = 71;                //G key
  VK_H = 72;                //H key
  VK_I = 73;                //I key
  VK_J = 74;                //J key
  VK_K = 75;                //K key
  VK_L = 76;                //L key
  VK_M = 77;                //M key
  VK_N = 78;                //N key
  VK_O = 79;                //O key
  VK_P = 80;                //P key
  VK_Q = 81;                //Q key
  VK_R = 82;                //R key
  VK_S = 83;                //S key
  VK_T = 84;                //T key
  VK_U = 85;                //U key
  VK_V = 86;                //V key
  VK_W = 87;                //W key
  VK_X = 88;                //X key
  VK_Y = 89;                //Y key
  VK_Z = 90;                //Z key

type
TForm1 = class(TForm)
    Panel1: TPanel;
    bstart: TButton;
    bstop: TButton;
    bsave: TButton;
    bclear: TButton;
    memolog: TMemo;
    SaveDialog1: TSaveDialog;
    cballkeys: TCheckBox;
    ltotcalls: TLabel;
    Label1: TLabel;
    cb_badwords: TComboBox;
    ed_badword: TEdit;
    btn_add: TButton;
    btn_delete: TButton;
    btn_clear: TButton;
    Memo1: TMemo;
    procedure btn_clearClick(Sender: TObject);
    procedure btn_deleteClick(Sender: TObject);
    procedure btn_addClick(Sender: TObject);
    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);
    procedure ProcessKeyEvent(Sender: TObject; AKeyStates: TKeyStates; AKeyNames: TKeyNames);
  private
    { Private declarations }
    procedure Exception_Handler(Sender: TObject; E: Exception);
  public
   { Public declarations }
  end;

var
  Form1: TForm1;
  KeyHook1: TCPKeyHook;
  KeysBuffer: TMemoryStream;
  callcount: integer = 0;
  BadWord: string;

implementation

{$R *.dfm}

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

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;

function GetActiveProcessName(IncludePath: boolean = False): string;
var
Wnd: Thandle;
ProcessName: string;
begin
Result := '';
ProcessName := '';
Wnd := GetForeGroundWindow; {GetActiveWindow}
ProcessName := GetWindowTitle(Wnd); //GetProcessNameFromWnd(Wnd);
if Not IncludePath then ProcessName := ExtractFileName(ProcessName);
Result := ProcessName;
end;

function GetActiveClassName: string;
var
Wnd: Thandle;
ClassName: array[0..80] of char;
begin
Result := '';
Wnd := GetForeGroundWindow; {GetActiveWindow}
GetClassName(Wnd, ClassName, sizeof(ClassName) - 1);
Result := StrPas(ClassName);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := Exception_Handler;
KeysBuffer := TMemoryStream.Create;
KeyHook1 := TCPKeyHook.Create(self);
KeyHook1.UserHookMsg := RegisterWindowMessage('keyhook_msg'); //WM_USER+100;
KeyHook1.LicenceCode := 'YOUR-LICENCEKEY-HERE';
KeyHook1.DisableKeyboard := false;
KeyHook1.LowLevelHook := True;
KeyHook1.HookInjected := False;
KeyHook1.OnKey := ProcessKeyEvent;
end;

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

procedure TForm1.ProcessKeyEvent(Sender: TObject; AKeyStates: TKeyStates; AKeyNames: TKeyNames);
var
BufStr: string;
AKey: string;
AExeName: string;
BufSize: integer;
AKeyCode: DWORD;
i,k: integer;
begin
inc(callcount);
ltotcalls.caption := 'Call Key Count: '+inttostr(callcount);
if AKeyStates.InjectedKey then exit;
if AKeyStates.KeyDown then exit;

AKey := AKeyNames.KeyExtName;
AExeName := '';
AKeyCode := Ord(AKeyNames.KeyChar);
//memolog.Lines.Add(AKey+'  '+AKeyNames.KeyChar);
if cballkeys.Checked then begin
   memolog.Lines.Add(AKey);
   exit;
   end;

//memolog.Lines.Add(inttostr(AKeyCode)+' '+AKeyNames.KeyChar);
if AKeyCode = VK_BACK then exit;   //PROCESS DELETE HERE

if AKeyCode = 0 then exit;
if (AKeyCode = VK_RETURN) or (AKeyCode = VK_SPACE) or (AKeyCode = VK_TAB) or (AKeyCode = 44) or (AKeyCode = 46) then
    begin
    TRY
      BufSize := KeysBuffer.Size;
      if BufSize <= 0 then exit;
      SetLength(BufStr,BufSize);
      KeysBuffer.Seek(0, soFromBeginning);
      KeysBuffer.Read(BufStr[1],BufSize);
      AExeName := GetActiveProcessName;
      //if AnsiCompareText(AExeName, 'notepad.exe') = 0 then
      memolog.Lines.Add('['+AExeName+'] '+BufStr);
    FINALLY
      BadWord := '';
      KeysBuffer.Clear;
      KeysBuffer.Position := 0;
    END;
    end else begin
    KeysBuffer.Write(AKeyNames.KeyChar,Length(AKeyNames.KeyChar));
    BadWord := BadWord + AKeyNames.KeyChar;
    for i := 0 to cb_badwords.Items.Count - 1 do begin
    if cb_badwords.Items.IndexOf(BadWord) >= 0 then begin
       for k := 0 to Length(BadWord) - 1 do begin
           keybd_event(VK_BACK, Mapvirtualkey(VK_BACK, 0), 0, 0);
           keybd_event(VK_BACK, Mapvirtualkey(VK_BACK, 0), KEYEVENTF_KEYUP, 0);
           end;
       keybd_event(VK_SHIFT, Mapvirtualkey(VK_SHIFT, 0), 0, 0);
       for k := 0 to Length(BadWord) - 1 do begin
           keybd_event(VK_8, Mapvirtualkey(VK_8, 0), 0, 0);
           keybd_event(VK_8, Mapvirtualkey(VK_8, 0), KEYEVENTF_KEYUP, 0);
           end;
       keybd_event(VK_SHIFT, Mapvirtualkey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0);
       BadWord := '';
       break;
       end;
    end;
    //if KeysBuffer.Size >= KEYBUFSIZE then FlushKeyBuffer;
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if KeyHook1.Enabled then KeyHook1.Stop_KeyHook;
finally
if Assigned(KeysBuffer) then KeysBuffer.Free;
if Assigned(KeyHook1) then KeyHook1.Free;
KeysBuffer := Nil;
KeyHook1 := nil;
end;

end;

procedure TForm1.bstartClick(Sender: TObject);
begin
if KeyHook1.Start_KeyHook 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 KeyHook1.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.btn_addClick(Sender: TObject);
begin
if ed_badword.Text = '' then exit;
if cb_badwords.Items.IndexOf(ed_badword.Text) >= 0 then exit;
cb_badwords.ItemIndex := cb_badwords.Items.Add(ed_badword.Text);
end;

procedure TForm1.btn_clearClick(Sender: TObject);
begin
if cb_badwords.Items.Count <= 0 then exit;
cb_badwords.Items.Clear;
end;

procedure TForm1.btn_deleteClick(Sender: TObject);
begin
if cb_badwords.Items.Count <= 0 then exit;
cb_badwords.DeleteSelected;
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
KeyHook1.Stop_KeyHook;
end;

end.