{==============================================================================

  Hook Components
  Copyright (C) 2000-2001 by Evgeny Kryukov
  All rights reserved

  All contents of this file and all other files included in this archive
  are Copyright (C) 2001 Evgeny Kryukov. Use and/or distribution of
  them requires acceptance of the License Agreement.

  See License.txt for licence information

===============================================================================}

unit KsHooks;

{$I KsCommonVer.Inc}
{$T-,W-,X+,P+}

interface

uses Windows, Messages, SysUtils, Classes, Controls, Forms;

const

  CM_RECREATEWINDOW  = CM_BASE + 222;
  CM_DESTROYHOOK     = CM_BASE + 223;

type
  THookMessageEvent = procedure (Sender: TObject; var Msg: TMessage;
    var Handled: Boolean) of object;

{ TKsHook class }

  TKsHook = class(TComponent)
  private
    FActive: Boolean;
    FControl: TWinControl;
    FControlHook: TObject;
    FBeforeMessage: THookMessageEvent;
    FAfterMessage: THookMessageEvent;
    function GetWinControl: TWinControl;
    function GetHookHandle: HWnd;
    procedure SetActive(Value: Boolean);
    procedure SetWinControl(Value: TWinControl);
    function DoUnhookControl: Pointer;
  protected
    procedure DoAfterMessage(var Msg: TMessage; var Handled: Boolean); dynamic;
    procedure DoBeforeMessage(var Msg: TMessage; var Handled: Boolean); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure HookControl;
    procedure UnhookControl;
    property HookWindow: HWnd read GetHookHandle;

    property Active: Boolean read FActive write SetActive default True;
    property WinControl: TWinControl read GetWinControl write SetWinControl;
    property BeforeMessage: THookMessageEvent read FBeforeMessage write FBeforeMessage;
    property AfterMessage: THookMessageEvent read FAfterMessage write FAfterMessage;
  end;

{ TKsHookComponent }

  TKsHookComponent = class(TComponent)
  private
    FActive: boolean;
    FHook: TKsHook;
    FControl: TWinControl;
    procedure DoAfter(Sender: TObject; var Msg: TMessage; var Handled: Boolean);
    procedure DoBefore(Sender: TObject; var Msg: TMessage; var Handled: Boolean);
    function GetControl: TWinControl;
    function GetHandle: HWnd;
    function GetForm: TForm;
    procedure SetActive(const Value: boolean);
    { }
  protected
    FHandled: boolean;
    procedure AfterControl(Sender: TObject; var Msg: TMessage; var Handled: Boolean); virtual;
    procedure MessageHandled;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

    procedure HookForm;
    procedure UnHookForm;

    property Active: boolean read FActive write SetActive;

    property Control: TWinControl read GetControl write FControl;
    property Handle: HWnd read GetHandle;
    property Form: TForm read GetForm;
  published
  end;

implementation {===============================================================}

uses Graphics;

type
  THack = class(TWinControl);
  THookOrder = (hoBeforeMsg, hoAfterMsg);

{ TControlHook }

  TControlHook = class(TObject)
  private
    FControl: TWinControl;
    FNewWndProc: Pointer;
    FPrevWndProc: Pointer;
    FList: TList;
    FDestroying: Boolean;
    procedure SetWinControl(Value: TWinControl);
    procedure HookWndProc(var AMsg: TMessage);
    procedure NotifyHooks(Order: THookOrder; var Msg: TMessage;
      var Handled: Boolean);
  public
    constructor Create;
    destructor Destroy; override;
    procedure HookControl;
    procedure UnhookControl;
    procedure AddHook(AHook: TKsHook);
    procedure RemoveHook(AHook: TKsHook);
    property WinControl: TWinControl read FControl write SetWinControl;
  end;

{ THookList }

  THookList = class(TList)
  private
    FHandle: HWnd;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    function FindControlHook(AControl: TWinControl): TControlHook;
    function GetControlHook(AControl: TWinControl): TControlHook;
    property Handle: HWnd read FHandle;
  end;

var
  HookList: THookList;

function GetHookList: THookList;
begin
  if HookList = nil then HookList := THookList.Create;
  Result := HookList;
end;

procedure DropHookList; far;
begin
  HookList.Free;
  HookList := nil;
end;

{ TControlHook }

constructor TControlHook.Create;
begin
  inherited Create;
  FList := TList.Create;
  FNewWndProc := MakeObjectInstance(HookWndProc);
  FPrevWndProc := nil;
  FControl := nil;
end;

destructor TControlHook.Destroy;
begin
  FDestroying := True;
  if Assigned(HookList) then
    if HookList.IndexOf(Self) >= 0 then HookList.Remove(Self);
  while FList.Count > 0 do RemoveHook(TKsHook(FList.Last));
  FControl := nil;
  FList.Free;
  FreeObjectInstance(FNewWndProc);
  FNewWndProc := nil;
  inherited Destroy;
end;

procedure TControlHook.AddHook(AHook: TKsHook);
begin
  if FList.IndexOf(AHook) < 0 then begin
    FList.Add(AHook);
    AHook.FControlHook := Self;
    WinControl := AHook.FControl;
  end;
  HookControl;
end;

procedure TControlHook.RemoveHook(AHook: TKsHook);
begin
  AHook.FControlHook := nil;
  FList.Remove(AHook);
  if FList.Count = 0 then UnhookControl;
end;

procedure TControlHook.NotifyHooks(Order: THookOrder; var Msg: TMessage;
  var Handled: Boolean);
var
  I: Integer;
begin
  if (FList.Count > 0) and Assigned(FControl) and
    not (FDestroying or (csDestroying in FControl.ComponentState)) then
    for I := FList.Count - 1 downto 0 do begin
      try
        if Order = hoBeforeMsg then
          TKsHook(FList[I]).DoBeforeMessage(Msg, Handled)
        else if Order = hoAfterMsg then
          TKsHook(FList[I]).DoAfterMessage(Msg, Handled);
      except
        Application.HandleException(Self);
      end;
      if Handled then Break;
    end;
end;

procedure TControlHook.HookControl;
var
  P: Pointer;
begin
  if Assigned(FControl) and not ((csDesigning in FControl.ComponentState) or
    (csDestroying in FControl.ComponentState) or FDestroying) then
  begin
    FControl.HandleNeeded;
    P := Pointer(GetWindowLong(FControl.Handle, GWL_WNDPROC));
    if (P <> FNewWndProc) then begin
      FPrevWndProc := P;
      SetWindowLong(FControl.Handle, GWL_WNDPROC, LongInt(FNewWndProc));
    end;
  end;
end;

procedure TControlHook.UnhookControl;
begin
  if Assigned(FControl) then begin
    if Assigned(FPrevWndProc) and FControl.HandleAllocated and
    (Pointer(GetWindowLong(FControl.Handle, GWL_WNDPROC)) = FNewWndProc) then
      SetWindowLong(FControl.Handle, GWL_WNDPROC, LongInt(FPrevWndProc));
  end;
  FPrevWndProc := nil;
end;

procedure TControlHook.HookWndProc(var AMsg: TMessage);
var
  Handled: Boolean;
begin
  Handled := False;
  if Assigned(FControl) then begin
    if (AMsg.Msg <> WM_QUIT) then NotifyHooks(hoBeforeMsg, AMsg, Handled);
    with AMsg do begin
      if (not Handled) or (Msg = WM_DESTROY) then
        try
          if Assigned(FPrevWndProc) then
            Result := CallWindowProc(FPrevWndProc, FControl.Handle, Msg,
              WParam, LParam)
          else
            Result := CallWindowProc(THack(FControl).DefWndProc,
              FControl.Handle, Msg, WParam, LParam);
        finally
          NotifyHooks(hoAfterMsg, AMsg, Handled);
        end;
      if Msg = WM_DESTROY then begin
        UnhookControl;
        if Assigned(HookList) and not (FDestroying or
          (csDestroying in FControl.ComponentState)) then
          PostMessage(HookList.FHandle, CM_RECREATEWINDOW, 0, Longint(Self));
      end;
    end;
  end;
end;

procedure TControlHook.SetWinControl(Value: TWinControl);
begin
  if Value <> FControl then begin
    UnhookControl;
    FControl := Value;
    if FList.Count > 0 then HookControl;
  end;
end;

{ THookList }

constructor THookList.Create;
begin
  inherited Create;
  FHandle := AllocateHWnd(WndProc);
end;

destructor THookList.Destroy;
begin
  while Count > 0 do TControlHook(Last).Free;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure THookList.WndProc(var Msg: TMessage);
var
  Hook: TControlHook;
begin
  try
    with Msg do begin
      if Msg = CM_RECREATEWINDOW then begin
        Hook := TControlHook(LParam);
        if (Hook <> nil) and (IndexOf(Hook) >= 0) then
          Hook.HookControl;
      end
      else if Msg = CM_DESTROYHOOK then begin
        Hook := TControlHook(LParam);
        if Assigned(Hook) and (IndexOf(Hook) >= 0) and
          (Hook.FList.Count = 0) then Hook.Free;
      end
      else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
    end;
  except
    Application.HandleException(Self);
  end;
end;

function THookList.FindControlHook(AControl: TWinControl): TControlHook;
var
  I: Integer;
begin
  if Assigned(AControl) then
    for I := 0 to Count - 1 do
      if (TControlHook(Items[I]).WinControl = AControl) then begin
        Result := TControlHook(Items[I]);
        Exit;
      end;
  Result := nil;
end;

function THookList.GetControlHook(AControl: TWinControl): TControlHook;
begin
  Result := FindControlHook(AControl);
  if Result = nil then begin
    Result := TControlHook.Create;
    try
      Add(Result);
      Result.WinControl := AControl;
    except
      Result.Free;
      raise;
    end;
  end;
end;

{ TKsHook }

constructor TKsHook.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FActive := True;
end;

destructor TKsHook.Destroy;
begin
  Active := False;
  WinControl := nil;
  inherited Destroy;
end;

procedure TKsHook.SetActive(Value: Boolean);
begin
  if FActive <> Value then
    if Value then HookControl else UnhookControl;
end;

function TKsHook.GetHookHandle: HWnd;
begin
  if Assigned(HookList) then Result := HookList.Handle
  else
    Result := INVALID_HANDLE_VALUE;
end;

procedure TKsHook.HookControl;
begin
  if Assigned(FControl) and not (csDestroying in ComponentState) then
    GetHookList.GetControlHook(FControl).AddHook(Self);
  FActive := True;
end;

function TKsHook.DoUnhookControl: Pointer;
begin
  Result := FControlHook;
  if Result <> nil then TControlHook(Result).RemoveHook(Self);
  FActive := False;
end;

procedure TKsHook.UnhookControl;
begin
  DoUnhookControl;
  FActive := False;
end;

function TKsHook.GetWinControl: TWinControl;
begin
  if Assigned(FControlHook) then Result := TControlHook(FControlHook).WinControl
  else Result := FControl;
end;

procedure TKsHook.DoAfterMessage(var Msg: TMessage; var Handled: Boolean);
begin
  if Assigned(FAfterMessage) then FAfterMessage(Self, Msg, Handled);
end;

procedure TKsHook.DoBeforeMessage(var Msg: TMessage; var Handled: Boolean);
begin
  if Assigned(FBeforeMessage) then FBeforeMessage(Self, Msg, Handled);
end;

procedure TKsHook.SetWinControl(Value: TWinControl);
var
  SaveActive: Boolean;
  Hook: TControlHook;
begin
  if Value <> WinControl then begin
    SaveActive := FActive;
    Hook := TControlHook(DoUnhookControl);
    FControl := Value;
    if Value <> nil then Value.FreeNotification(Self);
    if Assigned(Hook) and (Hook.FList.Count = 0) and Assigned(HookList) then
      PostMessage(HookList.Handle, CM_DESTROYHOOK, 0, Longint(Hook));
    if SaveActive then HookControl;
  end;
end;

{ TKsHookComponent ============================================================}

constructor TKsHookComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHook := TKsHook.Create(Self);
  FHook.BeforeMessage := DoBefore;
  FHook.AfterMessage := DoAfter;
end;

destructor TKsHookComponent.Destroy;
begin
  if FHook <> nil then FHook.Free;
  inherited Destroy;
end;

procedure TKsHookComponent.Loaded;
begin
  inherited Loaded;
  { Start Hook }
  if FActive then
    HookForm;
end;

procedure TKsHookComponent.HookForm;
begin
  { Only Owner }
  FHook.WinControl := FControl;
  FHook.Active := true;

  FActive := true;
end;

procedure TKsHookComponent.UnHookForm;
begin
  FHook.Active := false;

  FActive := false;
end;

{ Message Handlers }

procedure TKsHookComponent.DoBefore(Sender: TObject; var Msg: TMessage;
  var Handled: Boolean);
begin
  FHandled := Handled;
  try
    Dispatch(Msg);
  finally
    Handled := FHandled;
  end;
end;

procedure TKsHookComponent.DoAfter(Sender: TObject; var Msg: TMessage;
  var Handled: Boolean);
begin
  AfterControl(Sender, Msg, Handled);
end;

procedure TKsHookComponent.MessageHandled;
begin
  FHandled := true;
end;

procedure TKsHookComponent.AfterControl(Sender: TObject; var Msg: TMessage;
  var Handled: Boolean);
begin

end;

{ Properties }

function TKsHookComponent.GetHandle: HWnd;
begin
  if (FHook <> nil) and (FHook.WinControl <> nil) then
    Result := FHook.WinControl.Handle
  else
    Result := 0;
end;

function TKsHookComponent.GetForm: TForm;
begin
  if (FHook <> nil) and (FHook.WinControl <> nil) and (FHook.WinControl is TForm) then
    Result := FHook.WinControl as TForm
  else
    Result := nil;
end;

function TKsHookComponent.GetControl: TWinControl;
begin
  if (FHook <> nil) and (FHook.WinControl <> nil) then
    Result := FHook.WinControl
  else
    Result := nil;
end;

procedure TKsHookComponent.SetActive(const Value: boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    if FActive then
      HookForm
    else
      UnHookForm
  end;
end;

initialization
  HookList := nil;
finalization
  DropHookList;
end.
