Message abfangen

[Jens Schumann]

Hallo,
etwas besseres als das hier ist mir auf die Schnelle nicht eingefallen.
Evt hilft es ja weiter

Delphi-Quellcode:

unit JsMessageInterceptor;

interface

uses
  Messages, SysUtils, Classes, Forms, Controls;

type
  TMessageEvent = procedure(Sender : TObject;var Message : TMessage) of object;
  TMessageEventExt = procedure(Sender : TObject;var Message : TMessage; var Cancel : Boolean) of object;

  TJsMessageInterceptor = class(TComponent)
  private
    { Private-Deklarationen }
    FOwnerWndProc : TWndMethod;
    FOnNCHitTest: TMessageEvent;
    FOnBeforeMsg: TMessageEventExt;
  protected
    { Protected-Deklarationen }
    procedure Loaded; override;
    procedure DoNCHitTest(var Message : TMessage); dynamic;
    procedure DoBeforeMsg(var Message : TMessage; var Cancel : Boolean); dynamic;
    procedure WndProc(var Message: TMessage); virtual;
  public
    { Public-Deklarationen }
  published
    { Published-Deklarationen }
    property OnBeforeMsg : TMessageEventExt read FOnBeforeMsg write FOnBeforeMsg;
    property OnNCHitTest : TMessageEvent   read FOnNCHitTest write FOnNCHitTest;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('DelphiPraxis', [TJsMessageInterceptor]);
end;

{ TJsMessageDispatcher }

procedure TJsMessageInterceptor .DoBeforeMsg(var Message: TMessage; var Cancel: Boolean);
begin
  If Assigned(FOnBeforeMsg) then
    FOnBeforeMsg(Self,Message,Cancel);
end;

procedure TJsMessageInterceptor .DoNCHitTest(var Message: TMessage);
begin
  If Assigned(FOnNCHitTest) then
    FOnNCHitTest(Self,Message);
end;

procedure TJsMessageInterceptor .Loaded;
begin
  inherited Loaded;
  If (Owner<>Nil) and (Owner is TWinControl) then
    begin
    FOwnerWndProc:=TWinControl(Owner).WindowProc;
    TWinControl(Owner).WindowProc:=WndProc;
    end;
end;

procedure TJsMessageInterceptor .WndProc(var Message: TMessage);
var
  Cancel : Boolean;
begin
  inherited;
  Cancel:=False;
  DoBeforeMsg(Message,Cancel);
  If Not Cancel then
    begin
    If Assigned(FOwnerWndProc) then
      FOwnerWndProc(Message);
    Case Message.Msg of
      WM_NCHITTEST : begin
                     DoNCHitTest(Message);
                     end;
      // hier können weitere Messages bearbeitet werden.
      end;
    end;
end;

end.

Und ein Beispiel dazu

Delphi-Quellcode:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, JsMessageDispatcher, StdCtrls ;

type
  TForm1 = class(TForm)
    JsMessageDispatcher1: TJsMessageInterceptor ;
    Label1: TLabel;
    Label2: TLabel;
    procedure JsMessageInterceptor1NCHitTest(Sender: TObject;
      var Message: TMessage);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.JsMessageInterceptor1NCHitTest(Sender: TObject;
  var Message: TMessage);
begin
  if  (Message).Result = htClient then
    Message.Result := htCaption;
end;

end.