The Unofficial Newsletter of Delphi Users - by Robert Vivrette

Hooking Into the VCL

by Clinton Johnson - xepol@poboxes.com

This represents an extension of a concept shown by Grahame Marsh earlier in UNDU (see There's Method to My Hook Madness!).  I've extended his code, and created VCL non-visual wrappers for each possible system hook.  I'm not going to go into much detail about what I've done this time, I'm going to let people go through the source for that.

Please remember that hooks can impact system performance greatly, particularily when you create a system hook instead of an application hook.  On that note, I would like to draw your attention to the ACTIVE property.  Just because the component exists, does not mean that it has a hook into the system.  The hook is dynamically created as needed based on the active property, this should make the components a little easier to use and manage.

Enjoy...

unit hooks;

interface

Uses Windows,SysUtils,Classes,Controls;

{$IFNDEF VER100} THIS CODE WAS WRITTEN FOR DELPHI 3, YOU SHOULD NOT USE IT WITH ANY OTHER VERSION{$ENDIF}

//*****************************************************************************
//
// Hooks Unit - Written For Delphi 3 By Clinton R. Johnson, using code written by
//              by Grahame Marsh - gsmarsh@aol.com, in an article for UNDU.
//
// Written April 5, 1998 - The code written by Clinton R. Johnson is donated to
// the public domain.  Code written by Grahame Marsh may have additional
// restrictions.
//
// Not all portions of this code has been tested in all circumstances.  Use at
// your own discression, it comes with no warrenty express or implied.
//
// Grahame Marsh is responsible for the MakeHookInstance and FreeHookInstance
// code (which is based on the MakeObjectInstance code in the Forms.pas unit
// from Borland if you want further examples).  His goal was to simplify the
// creation of Hooks in Delphi.  He acheived his goal, but I figured it could
// be even simpler.  No housekeeping tasks involved, no need to issue the low
// level calls to stay in the chain, etc.  Delphi is after all a visual enviroment,
// so I dislike writing code where I can just drop a component.  The only change
// I've made to his code was to rename the THOOKCALL structure to THOOKMSG, I
// found his name too confusing & kept mixing it up with the call instance itself.
//
// If you investigate this code, the most power is exposed once you get to the
// code level instead of visual implementation, but that's the way it should be
// in my opinion - multiple levels of complexity, this keeps the true novice from
// playing with things before they at least learn how to winow out & use the
// most powerful units.
//
// I've created a basic non-visual component to host the hook, and then created
// descendant objects for each hook.  I've not created any special messages
// structures for each handle, and I've not done any of the low level handing
// recommended.  I've left that up to you, to implement as you see best.
//
//*****************************************************************************

Type
  THookMsg = Packed record
               Code   : integer;
               WParam : WPARAM;
               LParam : LPARAM;
               Result : LResult
             end;

Type
  THook = Class;
  THookMethod = procedure (var HookMsg: THookMsg) of object;
  THookNotify = procedure (Hook : THook; var Hookmsg: THookMsg) of object;

  THook = Class(TComponent)
  Private
    fHook               : hHook;
    fHookProc           : Pointer;
    fOnPreExecute       : THookNotify;
    fOnPostExecute      : THookNotify;
    fActive             : Boolean;
    fLoadedActive       : Boolean;

    fThreadID           : Integer;

    Procedure SetActive(NewState : Boolean);
    Procedure SetThreadID(NewID : INteger);
    Procedure HookProc(Var HookMsg : THookMsg);
  Protected
    Procedure PreExecute(Var HookMsg : THookMsg; Var Handled : Boolean); Virtual;
    Procedure PostExecute(Var HookMsg : THookMsg); Virtual;
    Function AllocateHook : hHook; Virtual; Abstract;
    Procedure Loaded; Override;
  Public
    Constructor Create(Owner : TComponent); Override;
    Destructor Destroy; Override;
    Property ThreadID : Integer Read fThreadID Write SetThreadID Stored False;
    Property Active : Boolean Read fActive Write SetActive;
    Property OnPreExecute : THookNotify  Read fOnPreExecute Write fOnPreExecute;
    Property OnPostExecute : THookNotify  Read fOnPostExecute Write fOnPostExecute;
  Published
  End;

Type
  TCallWndProcHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TCallWndProcRetHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TCBTHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TDebugHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TGetMessageHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TJournalPlaybackHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TJournalRecordHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TKeyboardHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TMouseHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TMsgHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TShellHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

Type
  TSysMsgHook = Class(THook)
  Private
  Protected
  Public
    Function AllocateHook : hHook; Override;
  Published
    Property Active;
    Property OnPreExecute;
    Property OnPostExecute;
  End;

function  MakeHookInstance (Method: THookMethod): pointer;
procedure FreeHookInstance (ObjectInstance: pointer);

Procedure Register;

implementation

const
  InstanceCount = 313;  // set so that sizeof (TInstanceBlock) < PageSize

type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
                      Code: Byte;
                      Offset: Integer;
                    case Integer of
                      0: (Next: PObjectInstance);
                      1: (Method: THookMethod);
                    end;
Type
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
                     Next: PInstanceBlock;
                     Code: array[1..2] of Byte;
                     WndProcPtr: Pointer;
                     Instances: array[0..InstanceCount] of TObjectInstance;
                   end;
var
  InstBlockList : PInstanceBlock  = nil;
  InstFreeList  : PObjectInstance = nil;

function StdHookProc (Code, WParam: WPARAM; LParam: LPARAM): LResult; stdcall; assembler;

asm
  XOR     EAX,EAX
  PUSH    EAX
  PUSH    LParam
  PUSH    WParam
  PUSH    Code
  MOV     EDX,ESP
  MOV     EAX,[ECX].Longint[4]
  CALL    [ECX].Pointer
  ADD     ESP,12
  POP     EAX
end;

{ Allocate a hook method instance }
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;

function MakeHookInstance(Method: THookMethod): Pointer;

const
  BlockCode: array [1..2] of Byte = ($59, $E9);
  PageSize = 4096;

var
  Block: PInstanceBlock;
  Instance: PObjectInstance;

begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc (nil, PageSize, MEM_COMMIT,PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2],@StdHookProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method
end;

{ Free a hook method instance }
procedure FreeHookInstance (ObjectInstance: Pointer);

Begin
  if ObjectInstance <> nil then
  Begin
    PObjectInstance(ObjectInstance)^.Next := InstFreeList;
    InstFreeList := ObjectInstance
  End
End;

Constructor THook.Create(Owner : TComponent);

Begin
  Inherited Create(Owner);
  fHookProc := MakeHookInstance(HookProc);
  fActive := false;
  fLoadedActive := False;
  fHook := 0;
  ThreadID := GetCurrentThreadID;
End;

Destructor THook.Destroy;

Begin
  Active := False;
  FreeHookInstance(fHookProc);
  Inherited;
End;

Procedure THook.SetActive(NewState : Boolean);

Begin
  If (csLoading in componentState) Then
  Begin
    fLoadedActive := NewState;
  End Else If (fActive<>NewState) Then
  Begin
    fActive := NewState;
    Case (Active And (Not (csDesigning In ComponentState))) Of
      True : Begin
               fHook := AllocateHook;
               If (fHook=0) Then
               Begin
                 fActive := False;
                 Raise Exception.Create(Classname+' CREATION FAILED!');
               End;
             End;
      False : Begin
                If (FHook<>0) Then UnhookWindowsHookEx(fHook);
                fHook := 0;
              End;
    End;
  End;
End;

Procedure THook.SetThreadID(NewID : INteger);

Var
  IsActive              : Boolean;

Begin
  IsActive := fActive;
  Active := False;
  fThreadID := NewID;
  Active := IsActive;
End;

Procedure THook.Loaded;

Begin
  Inherited;
  Active := fLoadedActive;
End;

Procedure THook.HookProc(Var HookMsg : THookMsg);

Var
  Handled               : Boolean;

Begin
  Handled := False;
  PreExecute(HookMsg,Handled);
  If Not Handled Then
  Begin
    with HookMsg do Result := CallNextHookEx (fHook, Code, wParam, lParam);
    PostExecute(HookMsg);
  End;
End;

Procedure THook.PreExecute(Var HookMsg : THookMsg; Var Handled : Boolean);

Begin
  If Assigned(fOnPreExecute) then
  Begin
    fOnPreExecute(Self,HookMsg);
  End;
End;

Procedure THook.PostExecute(Var HookMsg : THookMsg);

Begin
  If Assigned(fOnPostExecute) then
  Begin
    fOnPostExecute(Self,HookMsg);
  End;
End;

Function TCallWndProcHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx (WH_CALLWNDPROC, fHookProc, HInstance, ThreadID);
End;

Function TCallWndProcRetHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_CALLWNDPROCRET,fHookProc,hInstance,ThreadID);
End;

Function TCBTHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_CBT,fHookProc,hInstance,ThreadID);
End;

Function TDebugHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_DEBUG,fHookProc,hInstance,ThreadID);
End;

Function TGetMessageHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_GETMESSAGE,fHookProc,hInstance,ThreadID);
End;

Function TJournalPlaybackHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_JOURNALPLAYBACK,fHookProc,hInstance,ThreadID);
End;

Function TJournalRecordHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_JOURNALRECORD,fHookProc,hInstance,ThreadID);
End;

Function TKeyboardHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_KEYBOARD,fHookProc,hInstance,ThreadID);
End;

Function TMouseHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_MOUSE,fHookProc,hInstance,ThreadID);
End;

Function TMsgHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_MSGFILTER,fHookProc,hInstance,ThreadID);
End;

Function TShellHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_SHELL,fHookProc,hInstance,ThreadID);
End;
Function TSysMsgHook.AllocateHook : hHook;

Begin
  Result := SetWindowsHookEx(WH_SYSMSGFILTER,fHookProc,hInstance,ThreadID);
End;

Procedure Register;

Begin
  RegisterComponents('Hooks',[TCallWndProcHook,TCallWndProcRetHook,TCBTHook,TDebugHook,TGetMessageHook,
                             TJournalPlaybackHook,TJournalRecordHook,TKeyboardHook,TMouseHook,TMsgHook,
                             TShellHook,TSysMsgHook]);
End;

end.