Souris3D

3Dconnexion commercialise une souris 3D
http://www.3dconnexion.com/3dmouse/images/3D-handweb_001.jpg.

Comme j'ai eu l'occasion de l'utiliser dans un projet Delphi, je vous livre ici son interface Delphi :)

Le principe de cette unité est d'avoir un objet TMouse3D global et unique qui reçois les événements de la souris 3D.
Pour chaque contrôle qui doit réagir à la souris, il suffit de lui associer un TMouse3DEvent qui recevra automatiquement l'événement s'il possède le focus.

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    FMouse3D : TMouse3DEvent;
    procedure Mouse3DChange(Sender: TObject);
    procedure Mouse3DKeyDown(Sender: TObject; Key: Integer);
  end;
// ...
procedure TForm1.FormCreate(Sender: TObject);
begin
  FMouse3D := TMouse3DEvent.Create(Self);
  FMouse3D.OnChange := Mouse3DChange;
  FMouse3D.OnKeyDown := Mouse3DKeyDown;
end;

unit Mouse3D;
{ (c)2009 by Paul TOTH, http://lookinside.free.fr
{
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}
interface

uses
  Windows, Classes, Controls, Forms, ActiveX, ComObj;

const
  CLASS_Device: TGUID = '{82C5AB54-C92C-4D52-AAC5-27E25E22604C}';
  DIID__ISensorEvents: TGUID = '{E6929A4A-6F41-46C6-9252-A8CC53472CB1}';
  DIID__IKeyboardEvents: TGUID = '{6B6BB0A8-4491-40CF-B1A9-C15A801FE151}';

type
  IKeyboard = interface(IDispatch)
    ['{D6F968E7-2993-48D7-AF24-8B602D925B2C}']
    function  Get_Keys: Integer; safecall;
    function  Get_ProgrammableKeys: Integer; safecall;
    function  GetKeyLabel(key: Integer): WideString; safecall;
    function  GetKeyName(key: Integer): WideString; safecall;
    function  Get_Device: IDispatch; safecall;
    function  IsKeyDown(key: Integer): WordBool; safecall;
    function  IsKeyUp(key: Integer): WordBool; safecall;
    property Keys: Integer read Get_Keys;
    property ProgrammableKeys: Integer read Get_ProgrammableKeys;
    property Device: IDispatch read Get_Device;
  end;

  IAngleAxis = interface(IDispatch)
    ['{1EF2BAFF-54E9-4706-9F61-078F7134FD35}']
    function  Get_X: Double; safecall;
    procedure Set_X(pVal: Double); safecall;
    function  Get_Y: Double; safecall;
    procedure Set_Y(pVal: Double); safecall;
    function  Get_Z: Double; safecall;
    procedure Set_Z(pVal: Double); safecall;
    function  Get_Angle: Double; safecall;
    procedure Set_Angle(pVal: Double); safecall;
    property X: Double read Get_X write Set_X;
    property Y: Double read Get_Y write Set_Y;
    property Z: Double read Get_Z write Set_Z;
    property Angle: Double read Get_Angle write Set_Angle;
  end;

  IVector3D = interface(IDispatch)
    ['{8C2AA71D-2B23-43F5-A6ED-4DF57E9CD8D5}']
    function  Get_X: Double; safecall;
    procedure Set_X(pVal: Double); safecall;
    function  Get_Y: Double; safecall;
    procedure Set_Y(pVal: Double); safecall;
    function  Get_Z: Double; safecall;
    procedure Set_Z(pVal: Double); safecall;
    function  Get_Length: Double; safecall;
    procedure Set_Length(pVal: Double); safecall;
    property X: Double read Get_X write Set_X;
    property Y: Double read Get_Y write Set_Y;
    property Z: Double read Get_Z write Set_Z;
    property Length: Double read Get_Length write Set_Length;
  end;
  
  ISensor = interface(IDispatch)
    ['{F3A6775E-6FA1-4829-BF32-5B045C29078F}']
    function  Get_Translation: IVector3D; safecall;
    function  Get_Rotation: IAngleAxis; safecall;
    function  Get_Device: IDispatch; safecall;
    function  Get_Period: Double; safecall;
    property Translation: IVector3D read Get_Translation;
    property Rotation: IAngleAxis read Get_Rotation;
    property Device: IDispatch read Get_Device;
    property Period: Double read Get_Period;
  end;

  ISimpleDevice = interface(IDispatch)
    ['{CB3BF65E-0816-482A-BB11-64AF1E837812}']
    procedure Connect; safecall;
    procedure Disconnect; safecall;
    function  Get_Sensor: ISensor; safecall;
    function  Get_Keyboard: IKeyboard; safecall;
    function  Get_Type: Integer; safecall;
    function  Get_IsConnected: WordBool; safecall;
    procedure LoadPreferences(const PreferencesName: WideString); safecall;
    property Sensor: ISensor read Get_Sensor;
    property Keyboard: IKeyboard read Get_Keyboard;
    property Type_: Integer read Get_Type;
    property IsConnected: WordBool read Get_IsConnected;
  end;

  TMouseKeyEvent = procedure(Sender: TObject; Key : Integer) of object;

  TMouse3DEvent = class
  private
    FEnabled  : Boolean;
    FOwner    : TControl;
    FForm     : TCustomForm;
    FOnChange : TNotifyEvent;
    FOnKeyDown: TMouseKeyEvent;
    FOnKeyUp  : TMouseKeyEvent;
  protected
    function Focused : Boolean; virtual;
    procedure DoChange; virtual;
    procedure DoKeyDown(Key : Integer); virtual;
    procedure DoKeyUp(Key: Integer); virtual;
  public
    constructor Create(AOwner: TControl);
    destructor Destroy; override;
    property Enabled: Boolean read FEnabled write FEnabled;
    property OnChange : TNotifyEvent read FOnChange write FOnChange;
    property OnKeyDown: TMouseKeyEvent read FOnKeyDown write FOnKeyDown;
    property OnKeyUp  : TMouseKeyEvent read FOnKeyUp write FOnKeyUp;
  end;

  TCustomEvents = class(TObject, IUnknown)
  private
    FRefCount   : Integer;
    FConnection : Integer;
    FEventsIID  : TGUID;
  protected
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  end;

  TSensorEvents = class(TCustomEvents, IDispatch)
  private
    FSensor : ISensor;
  protected
    { IDispatch }
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create(ASensor: ISensor);
    destructor Destroy; override;
  end;

  TKeyboardEvents = class(TCustomEvents, IDispatch)
  private
    FKeyboard : IKeyboard;
  protected
    { IDispatch }
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create(AKeyboard: IKeyboard);
    destructor Destroy; override;
  end;

  TVector4D = record
    X, Y, Z, W : Double;
  end;

  TMouse3D = class
  private
    FEvents         : TList;
    FDevice         : ISimpleDevice;
    FSensorEvents   : TSensorEvents;
    FKeyboardEvents : TKeyboardEvents;
    FTranslation    : TVector4D;
    FRotation       : TVector4D;
    procedure OnChange;
    procedure GetValues;
    procedure DoKeyDown(Key : Integer);
    procedure DoKeyUp(Key: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    property Translation : TVector4D read FTranslation;
    property Rotation : TVector4D read FRotation;
  end;

var
  gMouse3D : TMouse3D;

implementation

{ TMouse3D }

constructor TMouse3D.Create;
var
  cClass : IUnknown;
  cErr   : Integer;
begin
  FEvents := TList.Create;
  cErr := CoCreateInstance(CLASS_Device, nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IUnknown, cClass);
  if cErr <> S_OK then
    Exit;
  FDevice := cClass as ISimpleDevice;
  FSensorEvents := TSensorEvents.Create(FDevice.Sensor);
  FKeyboardEvents := TKeyboardEvents.Create(FDevice.Keyboard);
  FDevice.Connect;
end;

destructor TMouse3D.Destroy;
begin
  if Assigned(FDevice) then
    FDevice.Disconnect;
  FSensorEvents.Free;
  FKeyboardEvents.Free;
  FEvents.Free;
  inherited;
end;

procedure TMouse3D.DoKeyDown(Key: Integer);
var
  i : Integer;
begin
  for i := 0 to Pred(FEvents.Count) do
    with TMouse3DEvent(FEvents[i]) do
      if Focused then
      begin
        DoKeyDown(Key);
        Exit;
      end;
end;

procedure TMouse3D.DoKeyUp(Key: Integer);
var
  i : Integer;
begin
  for i := 0 to Pred(FEvents.Count) do
    with TMouse3DEvent(FEvents[i]) do
      if Focused then
      begin
        DoKeyUp(Key);
        Exit;
      end;
end;

procedure TMouse3D.GetValues;
var
  T : IVector3D;
  R : IAngleAxis;
begin
  T := FDevice.Sensor.Translation;
  FTranslation.X := T.X;
  FTranslation.Y := T.Y;
  FTranslation.Z := T.Z;
  FTranslation.W := T.Length;
  R := FDevice.Sensor.Rotation;
  FRotation.X := R.X;
  FRotation.Y := R.Y;
  FRotation.Z := R.Z;
  FRotation.W := R.Angle;
end;

procedure TMouse3D.OnChange;
var
  i : Integer;
begin
  GetValues;
  for i := 0 to Pred(FEvents.Count) do
    with TMouse3DEvent(FEvents[i]) do
      if Focused then
      begin
        DoChange;
        Exit;
      end;
end;

{ TMouse3DEvent }

constructor TMouse3DEvent.Create(AOwner: TControl);
begin
  inherited Create;
  FOwner := AOwner;
  FForm := GetParentForm(FOwner);
  FEnabled := True;
  gMouse3D.FEvents.Add(Self);
end;

destructor TMouse3DEvent.Destroy;
begin
  gMouse3D.FEvents.Remove(Self);
  inherited;
end;

procedure TMouse3DEvent.DoChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TMouse3DEvent.DoKeyDown(Key: Integer);
begin
  if Assigned(FOnKeyDown) then
    FOnKeyDown(Self, Key);
end;

procedure TMouse3DEvent.DoKeyUp(Key: Integer);
begin
  if Assigned(FOnKeyUp) then
    FOnKeyUp(Self, Key);
end;

function TMouse3DEvent.Focused: Boolean;
begin
  if FForm = nil then
    FForm := GetParentForm(FOwner);
  Result := (FEnabled) and Assigned(FOnChange) and ((FOwner = Screen.ActiveControl) or (FForm = Screen.ActiveForm));
end;

{ TCustomEvents }

function TCustomEvents._AddRef: Integer;
begin
  inc(FRefCount);
  Result := FRefCount;
end;

function TCustomEvents._Release: Integer;
begin
  dec(FRefCount);
  Result := FRefCount;
end;

function TCustomEvents.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
  begin
    Result := S_OK;
    Exit;
  end;
  if IsEqualIID(IID, FEventsIID) then
  begin
    GetInterface(IDispatch, Obj);
    Result := S_OK;
    Exit;
  end;
  Result := E_NOINTERFACE;
end;

function TCustomEvents.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TCustomEvents.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TCustomEvents.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Count := 0;
  Result:= S_OK;
end;

{ TSensorEvents }

function TSensorEvents.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
  gMouse3D.OnChange;
  Result := S_OK;
end;

constructor TSensorEvents.Create(ASensor: ISensor);
begin
  inherited Create;
  FSensor := ASensor;
  FEventsIID := DIID__ISensorEvents;
  InterfaceConnect(FSensor, FEventsIID, Self, FConnection);
end;

destructor TSensorEvents.Destroy;
begin
  InterfaceDisconnect(FSensor, FEventsIID, FConnection);
  inherited;
end;

{ TKeyboardEvents }

constructor TKeyboardEvents.Create(AKeyboard: IKeyboard);
begin
  inherited Create;
  FKeyboard := AKeyboard;
  FEventsIID := DIID__IKeyboardEvents;
  InterfaceConnect(FKeyboard, FEventsIID, Self, FConnection);
end;

destructor TKeyboardEvents.Destroy;
begin
  InterfaceDisconnect(FKeyboard, FEventsIID, FConnection);
  inherited;
end;

function TKeyboardEvents.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
  if DispID = 1 then
    gMouse3D.DoKeyDown(OleVariant(TDispParams(Params).rgvarg^[0]))
  else
    gMouse3D.DoKeyUp(OleVariant(TDispParams(Params).rgvarg^[0]));
  Result := S_OK;
end;

initialization
  gMouse3D := TMouse3D.Create;
finalization
  gMouse3D.Free;
end.
Date de dernière modification : 22/01/2009