jvwndprochook.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvWndProcHook.PAS, released on 2002-11-01.

The Initial Developer of the Original Code is Peter Th鰎nqvist [peter3 at sourceforge dot net]
Portions created by Peter Th鰎nqvist are Copyright (C) 2002 Peter Th鰎nqvist.
All Rights Reserved.

Contributor(s):
Remko Bonte <remkobonte att myrealbox dott com>

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
  * (rb) object naming could be improved, for example
      TJvWndProcHook             -> TJvHookController
      TJvWndProcHook.FHookInfos  -> TJvHookController.Items
      TJvHookInfos               -> TJvHookItem, TJvHookInfo, TJvHook
      TJvHookInfo                -> TJvHookData
-----------------------------------------------------------------------------}
// $Id: JvWndProcHook.pas,v 1.22 2005/02/17 10:21:17 marquardt Exp $

unit JvWndProcHook;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, SysUtils, Controls, Forms, Classes,
  JvComponent;

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

  TJvHookOrder = (hoBeforeMsg, hoAfterMsg);

  TJvWindowHook = class(TJvComponent)
  private
    FActive: Boolean;
    FControl: TControl;
    FBeforeMessage: TJvHookMessageEvent;
    FAfterMessage: TJvHookMessageEvent;
    procedure SetActive(Value: Boolean);
    procedure SetControl(Value: TControl);
    function IsForm: Boolean;
    function NotIsForm: Boolean;
    procedure ReadForm(Reader: TReader);
    procedure WriteForm(Writer: TWriter);
    procedure SetAfterMessage(const Value: TJvHookMessageEvent);
    procedure SetBeforeMessage(const Value: TJvHookMessageEvent);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function DoAfterMessage(var Msg: TMessage): Boolean; dynamic;
    function DoBeforeMessage(var Msg: TMessage): Boolean; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure HookControl;
    procedure UnHookControl;
  published
    property Active: Boolean read FActive write SetActive default True;
    property Control: TControl read FControl write SetControl stored NotIsForm;
    property BeforeMessage: TJvHookMessageEvent read FBeforeMessage write SetBeforeMessage;
    property AfterMessage: TJvHookMessageEvent read FAfterMessage write SetAfterMessage;
  end;

function RegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean; overload;
function RegisterWndProcHook(AHandle: HWND; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean; overload;
function UnRegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean; overload;
function UnRegisterWndProcHook(AHandle: HWND; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean; overload;
procedure ReleaseObj(AObject: TObject);

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvWndProcHook.pas,v $';
    Revision: '$Revision: 1.22 $';
    Date: '$Date: 2005/02/17 10:21:17 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation


type
  PJvHookInfo = ^TJvHookInfo;
  TJvHookInfo = record
    Hook: TJvControlHook;
    Next: PJvHookInfo;
  end;

  PHookInfoList = ^THookInfoList;
  THookInfoList = array [0..MaxInt div 4 - 1] of PJvHookInfo;

  TJvWndProcHook = class;

  TJvHookInfos = class(TObject)
  private
    FFirst: array [TJvHookOrder] of PJvHookInfo;
    FLast: array [TJvHookOrder] of PJvHookInfo;
    { FStack is filled with HookInfos that are being processed in WindowProc
      procedures. On entrance of the WindowProc the size increases, on exit it
      decreases. Thus when a message is send inside a hook handler, the stack
      size increases.

      We use a stack to be able to register and unregister hooks inside hook
      handlers, see \dev\DUnit for some examples.

      The odd members in the stack are hoBeforeMsg hooks, the even members in
      the list are hoAfterMsg hooks
    }
    FStack: PHookInfoList;
    FStackCapacity: Integer;
    FStackCount: Integer;
    FHandle: HWND;
    FControl: TControl;
    FControlDestroyed: Boolean;
    FOldWndProc: TWndMethod;
    FHooked: Boolean;
    FController: TJvWndProcHook;
    procedure SetController(const Value: TJvWndProcHook);
  protected
    procedure WindowProc(var Msg: TMessage);
    procedure HookControl;
    procedure UnHookControl;
    procedure IncDepth;
    procedure DecDepth;
  public
    constructor Create(AControl: TControl); overload;
    constructor Create(AHandle: HWND); overload;
    destructor Destroy; override;
    procedure Add(const Order: TJvHookOrder; Hook: TJvControlHook);
    procedure Delete(const Order: TJvHookOrder; Hook: TJvControlHook);
    procedure ControlDestroyed;
    property Control: TControl read FControl;
    { Prevent calls to WndProcHook by using property Controller;
      TJvHookInfos may live longer than WndProcHook }
    property Controller: TJvWndProcHook read FController write SetController;
    property Handle: HWND read FHandle;
  end;

  TJvWndProcHook = class(TComponent)
  private
    FHookInfos: TList;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function IndexOf(AControl: TControl): Integer; overload;
    function IndexOf(AHandle: HWND): Integer; overload;
    function Find(AControl: TControl): TJvHookInfos; overload;
    function Find(AHandle: HWND): TJvHookInfos; overload;

    procedure Remove(AHookInfos: TJvHookInfos);
    procedure Add(AHookInfos: TJvHookInfos);
  public
    destructor Destroy; override;
    function RegisterWndProc(AControl: TControl; Hook: TJvControlHook;
      const Order: TJvHookOrder): Boolean; overload;
    function RegisterWndProc(AHandle: HWND; Hook: TJvControlHook;
      const Order: TJvHookOrder): Boolean; overload;
    function UnRegisterWndProc(AControl: TControl; Hook: TJvControlHook;
      const Order: TJvHookOrder): Boolean; overload;
    function UnRegisterWndProc(AHandle: HWND; Hook: TJvControlHook;
      const Order: TJvHookOrder): Boolean; overload;
  end;

  TJvReleaser = class(TObject)
  private
    FHandle: HWND;
    FReleasing: TList;
    function GetHandle: HWND;
    procedure CMRelease(var Msg: TMessage); message CM_RELEASE;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure DefaultHandler(var Msg); override;
    class function Instance: TJvReleaser;
    procedure Release(AObject: TObject);
    property Handle: HWND read GetHandle;
  end;

var
  GJvWndProcHook: TJvWndProcHook = nil;
  GReleaser: TJvReleaser = nil;

function WndProcHook: TJvWndProcHook;
begin
  if GJvWndProcHook = nil then
    GJvWndProcHook := TJvWndProcHook.Create(nil);
  Result := GJvWndProcHook;
end;

function RegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean;
begin
  Result := WndProcHook.RegisterWndProc(AControl, Hook, Order);
end;

function RegisterWndProcHook(AHandle: HWND; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean;
begin
  Result := WndProcHook.RegisterWndProc(AHandle, Hook, Order);
end;

function UnRegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean;
begin
  Result := WndProcHook.UnRegisterWndProc(AControl, Hook, Order);
end;

function UnRegisterWndProcHook(AHandle: HWND; Hook: TJvControlHook;
  const Order: TJvHookOrder): Boolean;
begin
  Result := WndProcHook.UnRegisterWndProc(AHandle, Hook, Order);
end;

procedure ReleaseObj(AObject: TObject);
begin
  TJvReleaser.Instance.Release(AObject);
end;

//=== { TJvWndProcHook } =====================================================

procedure TJvWndProcHook.Add(AHookInfos: TJvHookInfos);
var
  I: Integer;
begin
  I := FHookInfos.IndexOf(AHookInfos);
  if I < 0 then
    FHookInfos.Add(AHookInfos);
end;

destructor TJvWndProcHook.Destroy;
begin
  if FHookInfos <> nil then
  begin
    while FHookInfos.Count > 0 do
      { If you free a hook info, it will remove itself from the list }
      TJvHookInfos(FHookInfos[0]).Free;

    FHookInfos.Free;
  end;
  inherited Destroy;
end;

function TJvWndProcHook.Find(AHandle: HWND): TJvHookInfos;
var
  I: Integer;
begin
  I := IndexOf(AHandle);
  if I < 0 then
    Result := nil
  else
    Result := TJvHookInfos(FHookInfos[I]);
end;

function TJvWndProcHook.Find(AControl: TControl): TJvHookInfos;
var
  I: Integer;
begin
  I := IndexOf(AControl);
  if I < 0 then
    Result := nil
  else
    Result := TJvHookInfos(FHookInfos[I]);
end;

function TJvWndProcHook.IndexOf(AHandle: HWND): Integer;
begin
  { The following code introduces a problem:

    The handle of a control may change (by a call to RecreateWnd for example)
    thus you may find a Ctrl by calling FindControl(AHandle) in RegisterWndProcHook
    and then it's possible to _not_ find the same control in UnRegisterWndProcHook,
    thus hooks may be left open unwanted.

    Maybe there is a better way to identify hooks than (Handle x Hook x Order) or
    ( Ctrl x Hook x Order ) (?)
  }

  {Ctrl := FindControl(AHandle);
  if Ctrl <> nil then
  begin
    Result := IndexOf(Ctrl);
    if Result >= 0 then
      Exit;
  end;}

  Result := 0;
  while (Result < FHookInfos.Count) and
    (TJvHookInfos(FHookInfos[Result]).Handle <> AHandle) do
    Inc(Result);
  if Result = FHookInfos.Count then
    Result := -1;
end;

function TJvWndProcHook.IndexOf(AControl: TControl): Integer;
begin
  Result := 0;
  while (Result < FHookInfos.Count) and
    (TJvHookInfos(FHookInfos[Result]).Control <> AControl) do
    Inc(Result);
  if Result = FHookInfos.Count then
    Result := -1;
end;

procedure TJvWndProcHook.Notification(AComponent: TComponent;
  Operation: TOperation);
var
  I: Integer;
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FHookInfos <> nil) and (AComponent is TControl) then
  begin
    I := IndexOf(TControl(AComponent));
    if I >= 0 then
      { Be careful because the TJvHookInfos object might be in it's
        WindowProc procedure, for example when hooking a form and handling
        a CM_RELEASE message. The TJvHookInfos object can't be destroyed then.

        General rule must be that only TJvHookInfos can destroy itself, and
        remove it from the TJvWndProcHook.FHookInfos list.
      }
      TJvHookInfos(FHookInfos[I]).ControlDestroyed;
  end;
end;

function TJvWndProcHook.RegisterWndProc(AControl: TControl;
  Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;
var
  HookInfos: TJvHookInfos;
begin
  Result := False;
  if not Assigned(AControl) or
    (csDestroying in AControl.ComponentState) or not Assigned(Hook) then
    Exit;

  if FHookInfos = nil then
    FHookInfos := TList.Create;

  // find the control:
  HookInfos := Find(AControl);
  if not Assigned(HookInfos) then
  begin
    HookInfos := TJvHookInfos.Create(AControl);
    HookInfos.Controller := Self;
    AControl.FreeNotification(Self);
  end;
  HookInfos.Add(Order, Hook);

  Result := True;
end;

function TJvWndProcHook.RegisterWndProc(AHandle: HWND;
  Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;
var
  HookInfos: TJvHookInfos;
begin
  Result := False;
  if not Assigned(Hook) then
    Exit;
  if FHookInfos = nil then
    FHookInfos := TList.Create;

  // find the control:
  HookInfos := Find(AHandle);
  if not Assigned(HookInfos) then
  begin
    HookInfos := TJvHookInfos.Create(AHandle);
    HookInfos.Controller := Self;
  end;
  HookInfos.Add(Order, Hook);

  Result := True;
end;

procedure TJvWndProcHook.Remove(AHookInfos: TJvHookInfos);
var
  I: Integer;
begin
  I := FHookInfos.IndexOf(AHookInfos);
  if I >= 0 then
    FHookInfos.Delete(I);
end;

function TJvWndProcHook.UnRegisterWndProc(AHandle: HWND;
  Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;
var
  HookInfos: TJvHookInfos;
begin
  Result := False;
  if not Assigned(Hook) or not Assigned(FHookInfos) then
    Exit;
  // find the control:
  HookInfos := Find(AHandle);
  Result := Assigned(HookInfos);
  if Result then
    // Maybe delete HookInfos if HookInfos.FFirst.. = nil?
    HookInfos.Delete(Order, Hook);
end;

function TJvWndProcHook.UnRegisterWndProc(AControl: TControl;
  Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;
var
  HookInfos: TJvHookInfos;
begin
  Result := False;
  if not Assigned(AControl) or not Assigned(Hook) or not Assigned(FHookInfos) then
    Exit;
  // find the control:
  HookInfos := Find(AControl);
  Result := Assigned(HookInfos);
  if Result then
    // Maybe delete HookInfos if HookInfos.FFirst.. = nil?
    HookInfos.Delete(Order, Hook);
end;

//=== { TJvHookInfos } =======================================================

procedure TJvHookInfos.Add(const Order: TJvHookOrder; Hook: TJvControlHook);
var
  HookInfo: PJvHookInfo;
  I: Integer;
begin
  New(HookInfo);
  HookInfo.Hook := Hook;
  HookInfo.Next := nil;

  { Some bookkeeping }
  if FFirst[Order] = nil then
    FFirst[Order] := HookInfo;

  if FLast[Order] <> nil then
    FLast[Order].Next := HookInfo;

  FLast[Order] := HookInfo;

  { Update the stack }
  if Order = hoBeforeMsg then
    I := 0
  else
    I := 1;
  while I < FStackCount * 2 do
  begin
    if FStack[I] = nil then
      FStack[I] := HookInfo;
    Inc(I, 2);
  end;

  HookControl;
end;

procedure TJvHookInfos.ControlDestroyed;
begin
  if FControlDestroyed then
    Exit;

  { This procedure is called when we get notified that the control we are hooking
    is destroyed. We can get this notification from TJvWindowHook.Notification
    or in TJvHookInfos.WindowProc.

    Problem is that the control might be destroyed when we are in the
    TJvHookInfos.WindowProc. This can occur for example with the CM_RELEASE
    message for a TCustomForm. In this case we have to be extra careful to not
    call destroyed components via HookInfo.Hook(Msg) etc. Also in that case
    we can't free the TJvHookInfos yet, thus we use ReleaseObj.
  }

  FControlDestroyed := True;
  FOldWndProc := nil;

  { Remove this TJvHookInfos object from the HookInfo list of Controller }
  Controller := nil;
  ReleaseObj(Self);
end;

constructor TJvHookInfos.Create(AControl: TControl);
begin
  inherited Create;
  FControl := AControl;
  FillChar(FFirst, SizeOf(FFirst), 0);
  FillChar(FLast, SizeOf(FLast), 0);
  //FillChar(FStack, SizeOf(FStack), 0);
  //FillChar(FStackCapacity, SizeOf(FStackCapacity), 0);
  //FillChar(FStackCount, SizeOf(FStackCount), 0);
end;

constructor TJvHookInfos.Create(AHandle: HWND);
begin