ushellhookdemo.pas

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

unit UShellHookDemo;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ShellAPI, CPShellHook, StdCtrls, ComCtrls, psapi,
  ImgList;

type
  TFMain = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    btn_starthook: TButton;
    btn_stophook: TButton;
    GroupBox1: TGroupBox;
    lb_userhookmsg: TLabel;
    lb_windowhandle: TLabel;
    loglist: TListView;
    lwebpage: TLabel;
    lemail: TLabel;
    Label2: TLabel;
    ImageList1: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btn_starthookClick(Sender: TObject);
    procedure btn_stophookClick(Sender: TObject);
    procedure lwebpageClick(Sender: TObject);
    procedure lemailClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure OnShellHookWindowCreated(Sender: TObject; WindowID: HWnd);
    procedure OnShellHookWindowActivated(Sender: TObject; WindowID: HWnd);
    procedure OnShellHookWindowDestroyed(Sender: TObject; WindowID: HWnd);
  end;

Const
  KH_WEB = 'http://www.bitlogic.co.uk';
  KH_EMAIL = 'mailto:[e-mail]?subject=TCPShellHook';
var
  FMain: TFMain;
  ShellHook: TCPShellHook;

implementation

{$R *.dfm}

function GetWindowTitle(AWnd: THandle): 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 GetProcessName(ProcPid: integer; FullPath: Boolean): string;
var
HPid: THandle;
PBuf: array [0..MAX_PATH] of Char;
begin
Result := '';
HPid := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcPid);
if HPid <> INVALID_HANDLE_VALUE then
   TRY
   if FullPath then begin
      if GetModuleFileNameEx(HPid, 0, PBuf, SizeOf(PBuf)) > 0 then Result := StrPas(PBuf);
      end else
      if GetModuleBaseNameA(HPid, 0, PBuf, SizeOf(PBuf)) > 0 then Result := StrPas(PBuf);
   FINALLY
   CloseHandle(HPid);
   END;
end;

procedure TFMain.FormCreate(Sender: TObject);
begin
ShellHook := TCPShellHook.Create(self);
ShellHook.LicenceCode := 'Enter Your DLL Licence Code Here';
ShellHook.OnShellWindowCreated := OnShellHookWindowCreated;
ShellHook.OnShellWindowActivated := OnShellHookWindowActivated;
ShellHook.OnShellWindowDestroyed := OnShellHookWindowDestroyed;
lb_userhookmsg.Caption := 'UserHookMsg: '+inttostr(ShellHook.UserHookMsg);
lb_windowhandle.Caption := 'WindowHandle: '+inttostr(ShellHook.WindowHandle);

end;

procedure TFMain.FormDestroy(Sender: TObject);
begin
ShellHook.Free;
end;

procedure TFMain.btn_starthookClick(Sender: TObject);
begin
if ShellHook.Start_ShellHook then begin
   btn_starthook.Enabled := False;
   btn_stophook.Enabled := True;
   end
   else begin
   MessageDlg('Error Starting ShellHook.', mtError, [mbOK], 0);
   btn_starthook.Enabled := True;
   btn_stophook.Enabled := False;
   end;
end;

procedure TFMain.btn_stophookClick(Sender: TObject);
begin
if ShellHook.Stop_ShellHook then begin
   btn_starthook.Enabled := True;
   btn_stophook.Enabled := False;
   end
   else begin
   MessageDlg('Error Stopping ShellHook.', mtError, [mbOK], 0);
   btn_starthook.Enabled := False;
   btn_stophook.Enabled := True;
   end;
end;

procedure TFMain.OnShellHookWindowCreated(Sender: TObject; WindowID: HWnd);
var
WindowTitle: string;
ProcessFile: string;
ThreadID,ProcessID: integer;
begin
if WindowID <> 0 then begin
   WindowTitle := GetWindowTitle(WindowID);
   ThreadID := GetWindowThreadProcessId(WindowID, @ProcessID);
   ProcessFile := GetProcessName(ProcessID,True);
   end
   else begin
   WindowTitle := '[DESKTOP]';
   ProcessFile := '[DESKTOP]';
   ThreadID := 0;
   ProcessID := 0;
   end;
with loglist.Items.Add do
     begin
     ImageIndex := 0;
     Caption := 'CREATED';
     SubItems.Add(inttostr(WindowID));
     SubItems.Add(WindowTitle);
     SubItems.Add(inttostr(ProcessID));
     SubItems.Add(ProcessFile);
     end;
end;

procedure TFMain.OnShellHookWindowActivated(Sender: TObject; WindowID: HWnd);
var
WindowTitle: string;
ProcessFile: string;
ThreadID,ProcessID: integer;
begin
if WindowID <> 0 then begin
   WindowTitle := GetWindowTitle(WindowID);
   ThreadID := GetWindowThreadProcessId(WindowID, @ProcessID);
   ProcessFile := GetProcessName(ProcessID,True);
   end
   else begin
   WindowTitle := '[DESKTOP]';
   ProcessFile := '[DESKTOP]';
   ThreadID := 0;
   ProcessID := 0;
   end;
with loglist.Items.Add do
     begin
     ImageIndex := 1;
     Caption := 'ACTIVATED';
     SubItems.Add(inttostr(WindowID));
     SubItems.Add(WindowTitle);
     SubItems.Add(inttostr(ProcessID));
     SubItems.Add(ProcessFile);
     end;
end;

procedure TFMain.OnShellHookWindowDestroyed(Sender: TObject; WindowID: HWnd);
var
WindowTitle: string;
ProcessFile: string;
ThreadID,ProcessID: integer;
begin
if WindowID <> 0 then begin
   WindowTitle := GetWindowTitle(WindowID);
   ThreadID := GetWindowThreadProcessId(WindowID, @ProcessID);
   ProcessFile := GetProcessName(ProcessID,True);
   end
   else begin
   WindowTitle := '[DESKTOP]';
   ProcessFile := '[DESKTOP]';
   ThreadID := 0;
   ProcessID := 0;
   end;
with loglist.Items.Add do
     begin
     ImageIndex := 2;
     Caption := 'DESTROYED';
     SubItems.Add(inttostr(WindowID));
     SubItems.Add(WindowTitle);
     SubItems.Add(inttostr(ProcessID));
     SubItems.Add(ProcessFile);
     end;
end;

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

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

end.