unit xMouseHookVistaU;
// Version 1.0
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, xSystemTimerU, xClasses, ExtCtrls;
type
//==============================================================================
TMouseHook =
class(TObject)
private
BoolDelphiTimer : Boolean;
LButtonIsDown : boolean;
RButtonIsDown : Boolean;
MButtonIsDown: boolean;
LastPos : TPoint;
EMouseDown, EMouseUp : TMouseEvent;
EMouseMove : TMouseMoveEvent;
FHookStarted : Boolean;
FTimer : TSystemTimer;
FTimerDelphi : TTimer;
FEventMouseDownMMCaster : TMulticaster;
FEventMouseUpMMCaster : TMulticaster;
FEventMouseMoveMMCaster : TMulticaster;
function GetShift : TShiftState;
procedure OnTimer(Sender : TObject);
procedure Set_EventMouseMove(
const Value: TMouseMoveEvent);
procedure Set_EventMouseDown(
const Value: TMouseEvent);
procedure Set_EventMouseUp(
const Value: TMouseEvent);
procedure CastMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure CastMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure CastMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
public
constructor create;
destructor destroy;
override;
function Start : Boolean;
function stop : boolean;
property Timer : TSystemTimer
read FTimer;
property EventMouseDown : TMouseEvent
read EMouseDown
write EMouseDown;
property EventMouseUp : TMouseEvent
read EMouseUp
write EMouseUp;
property EventMouseMove : TMouseMoveEvent
read EMouseMove
write EMouseMove;
procedure RemoveAllForAnObject(anObject: TObject);
end;
//==============================================================================
implementation
//==============================================================================
//==============================================================================
constructor TMouseHook.create;
begin
inherited;
BoolDelphiTimer := true;
FEventMouseDownMMCaster := TMultiCaster.create(self);
FEventMouseUpMMCaster := TMultiCaster.create(self);
FEventMouseMoveMMCaster := TMultiCaster.Create(self);
FHookStarted := False;
LButtonIsDown := false;
RButtonIsDown := false;
MButtonIsDown := false;
if BoolDelphiTimer
then begin
FTimerDelphi := TTimer.Create(
nil);
FTimerDelphi.Enabled := false;
FtimerDelphi.OnTimer := self.OnTimer;
FTimerDelphi.Interval := 50;
end else begin
FTimer := TSystemTimer.Create;
FTimer.Interval := 10;
FTimer.OnTimer := self.OnTimer;
end;
end;
//==============================================================================
destructor TMouseHook.destroy;
begin
if FHookStarted
then self.stop;
if BoolDelphiTimer
then begin
if Assigned(FTimerDelphi)
then FTimerDelphi.Free;
end else begin
Timer.OnTimer :=
nil;
end;
FEventMouseDownMMCaster.free;
FEventMouseUpMMCaster.free;
FEventMouseMoveMMCaster.free;
inherited;
end;
//==============================================================================
procedure TMouseHook.OnTimer(Sender : TObject);
var
s :
String;
MouseButton : TMouseButton;
X, Y : Integer;
Point : TPoint;
NewLButtonIsDown, NewRButtonIsDown, NewMButtonIsDown : Boolean;
i : Integer;
begin
if not FHookStarted
then exit;
GetCursorPos(Point);
X := Point.X;
Y := Point.Y;
NewLButtonIsDown := false;
NewRButtonIsDown := false;
NewMButtonIsDown := false;
if (GetAsynckeyState(vk_lbutton) <> 0)
then begin
NewLButtonIsDown := True;
end;
if (GetAsynckeyState(vk_Rbutton) <> 0)
then begin
NewRButtonIsDown := true;
end;
if (GetAsynckeyState(vk_mbutton) <> 0)
then begin
NewMButtonIsDown := true;
end;
// for i := 0 to 10000 do begin
// if i = 145 then continue;
// if (GetAsynckeyState(i ) <> 0) then begin
// beep;
// end;
// end;
//==========================================================================
// Left Button Down
if NewLButtonIsDown
and not LButtonIsDown
then begin
LButtonIsDown := true;
MouseButton := mbLeft;
if Assigned(EMouseDown)
then EMouseDown(self,MouseButton, GetShift,X, Y);
end;
// L Button Down
// Left Button Up
if not NewLButtonIsDown
and LButtonIsDown
then begin
LButtonIsDown := false;
MouseButton := mbLeft;
if Assigned(EMouseUP)
then EMouseUP(self,MouseButton, GetShift,X, Y);
end;
// L Button Up
//==========================================================================
// Right Button Down
if NewRButtonIsDown
and not RButtonIsDown
then begin
RButtonIsDown := true;
MouseButton := mbRight;
if Assigned(EMouseDown)
then EMouseDown(self,MouseButton, GetShift,X, Y);
end;
// R Button Down
// Right Button Up
if not NewRButtonIsDown
and RButtonIsDown
then begin
RButtonIsDown := false;
MouseButton := mbRight;
if Assigned(EMouseUP)
then EMouseUP(self,MouseButton, GetShift,X, Y);
end;
// R Button Up
//==========================================================================
// Middle Button Down
if NewMButtonIsDown
and not MButtonIsDown
then begin
MButtonIsDown := true;
MouseButton := mbMiddle;
if Assigned(EMouseDown)
then EMouseDown(self,MouseButton, GetShift,X, Y);
end;
// R Button Down
// Middle Button Up
if not NewMButtonIsDown
and MButtonIsDown
then begin
MButtonIsDown := false;
MouseButton := mbmiddle;
if Assigned(EMouseUP)
then EMouseUP(self,MouseButton, GetShift,X, Y);
end;
// R Button Up
//==========================================================================
// // Mouse Wheel
// if (EventStrut.message = WM_MOUSEWHEEL) then begin
// s := 'Mouse Wheel at X pos ' +
// IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH);
// end; // Mouse Wheel
//==========================================================================
// Mouse Move
if (X <> LastPos.x)
or
(Y <> LastPos.Y)
then begin
if Assigned(EMouseMove)
then EMouseMove(Self, GetShift,X, Y);
end;
// MouseMove
LastPos.X := x;
LastPos.Y := y;
end;
// OnTimer (TMouseHook)
//==============================================================================
function TMouseHook.GetShift : TShiftState;
begin
result := [];
if self.LButtonIsDown
then Include(result,ssleft);
if self.RButtonIsDown
then Include(result,ssright);
if self.MButtonIsDown
then Include(result,ssmiddle);
end;
// SetShift (TMouseHook)
//==============================================================================
function TMouseHook.Start : Boolean;
begin
result := false;
if FHookStarted
then exit;
if BoolDelphiTimer
then begin
FTimerDelphi.Enabled := true;
FHookStarted := true;
end else begin
FTimer.StartTimer;
FHookStarted := true;
end;
result := true;
end;
// Start (TMouseHook)
//==============================================================================
function TMouseHook.stop : boolean;
begin
if BoolDelphiTimer
then begin
FTimerDelphi.Enabled := false;
FHookStarted := false;
end else begin
FTimer.StopTimer;
FHookStarted := False;
end;
end;
// stop (TMouseHook)
//==============================================================================
//==============================================================================
//==============================================================================
procedure TMouseHook.Set_EventMouseMove(
const Value: TMouseMoveEvent);
begin
if not assigned(Value)
then showmessage('
Bitte remove benutzen')
else
FEventMouseMoveMMCaster.add(TMethod(Value));
end;
//==============================================================================
procedure TMouseHook.Set_EventMouseDown(
const Value: TMouseEvent);
begin
if not assigned(Value)
then showmessage('
Bitte remove benutzen')
else
FEventMouseDownMMCaster.add(TMethod(Value));
end;
//==============================================================================
procedure TMouseHook.Set_EventMouseUp(
const Value: TMouseEvent);
begin
if not assigned(Value)
then showmessage('
Bitte remove benutzen')
else
FEventMouseUpMMCaster.add(TMethod(Value));
end;
//==============================================================================
//==============================================================================
// entfernt ein Object aus ALLEN Multicastern
//==============================================================================
procedure TMouseHook.RemoveAllForAnObject(anObject: TObject);
begin
FEventMouseMoveMMCaster.RemoveAllForAnObject(anObject);
FEventMouseDownMMCaster.RemoveAllForAnObject(anObject);
FEventMouseUpMMCaster.RemoveAllForAnObject(anObject);
end;
// RemoveAllForAnObject
//==============================================================================
procedure TMouseHook.CastMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var i : Integer;
Method : TMouseMoveEvent;
begin
for i := 0
to FEventMouseMoveMMCaster.count - 1
do begin
Method := TMouseMoveEvent(FEventMouseMoveMMCaster[i]);
Method(Self, Shift, X, Y);
end;
end;
//==============================================================================
procedure TMouseHook.CastMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var i : Integer;
Method : TMouseEvent;
begin
for i := 0
to FEventMouseDownMMCaster.count - 1
do begin
Method := TMouseEvent(FEventMouseDownMMCaster[i]);
Method(Self, Button, Shift, X, Y);
end;
end;
// CastMouseDown
//==============================================================================
procedure TMouseHook.CastMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var i : Integer;
Method : TMouseEvent;
begin
for i := 0
to FEventMouseUpMMCaster.count - 1
do begin
Method := TMouseEvent(FEventMouseUpMMCaster[i]);
Method(Self, Button, Shift, X, Y);
end;
end;
// CastMouseUp
end.