【笨嘴拙舌WINDOWS】实践检验之按键精灵【Delphi】

通过记录键盘和鼠标位置和输入信息，然后模拟发送，就能够创建一个按键精灵！

主要代码如下：

 1 library KeyBoardHook;
 2 
 3 { Important note about DLL memory management: ShareMem must be the
 4   first unit in your library's USES clause AND your project's (select
 5   Project-View Source) USES clause if your DLL exports any procedures or
 6   functions that pass strings as parameters or function results. This
 7   applies to all strings passed to and from your DLL--even those that
 8   are nested in records and classes. ShareMem is the interface unit to
 9   the BORLNDMM.DLL shared memory manager, which must be deployed along
10   with your DLL. To avoid using BORLNDMM.DLL, pass string information
11   using PChar or ShortString parameters. }
12 
13 uses
14   SysUtils,
15   Classes,
16   Windows,
17   Messages;
18 
19   type
20     TCallBackFun=procedure(info:PChar);
21     TKeyBoardHook=record
22       isrun:Bool;
23       hook:HHook;
24       callBackFun:TCallBackFun;
25     end;
26 
27 var
28   myKeyBoardHook:TKeyBoardHook;
29 {$R *.res}
30 
31 function GetKeyBoardInfo(code:Integer;wp:WPARAM;lp:LPARAM):LRESULT;stdcall;
32 var
33   info:string;
34 begin
35   if code<0 then
36   begin
37     Result:=CallNextHookEx(myKeyBoardHook.hook,code,wp,lp);
38     Exit;
39   end;
40   info:='';
41   if ((DWord(lp) shr 31)=1) and (code=HC_ACTION) then
42     if ((DWord(lp) shr 29)=1) then
43       info:='WM_SYSKEYUP'
44     else
45       info:='WM_KEYUP'
46   else
47     if ((DWord(lp) shr 29)=1) then
48       info:='WM_SYSKEYDOWN'
49     else
50       info:='WM_KEYDOWN';
51   info:=info+','+inttostr(wp)+','+inttostr(lp);
52   if Assigned(myKeyBoardHook.callbackFun) then
53     myKeyBoardHook.callbackFun(pchar(info));
54   Result := CallNextHookEx(myKeyBoardHook.hook,code,wp,lp);
55 end;
56 
57 procedure InstallKeyBoardHook(callback:TCallBackFun);stdcall;
58 begin
59   if not myKeyBoardHook.isrun then
60   begin 
61     myKeyBoardHook.hook:=SetWindowsHookEx(WH_KEYBOARD,@GetKeyBoardInfo,HInstance,0);
62     myKeyBoardHook.callBackFun:=callBack;
63     myKeyBoardHook.isrun:=not myKeyBoardHook.isrun;
64   end;
65 end;
66 
67 procedure UninstallKeyBoardHook();stdcall;
68 begin
69   if   myKeyBoardHook.isrun   then
70   begin
71     UnHookWindowsHookEx(myKeyBoardHook.hook);
72     myKeyBoardHook.callBackFun:=nil;
73     myKeyBoardHook.isrun:=not myKeyBoardHook.isrun;
74   end;
75 end;
76 
77 Procedure DLLEntryPoint(dwReason:DWord);
78 begin
79   Case dwReason of
80     DLL_PROCESS_ATTACH:begin
81       myKeyBoardHook.isrun:=false;
82     end;
83     DLL_PROCESS_DETACH:;
84     DLL_THREAD_ATTACH:;
85     DLL_THREAD_DETACH:;
86   End;
87 end;
88 
89 exports
90   InstallKeyBoardHook,
91   UninstallKeyBoardHook;
92 
93 begin
94   DLLProc := @DLLEntryPoint;
95   DLLEntryPoint(DLL_PROCESS_ATTACH);
96 end.

以上是创建一个全局钩子函数的Dll来记录按键信息

library Mousehook;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  SysUtils,
  Classes,
  Windows,
  Messages,
  ShellAPI;

  type
    TCallbackFun=procedure(info:pchar);
    TMouseHook=record
      isrun:Bool;
      hook:HHook;
      callbackFun:TCallbackFun;
    end;

var
  myMouseHook:TMouseHook;

{$R *.res}
//1.定义自定义的HOOK函数，函数必须和需要HOOK的钩子类型保持同样的参数列表
function GetHookInfo(code:Integer;wp:WPARAM;lp:LPARAM):LResult;stdcall;
var
  info:String;
begin
  if code<0 then
  begin
    Result:=CallNextHookEx(myMouseHook.hook,code,wp,lp);
    Exit;
  end;
  info:='';
  case wp of
    //鼠标消息共有21种，其中10种点击是客户区，10种是非客户区也就是消息名以NC开头的消息。和一个命中测试消息
    WM_LBUTTONDOWN:begin
      info:='WM_LBUTTONDOWN';
    end;
    WM_LBUTTONUP:begin
      info:='WM_LBUTTONUP';
    end;
    WM_LBUTTONDBLCLK:begin
      info:='WM_LBUTTONDBLCLK';
    end;
    WM_RBUTTONDOWN:begin
      info:='WM_RBUTTONDOWN';
    end;
    WM_RBUTTONUP:begin
      info:='WM_RBUTTONUP';
    end;
    WM_RBUTTONDBLCLK:begin
      info:='WM_RBUTTONDBLCLK';
    end;
    WM_MBUTTONDOWN:begin
      info:='WM_MBUTTONDOWN';
    end;
    WM_MBUTTONUP:begin
      info:='WM_MBUTTONUP';
    end;
    WM_MBUTTONDBLCLK:begin
      info:='WM_MBUTTONDBLCLK';
    end;
    WM_MOUSEMOVE:begin
      info:='WM_MOUSEMOVE';
    end;
    WM_NCMouseMove:begin
      info:='WM_NCMouseMove';
    end;
    WM_MOUSEWHEEL:
    begin
       info:='WM_MOUSEWHEEL';
    end;
    WM_NCHITTEST:begin
      info:='WM_NCHITTEST';
    end;
    WM_NCLBUTTONDOWN:BEGIN
      info:='WM_NCLBUTTONDOWN';
    end;
    WM_NCLBUTTONUP:BEGIN
      info:='WM_NCLBUTTONUP';
    end;
    WM_NCLBUTTONDBLCLK:BEGIN
      info:='WM_NCLBUTTONDBLCLK';
    end;
    WM_NCRBUTTONDOWN:BEGIN
      info:='WM_NCRBUTTONDOWN';
    end;
    WM_NCRBUTTONUP:BEGIN
      info:='WM_NCRBUTTONUP';
    end;

    WM_NCRBUTTONDBLCLK:BEGIN
      info:='WM_NCRBUTTONDBLCLK';
    end;
  end;
  info:=info+','+inttostr(PMouseHookStruct(lp)^.wHitTestCode)+ ','+inttostr(MakeLParam(PMouseHookStruct(lp)^.pt.x,PMouseHookStruct(lp)^.pt.Y));
  if Assigned(myMouseHook.callbackFun) then
    myMouseHook.callbackFun(pchar(info));
  Result := CallNextHookEx(myMouseHook.hook,code,wp,lp);
end;

procedure InstallMouseHook(callbackF:Tcallbackfun);stdcall;
begin
  if not myMouseHook.isrun then
  begin
    {2.设置钩子函数
    setwindowhookEx参数说明
    参数idHook指定建立的监视函数类型。
    参数lpfn指定消息函数，在相应的消息产生后，系统会调用该函数并将消息值传递给该函数供处理。函数的一般形式为：
    Hookproc (code:   Integer;   wparam:   WPARAM;   lparam:   LPARAM):   LRESULT   stdcall;
    其中code为系统指示标记（对应于idHook），wParam和lParam为附加参数，根据不同的消息监视类型而不同。
    只要在程序中建立这样一个函数再通过SetwindowsHookEx函数将它加入到消息监视链中就可以处理消息了。
    }
    myMouseHook.hook:=setwindowshookex(WH_MOUSE,@gethookinfo,HInstance,0);
    myMouseHook.callbackfun:=callbackf;
    myMouseHook.isrun:=not mymousehook.isrun;
  end;
end;

procedure UninstallMouseHook();stdcall;
begin
  if   myMouseHook.isrun   then
  begin
    UnHookWindowsHookEx(mymousehook.hook);
    myMouseHook.callbackfun   :=nil;
    myMouseHook.isrun:=not myMouseHook.isrun;
  end;
end;

Procedure DLLEntryPoint(dwReason:DWord);
begin
  Case dwReason of
    DLL_PROCESS_ATTACH:begin
      myMouseHook.isrun:=false;
    end;
    DLL_PROCESS_DETACH:;
    DLL_THREAD_ATTACH:;
    DLL_THREAD_DETACH:;
  End;
end;

exports
  InstallMouseHook,
  UninstallMouseHook;

begin
  DLLProc := @DLLEntryPoint;
  DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

以上是捕获鼠标消息的全局钩子DLL

使用一个新的线程来模拟发送消息

procedure TPlayThread.Execute;
var
  directive:string;
  i:integer;
  ForgroundForm:TForm;
  procedure ExecuteDir(directive:string);
  var
     tempList:TStringList;
     Wp,Lp:integer;
     wmtype:String;
     focusControl:string;
     duration:Cardinal;
     winCtl:TWinControl;
     tempHandle,focusHandle:THandle;
     classname:String;
     mousPoint:TPOINT;
     procedure findFocus;
     var
       temp:TWinControl;
       finded:Boolean;
     begin
       if ((wmtype='WM_MOUSEMOVE') or (wmtype='WM_NCMouseMove')) then Exit;
       winCtl:=TWinControl(ForgroundForm.FindChildControl(focusControl));
       
       if winCtl<>nil then
       begin
         focusHandle:= winCtl.Handle;
         AttachThreadInput(GetWindowThreadProcessId(ForgroundForm.Handle,nil),Self.ThreadID,True);
         Ferrorinfo:=SysErrorMessage(GetLastError);
         winCtl.SetFocus;
         AttachThreadInput(GetWindowThreadProcessId(ForgroundForm.Handle,nil),Self.ThreadID,False);
         Ferrorinfo:=SysErrorMessage(GetLastError);
         Exit;
       end;
       temp:=nil;
       finded:=False;
       while not finded do
       begin
         GetCursorPos(mousPoint);
         tempHandle := WindowFromPoint(mousPoint);
         if tempHandle =0 then
         begin
          Sleep(0);
          Continue;
         end;
         temp:=FindControl(tempHandle);
         if temp=nil then
         begin
          Sleep(0);
          Continue;
         end;
         if (temp.Name = focusControl) or (classname=temp.ClassName) then
            finded:=True;
       end;
       focusHandle := temp.Handle;
       AttachThreadInput(GetWindowThreadProcessId(ForgroundForm.Handle,nil),Self.ThreadID,True);
       Ferrorinfo:=SysErrorMessage(GetLastError);
       temp.SetFocus;
       AttachThreadInput(GetWindowThreadProcessId(ForgroundForm.Handle,nil),Self.ThreadID,False);
       Ferrorinfo:=SysErrorMessage(GetLastError);
     end;
  begin
    tempList:=TStringList.Create;
    try
      tempList.CommaText:=directive;
      tempList.Delimiter:=',';
      wmtype:=tempList[0];
      focusHandle:=0;
      Wp:=StrToIntDef(tempList[1],0);  //wParam
      Lp:=StrToIntDef(tempList[2],0);  //Lparam
      
      duration:= StrToIntDef(tempList[3],0);
      if (duration=0) and (wmtype='WM_NCMouseMove') then Exit;       //小于线程调度时间片的话就不延时---以免 sleep(0)直接放弃时间进入内核态
      if (wmtype='') or (tempList.Count<6) then Exit;
      focusControl :=tempList[4];
      classname := tempList[5];  

      findFocus;
      //鼠标消息     
      if wmtype='WM_LBUTTONDOWN' then TInputHelper.MouseLButtonDown(focusHandle,Wp,Lp)
      else if wmtype='WM_LBUTTONUP' then  TInputHelper.MouseLButtonUp(focusHandle,Wp,Lp,True)
      else if wmtype='WM_LBUTTONDBLCLK' then TInputHelper.MouseLButtonDbClick(focusHandle,Wp,Lp,True)
      else if wmtype='WM_RBUTTONDOWN' then  TInputHelper.MouseRButtonDown(focusHandle,Wp,Lp,True)
      else if wmtype='WM_RBUTTONUP' then  TInputHelper.MouseRButtonUp(focusHandle,Wp,Lp,True)
      else if wmtype='WM_RBUTTONDBLCLK' then  TInputHelper.MouseRButtonDbClick(focusHandle,Wp,Lp,True)
      else if wmtype='WM_MBUTTONDOWN' then TInputHelper.MouseMButtonDown(focusHandle,Wp,Lp,True)
      else if wmtype='WM_MBUTTONUP' then   TInputHelper.MouseMButtonUp(focusHandle,Wp,Lp,True)
      else if wmtype='WM_MBUTTONDBLCLK' then TInputHelper.MouseMButtonDbClick(focusHandle,Wp,Lp,True)
      else if wmtype='WM_MOUSEMOVE' then  TInputHelper.MouseMove(focusHandle,Wp,Lp,True)
      else if wmtype='WM_MOUSEWHEEL' then TInputHelper.MouseWHEEL(focusHandle,Wp,Lp,True)
      //鼠标非客户区
      else if wmtype='WM_NCMouseMove' then  TInputHelper.MouseNCMouseMove(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCHITTEST' then  TInputHelper.MouseNCHITTEST(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCLBUTTONDOWN' then  TInputHelper.MouseNCLBUTTONDOWN(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCLBUTTONUP' then  TInputHelper.MouseNCLBUTTONUP(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCLBUTTONDBLCLK' then  TInputHelper.MouseNCLBUTTONDBLCLK(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCRBUTTONDOWN' then  TInputHelper.MouseNCRBUTTONDOWN(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCRBUTTONUP' then  TInputHelper.MouseNCRBUTTONUP(focusHandle,Wp,Lp,True)
      else if wmtype='WM_NCRBUTTONDBLCLK' then  TInputHelper.MouseRButtonDbClick(focusHandle,Wp,Lp,True)
      //键盘消息    
      else if wmtype='WM_KEYDOWN' then TInputHelper.KeyDown(focusHandle,Wp,Lp,True)
      else if wmtype='WM_KEYUP' then  TInputHelper.KEYUP(focusHandle,Wp,Lp,True)
      else if wmtype='WM_SYSKEYDOWN' then  TInputHelper.KeySYSKEYDOWN(focusHandle,Wp,Lp,True)
      else if wmtype='WM_SYSKEYUP' then TInputHelper.KeySYSKEYUP(focusHandle,Wp,Lp,True);
      Application.ProcessMessages;
      Sleep(duration);
    finally
      tempList.Free;
    end; 
  end;
begin
  Sleep(1000);
  try
    ForgroundForm :=InputRecord.ForgroundForm;
    for i:= 0 to PosList.Count-1 do
    begin
      directive:=PosList[i];
      ExecuteDir(directive);
    end; 
  finally
    InputRecord.FIsPlay:=False;   
  end;

end;

点击这里下载代码

【推广】 免费学中医，健康全家人
原文地址：https://www.cnblogs.com/pavkoo/p/3316574.html