Transparentes Bild soll nur an bestimmten stellen angeklickt

[Robert Marquardt]

Hier eine aeltere Komponente von mir. Die ist nicht ideal konstruiert, aber funktioniert.
Wichtig ist, das PicUp und PicDown sich moeglichst nur in der Farbgebung unterscheiden.
Es ist sehr unangenehm wenn das Bild sich beim Betreten mit der Maus aendert und sich dabei der Hittest veraendert.
Damit ist die Maus wieder draussen und das Bild schaltet zurueck usw usf.

Mit CM_MOUSEENTER und CM_MOUSELEAVE gibt es in Delphi ein paar Macken. Manchmal wird das CM_MOUSELEAVE nicht generiert.
Man kann beispielsweise ueber ein Kontextmenue das man mit ESC abbricht die Komponente heimlich verlassen.

Delphi-Quellcode:

unit MouseImage;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TOnMouseEvent = procedure(Msg: TWMMouse) of object;

  TMouseImage = class(TImage)
  private
    FOnMouseEnter: TOnMouseEvent;
    FOnMouseLeave: TOnMouseEvent;
    FPicDown: TPicture;
    FPicUp: TPicture;
    FDown: Boolean;
    FEntered: Boolean;
    procedure SetPicDown(Value: TPicture);
    procedure SetPicUp(Value: TPicture);
    procedure SetDown(Value: Boolean);
    procedure SetEntered(Value: Boolean);
  protected
    procedure Loaded; override;
    procedure WMMouseEnter(var Msg: TWMMouse); message CM_MOUSEENTER;
    procedure WMMouseLeave(var Msg: TWMMouse); message CM_MOUSELEAVE;
    procedure CMHitTest(var Msg: TWMMouse); message CM_HITTEST;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Down: Boolean read FDown write SetDown;
    property Entered: Boolean read FEntered write SetEntered;
    property PicDown: TPicture read FPicDown write SetPicDown;
    property PicUp: TPicture read FPicUp write SetPicUp;
    property OnMouseEnter: TOnMouseEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TOnMouseEvent read FOnMouseLeave write FOnMouseLeave;
  end;

procedure Register;

implementation

{$R *.RES}

(*******************************************************************************)

procedure Register;
begin
  RegisterComponents('3rdParty', [TMouseImage]);
end;

(*******************************************************************************)

constructor TMouseImage.Create;
begin
  inherited;
  FPicDown := TPicture.Create;
  FPicUp   := TPicture.Create;
  FDown    := False;
  FEntered := False;
end;

(*******************************************************************************)

destructor TMouseImage.Destroy;
begin
  FreeAndNil(FPicDown);
  FreeAndNil(FPicUp);
  inherited;
end;

(*******************************************************************************)

procedure TMouseImage.Loaded;
begin
  Picture.Assign(PicUp);
end;

(*******************************************************************************)

procedure TMouseImage.WMMouseEnter(var Msg: TWMMouse);
var
 P: TControl;
begin
  inherited;
  P := Self;
  repeat
    P := P.Parent;
  until (P = nil) or (P is TForm);
  if (P = nil) or TForm(P).Active then
  begin
    Entered := True;
    if Assigned(FOnMouseEnter) then
      FOnMouseEnter(Msg);
  end;
end;

(*******************************************************************************)

procedure TMouseImage.WMMouseLeave(var Msg: TWMMouse);
var
 P: TControl;
begin
  inherited;
  P := Self;
  repeat
    P := P.Parent;
  until (P = nil) or (P is TForm);
  if (P = nil) or TForm(P).Active then
  begin
    Entered := False;
    if Assigned(FOnMouseLeave) then
      FOnMouseLeave(Msg);
  end;
end;

(*******************************************************************************)

procedure TMouseImage.CMHitTest(var Msg: TWMMouse);
begin
  inherited;
  if Assigned(PicUp) and Assigned(PicUp.Bitmap) and Transparent and
    (Msg.XPos < PicUp.Bitmap.Width) and (Msg.YPos < PicUp.Bitmap.Height) and
    (PicUp.Bitmap.Canvas.Pixels[Msg.XPos, Msg.YPos] = (Picture.Bitmap.TransparentColor and $FFFFFF)) then
    Msg.Result := 0;
end;

(*******************************************************************************)

procedure TMouseImage.SetPicUp(Value: TPicture);
begin
  FPicUp.Assign(Value);
end;

(*******************************************************************************)

procedure TMouseImage.SetPicDown(Value: TPicture);
begin
  FPicDown.Assign(Value);
end;

(*******************************************************************************)

procedure TMouseImage.SetDown(Value: Boolean);
begin
  FDown   := Value;
  Entered := Value;
end;

(*******************************************************************************)

procedure TMouseImage.SetEntered(Value: Boolean);
begin
  FEntered := Value;
  if Down or Entered then
    Picture.Assign(PicDown)
  else
    Picture.Assign(PicUp);
end;

end.

Die Tests in WMMouseEnter und WMMouseLeave stellen sicher das die Komponente nur auf die Maus reagiert wenn sie auf der aktiven Form ist.
Es ist selten gewuenscht das die komponente reagiert, wenn sie auf einer im Hintergrund liegenden Form liegt.
CMHitTest ist das Herz der Komponente. Es wird getestet ob die Maus wirklich ueber dem Komponentenrechteck liegt und ob der Pixel unter dem Cursor transparent ist.
inherited; hat bereits dafuer gesorgt, das Msg.Result 1 ist, da dies die Standardantwort eines TImage ist.
Die Konsequenz ist, das die Komponente jetzt auch fuer Klicks transparent ist.