📄 umousehookdemo.pas

📁 键盘钩子程序及控件, C++ Builder 和DELPHI可用
💻 PAS
字号:
unit UMouseHookDemo;

interface

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

type
  TForm1 = class(TForm)
    Panel2: TPanel;
    Label6: TLabel;
    Label7: TLabel;
    GroupBox1: TGroupBox;
    lemail: TLabel;
    lwebpage: TLabel;
    GroupBox2: TGroupBox;
    btStart: TButton;
    btStop: TButton;
    Panel4: TPanel;
    Label9: TLabel;
    GroupBox3: TGroupBox;
    shtcaption: TShape;
    shtmenu: TShape;
    shtreduce: TShape;
    shtzoom: TShape;
    shtsysmenu: TShape;
    shttransparent: TShape;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Label15: TLabel;
    Label16: TLabel;
    Label17: TLabel;
    shtclient: TShape;
    Label18: TLabel;
    shtborder: TShape;
    Label20: TLabel;
    shthscroll: TShape;
    Label21: TLabel;
    shtvscroll: TShape;
    Label22: TLabel;
    GroupBox4: TGroupBox;
    sbleft: TShape;
    sbmiddle: TShape;
    sbldblclk: TShape;
    sbrdblclk: TShape;
    sbmdblclk: TShape;
    sbwheel: TShape;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label8: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    sbright: TShape;
    lbkeyrepeat: TLabel;
    shtbottom: TShape;
    Label2: TLabel;
    shtbottomleft: TShape;
    Label19: TLabel;
    shtbottomright: TShape;
    Label23: TLabel;
    shtleft: TShape;
    Label25: TLabel;
    shtright: TShape;
    Label26: TLabel;
    shttop: TShape;
    Label27: TLabel;
    shttopleft: TShape;
    Label24: TLabel;
    shttopright: TShape;
    Label28: TLabel;
    shtsize: TShape;
    Label29: TLabel;
    shtclose: TShape;
    Label30: TLabel;
    btUpdate: TButton;
    GroupBox5: TGroupBox;
    cbdisablemouse: TCheckBox;
    cb_hidepointer: TCheckBox;
    cb_invertpointer: TCheckBox;
    GroupBox6: TGroupBox;
    ltotcalls: TLabel;
    lbmousex: TLabel;
    lbmousey: TLabel;
    lwindowhandle: TLabel;
    luserhookmsg: TLabel;
    lbapptitle: TLabel;
    lbwndhandle: TLabel;
    lbmousehittestcode: TLabel;
    lbmouseextrainfo: TLabel;
    lbwndcaption: TLabel;
    lbwndclass: TLabel;
    lbwndtext: TLabel;
    lbwndparent: TLabel;
    cb_blocklb: TCheckBox;
    cb_blockrb: TCheckBox;
    cb_blockmb: TCheckBox;
    cb_blockwheel: TCheckBox;
    cb_swapbuttons: TCheckBox;
    lb_status: TLabel;
    shthelp: TShape;
    Label1: TLabel;
    shterror: TShape;
    Label31: TLabel;
    shtobject: TShape;
    Label32: TLabel;
    lb_dx: TLabel;
    lb_dy: TLabel;
    cb_wrappointer: TCheckBox;
    lb_mickeysx: TLabel;
    lb_mickeysy: TLabel;
    procedure btStartClick(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure OnMouseEvent(Sender: TObject; AMouseStates: TMouseStates);
    procedure FormDestroy(Sender: TObject);
    procedure lwebpageClick(Sender: TObject);
    procedure lemailClick(Sender: TObject);
    procedure cbdisablemouseClick(Sender: TObject);
    procedure btUpdateClick(Sender: TObject);
    procedure cb_hidepointerClick(Sender: TObject);
    procedure cb_invertpointerClick(Sender: TObject);
    procedure cb_blocklbClick(Sender: TObject);
    procedure cb_blockrbClick(Sender: TObject);
    procedure cb_blockmbClick(Sender: TObject);
    procedure cb_swapbuttonsClick(Sender: TObject);
    procedure cb_blockwheelClick(Sender: TObject);
    procedure cb_wrappointerClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

Const
  KH_WEB = 'http://www.bitlogic.co.uk';
  KH_EMAIL = 'mailto:development@bitlogic.co.uk?subject=TCPMouseHook 1.3';
  LLMHF_INJECTED = $00000001;

var
  Form1: TForm1;
  callcount: integer = 0;
  MouseHook1: TCPMouseHook;

implementation

{$R *.DFM}

{** Window Handle Functions **********************************************************}

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 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 GetWindowClassName(AWnd: HWnd): string;
var
ClassName: array[0..255] of char;
begin
Result := '';
GetClassName(AWnd, ClassName, sizeof(ClassName) - 1);
Result := StrPas(ClassName);
end;

function GetTextFromWindow(Wnd: HWND): string;
var
textlength: Integer;
Text: PChar;
begin
Result := '';
textlength := SendMessage(Wnd, WM_GETTEXTLENGTH, 0, 0);
if textlength > 0 then
   begin
   GetMem(Text, textlength + 1);
   Try
   SendMessage(Wnd, WM_GETTEXT, textlength + 1, Integer(Text));
   Result := Text;
   Finally
   FreeMem(Text);
   End;
  end;
end;

{*****************************************************************************}

procedure TForm1.OnMouseEvent(Sender: TObject; AMouseStates: TMouseStates);
begin
  inc(callcount);
  ltotcalls.caption := 'Total Hook Calls Processed: '+inttostr(callcount);
  lbmousex.Caption := 'Pointer Screen X: '+inttostr(AMouseStates.x);
  lbmousey.Caption := 'Pointer Screen Y: '+inttostr(AMouseStates.y);
  lb_dx.Caption := 'Pointer Absolute X: '+inttostr(AMouseStates.dx);
  lb_dy.Caption := 'Pointer Absolute Y: '+inttostr(AMouseStates.dy);
  lb_mickeysx.Caption := 'Screen Mickeys X: '+inttostr(Round(MouseHook1.ScreenMickeyX));
  lb_mickeysy.Caption := 'Screen Mickeys Y: '+inttostr(Round(MouseHook1.ScreenMickeyY));
  lbwndhandle.Caption := 'Window Handle: '+inttostr(AMouseStates.Window);
  lbwndparent.Caption := 'Window Parent: '+inttostr(GetParent(AMouseStates.Window));
  lbwndcaption.Caption := 'Window Caption: '+GetWindowTitle(AMouseStates.Window);
  lbwndclass.Caption := 'Window Class: '+GetWindowClassName(AMouseStates.Window);
  lbwndtext.Caption := 'Window Text: '+GetTextFromWindow(AMouseStates.Window);
  lbapptitle.Caption := 'Application Title: '+GetActiveWindowTitle;
  lbmousehittestcode.Caption := 'HitTestCode: '+inttostr(AMouseStates.HitTestCode);
  lbmouseextrainfo.Caption := 'ExtraInfo: '+inttostr(AMouseStates.ExtraInfo);
  //lbmousewparam.Caption := 'WParam: '+inttostr(AMouseStates.ButtonInfo);

  { Show The State of HitTestCode }
  if AMouseStates.HitTestCode = HTCAPTION then shtcaption.Brush.Color := clLime else shtcaption.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTCLIENT then shtclient.Brush.Color := clLime else shtclient.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTMENU then shtmenu.Brush.Color := clLime else shtmenu.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTREDUCE then shtreduce.Brush.Color := clLime else shtreduce.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTZOOM then shtzoom.Brush.Color := clLime else shtzoom.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTCLOSE then shtclose.Brush.Color := clLime else shtclose.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTSYSMENU then shtsysmenu.Brush.Color := clLime else shtsysmenu.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTTRANSPARENT then shttransparent.Brush.Color := clLime else shttransparent.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTBORDER then shtborder.Brush.Color := clLime else shtborder.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTHSCROLL then shthscroll.Brush.Color := clLime else shthscroll.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTVSCROLL then shtvscroll.Brush.Color := clLime else shtvscroll.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTBOTTOM then shtbottom.Brush.Color := clLime else shtbottom.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTBOTTOMLEFT then shtbottomleft.Brush.Color := clLime else shtbottomleft.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTBOTTOMRIGHT then shtbottomright.Brush.Color := clLime else shtbottomright.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTLEFT then shtleft.Brush.Color := clLime else shtleft.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTRIGHT then shtright.Brush.Color := clLime else shtright.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTTOP then shttop.Brush.Color := clLime else shttop.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTTOPLEFT then shttopleft.Brush.Color := clLime else shttopleft.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTTOPRIGHT then shttopright.Brush.Color := clLime else shttopright.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTSIZE then shtsize.Brush.Color := clLime else shtsize.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTHELP then shthelp.Brush.Color := clLime else shthelp.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTERROR then shterror.Brush.Color := clLime else shterror.Brush.Color := clWhite;
  if AMouseStates.HitTestCode = HTOBJECT then shtobject.Brush.Color := clLime else shtobject.Brush.Color := clWhite;

  if ((AMouseStates.ButtonInfo = WM_LBUTTONDOWN) or (AMouseStates.ButtonInfo = WM_NCLBUTTONDOWN))
  then sbleft.Brush.Color := clLime else sbleft.Brush.Color := clWhite;

  if ((AMouseStates.ButtonInfo = WM_RBUTTONDOWN) or (AMouseStates.ButtonInfo = WM_NCRBUTTONDOWN))
  then sbright.Brush.Color := clLime else sbright.Brush.Color := clWhite;

  if ((AMouseStates.ButtonInfo = WM_MBUTTONDOWN) or (AMouseStates.ButtonInfo = WM_NCMBUTTONDOWN))
  then sbmiddle.Brush.Color := clLime else sbmiddle.Brush.Color := clWhite;

  if ((AMouseStates.ButtonInfo = WM_LBUTTONDBLCLK) or (AMouseStates.ButtonInfo = WM_NCLBUTTONDBLCLK))
  then sbldblclk.Brush.Color := clLime else sbldblclk.Brush.Color := clWhite;

  if ((AMouseStates.ButtonInfo = WM_RBUTTONDBLCLK) or (AMouseStates.ButtonInfo = WM_NCRBUTTONDBLCLK))
  then sbrdblclk.Brush.Color := clLime else sbrdblclk.Brush.Color := clWhite;

  if AMouseStates.ButtonInfo = WM_MBUTTONDBLCLK then sbmdblclk.Brush.Color := clLime else sbmdblclk.Brush.Color := clWhite;
  if AMouseStates.ButtonInfo = WM_MOUSEWHEEL then sbwheel.Brush.Color := clLime else sbwheel.Brush.Color := clWhite;
end;

procedure TForm1.btStartClick(Sender: TObject);
begin
if MouseHook1.Start_MouseHook then begin
   lb_status.caption := 'MouseHook Status: Enabled';
   btStart.Enabled := False;
   btStop.Enabled := True;
   btUpdate.Enabled := True;
   end
   else begin
   lb_status.caption := 'MouseHook Status: Error Starting Hook DLL';
   btStart.Enabled := True;
   btStop.Enabled := False;
   btUpdate.Enabled := False;
   end;
end;

procedure TForm1.btStopClick(Sender: TObject);
begin
if MouseHook1.Stop_MouseHook then begin
   lb_status.caption := 'MouseHook Status: Disabled';
   btStart.Enabled := True;
   btStop.Enabled := False;
   btUpdate.Enabled := False;
   end
   else begin
   lb_status.caption := 'MouseHook Status: Error Starting Hook DLL';
   btStart.Enabled := False;
   btStop.Enabled := True;
   btUpdate.Enabled := True;
   end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MouseHook1 := TCPMouseHook.Create(self);
MouseHook1.LicenceCode := '';
//MouseHook1.UserHookMsg := WM_USER+200;
MouseHook1.UserHookMsg := RegisterWindowMessage('mousehook_msg'); //WM_USER+100;
MouseHook1.OnMouse := OnMouseEvent;
MouseHook1.DisableMouse := false;
lwindowhandle.Caption := 'MouseHook WindowHandle: '+inttostr(MouseHook1.WindowHandle);
luserhookmsg.Caption := 'Custom UserHookMsg: '+inttostr(MouseHook1.UserHookMsg);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if MouseHook1.Enabled then MouseHook1.Stop_MouseHook;
finally
MouseHook1.Free;
MouseHook1 := nil;
end;
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.cbdisablemouseClick(Sender: TObject);
begin
MouseHook1.DisableMouse := cbdisablemouse.Checked;
end;

procedure TForm1.btUpdateClick(Sender: TObject);
begin
if MouseHook1.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.cb_hidepointerClick(Sender: TObject);
begin
MouseHook1.HidePointer := cb_hidepointer.Checked;
end;

procedure TForm1.cb_invertpointerClick(Sender: TObject);
begin
MouseHook1.InvertPointer := cb_invertpointer.Checked;
end;

procedure TForm1.cb_blocklbClick(Sender: TObject);
begin
MouseHook1.BlockLeftButton := cb_blocklb.Checked;
end;

procedure TForm1.cb_blockrbClick(Sender: TObject);
begin
MouseHook1.BlockRightButton := cb_blockrb.Checked;
end;

procedure TForm1.cb_blockmbClick(Sender: TObject);
begin
MouseHook1.BlockMiddleButton := cb_blockmb.Checked;
end;

procedure TForm1.cb_swapbuttonsClick(Sender: TObject);
begin
MouseHook1.SwapButtons := cb_swapbuttons.Checked;
end;

procedure TForm1.cb_blockwheelClick(Sender: TObject);
begin
MouseHook1.BlockWheel := cb_blockwheel.Checked;
end;

procedure TForm1.cb_wrappointerClick(Sender: TObject);
begin
MouseHook1.WrapPointer := cb_wrappointer.Checked;
end;

end.
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -