Message abfangen

[Mystic]

Ich programmiere gerade an einer Komponente.

Wenn sie auf dem Formular platziert ist, soll sie künftig die Message WM_NCHITTEST an das Formular abfangen und selber handlen (Die Message soll dann nicht mehr vom Formular gehandelt werden!).

Wie mache ich das?

[nailor]

ich glaube nicht, dass das _sauber_ durch eine Komponente möglich ist.

[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.

[Mystic]

Danke. Ich hatte es vorher mit Subclassing ( TForm = class(Forms.TForm) ) gemacht. Allerdings war das mit etwas zu unsauber.

[Jens Schumann]

Zitat von Mystic:

... Subclassing ( TForm = class(Forms.TForm) ) gemacht. Allerdings war das mit etwas zu unsauber.

Das ist kein SubClassing, sondern eher die klassische Vererbung.

SubClassing verwende ich in meinem Beispiel. SubClassing bedeutet das man Botschaften, die für ein fremdes Fenster bestimmt sind abfängt und evt. verändert. Dadurch verändert sich auch das Verhalten des fremden Fensters. Das kann z.B. dadurch passieren, das man die registrierte Fensterprocedure austauscht. Das´geschieht in meinem Beispiel genau dort

Delphi-Quellcode:

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