Subversion Repositories spacemission

Rev

Rev 4 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. unit DXInput;
  2.  
  3. interface
  4.  
  5. {$INCLUDE DelphiXcfg.inc}
  6.  
  7. uses
  8.   Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem,
  9.   DirectX, DXClass;
  10.  
  11. type
  12.  
  13.   {  EDXInputError  }
  14.  
  15.   EDXInputError = class(Exception);
  16.  
  17.   {  EForceFeedbackEffectError  }
  18.  
  19.   EForceFeedbackEffectError = class(Exception);
  20.  
  21.  
  22.   {  TForceFeedbackEffect  }
  23.  
  24.   TForceFeedbackEffectType = (etNone, etConstantForce, etPeriodic, etCondition);
  25.  
  26.   TForceFeedbackEffect = class;
  27.   TForceFeedbackEffects = class;
  28.  
  29.   TForceFeedbackEffectObject = class
  30.   private
  31.     FAxes: array[0..1] of DWORD;
  32.     FAxesCount: Integer;
  33.     Feff: TDIEffect;
  34.     FDirections: array[0..1] of DWORD;
  35.     FEnvelope: TDIEnvelope;
  36.     FConstantForce: TDIConstantForce;
  37.     FCondition: TDICondition;
  38.     FPeriodic: TDIPeriodic;
  39.     FEffect: IDirectInputEffect;
  40.     procedure Clear;
  41.     procedure Init(Effect: TForceFeedbackEffect);
  42.     procedure Release;
  43.   public
  44.     destructor Destroy; override;
  45.   end;
  46.  
  47.   TForceFeedbackEffect = class(TPersistent)
  48.   private
  49.     FRoot: TForceFeedbackEffects;                
  50.     FParent: TForceFeedbackEffect;
  51.     FList: TList;
  52.     FAttackLevel: Integer;
  53.     FAttackTime: Integer;
  54.     FCondition: TPoint;
  55.     FConstant: TPoint;
  56.     FEffectType: TForceFeedbackEffectType;
  57.     FFadeLevel: Integer;
  58.     FFadeTime: Integer;
  59.     FName: string;
  60.     FPeriod: Integer;
  61.     FPlaying: Boolean;
  62.     FPower: Integer;
  63.     FTime: Integer;
  64.     FStartDelayTime: Integer;
  65.     FObject: TForceFeedbackEffectObject;
  66.     FObject2: TForceFeedbackEffectObject;
  67.     FFindEffectFlag: Boolean;
  68.     FFindEffectGUID: TGUID;
  69.     procedure Acquire;
  70.     procedure Finalize;
  71.     procedure Initialize;
  72.     procedure ChangeEffect;
  73.     procedure MakeEff;
  74.     procedure CreateEffect;
  75.     function GetCount: Integer;
  76.     function GetEffect(Index: Integer): TForceFeedbackEffect;
  77.     function GetIndex: Integer;
  78.     function GetPlaying: Boolean;
  79.     procedure SetAttackLevel(Value: Integer);
  80.     procedure SetAttackTime(Value: Integer);
  81.     procedure SetCondition(Value: TPoint);
  82.     procedure SetConstant(Value: TPoint);
  83.     procedure SetEffectType(Value: TForceFeedbackEffectType);
  84.     procedure SetFadeLevel(Value: Integer);
  85.     procedure SetFadeTime(Value: Integer);
  86.     procedure SetIndex(Value: Integer);
  87.     procedure SetPeriod(Value: Integer);
  88.     procedure SetParent(Value: TForceFeedbackEffect);
  89.     procedure SetPower(Value: Integer);
  90.     procedure SetTime(Value: Integer);
  91.     procedure SetStartDelayTime(Value: Integer);
  92.     function HasInterface: Boolean;
  93.   protected
  94.     function GetOwner: TPersistent; override;
  95.     property StartDelayTime: Integer read FStartDelayTime write SetStartDelayTime;
  96.   public
  97.     constructor Create(AParent: TForceFeedbackEffect);
  98.     destructor Destroy; override;
  99.     procedure Assign(Source: TPersistent); override;
  100.     procedure Clear;
  101.     function Find(const Name: string): TForceFeedbackEffect;
  102.     function IndexOf(const Name: string): Integer;
  103.     procedure LoadFromFile(const FileName: string);
  104.     procedure LoadFromStream(Stream: TStream);
  105.     procedure SaveToFile(const FileName: string);
  106.     procedure SaveToStream(Stream: TStream);
  107.     procedure Start;
  108.     procedure Stop;
  109.     procedure Unload(Recurse: Boolean);
  110.     property Count: Integer read GetCount;
  111.     property Effects[Index: Integer]: TForceFeedbackEffect read GetEffect; default;
  112.     property Index: Integer read GetIndex write SetIndex;
  113.     property Playing: Boolean read GetPlaying;
  114.     property Parent: TForceFeedbackEffect read FParent write SetParent;
  115.     property Name: string read FName write FName;
  116.     property EffectType: TForceFeedbackEffectType read FEffectType write SetEffectType;
  117.     property AttackLevel: Integer read FAttackLevel write SetAttackLevel;
  118.     property AttackTime: Integer read FAttackTime write SetAttackTime;
  119.     property Condition: TPoint read FCondition write SetCondition;
  120.     property Constant: TPoint read FConstant write SetConstant;
  121.     property FadeLevel: Integer read FFadeLevel write SetFadeLevel;
  122.     property FadeTime: Integer read FFadeTime write SetFadeTime;
  123.     property Period: Integer read FPeriod write SetPeriod;
  124.     property Power: Integer read FPower write SetPower;
  125.     property Time: Integer read FTime write SetTime;
  126.   end;
  127.  
  128.   {  TForceFeedbackEffects  }
  129.  
  130.   TCustomInput = class;
  131.  
  132.   TForceFeedbackEffects = class(TForceFeedbackEffect)
  133.   private
  134.     FComponent: TComponent;
  135.     FInput: TCustomInput;
  136.   protected
  137.     procedure DefineProperties(Filer: TFiler); override;
  138.   public
  139.     constructor Create(Input: TCustomInput);
  140.     destructor Destroy; override;
  141.     property Input: TCustomInput read FInput;
  142.   end;
  143.  
  144.   {  TCustomInput  }
  145.  
  146.   TDXInputState = (isUp, isDown, isLeft, isRight, isButton1, isButton2, isButton3,
  147.     isButton4, isButton5, isButton6, isButton7, isButton8, isButton9, isButton10, isButton11,
  148.     isButton12, isButton13, isButton14, isButton15, isButton16, isButton17, isButton18,
  149.     isButton19, isButton20, isButton21, isButton22, isButton23, isButton24, isButton25,
  150.     isButton26, isButton27, isButton28, isButton29, isButton30, isButton31, isButton32);
  151.  
  152.   TDXInputStates = set of TDXInputState;
  153.  
  154.   TCustomDXInput = class;
  155.  
  156.   TCustomInput = class(TPersistent)
  157.   private          
  158.     FBindInputStates: Boolean;
  159.     FButtonCount: Integer;
  160.     FDataFormat: TDIDataFormat;
  161.     FDataFormatObjects: array[0..255] of TDIObjectDataFormat;
  162.     FDataFormatGUIDs: array[0..255] of TGUID;
  163.     FDevice: IDirectInputDevice;
  164.     FDevice2: IDirectInputDevice2;
  165.     FDXInput: TCustomDXInput;
  166.     FEffects: TForceFeedbackEffects;
  167.     FEnabled: Boolean;
  168.     FForceFeedback: Boolean;
  169.     FForceFeedbackDevice: Boolean;
  170.     FInitialized: Boolean;
  171.     FStates: TDXInputStates;
  172.     procedure Acquire;
  173.     procedure Finalize; virtual;
  174.     procedure Initialize; virtual;
  175.     function GetButton(Index: Integer): Boolean;
  176.     function GetCooperativeLevel: Integer; virtual;
  177.     function GetDeviceState(dwSize: Integer; var Data): Boolean;
  178.     function SetDataFormat: Boolean;
  179.     procedure SetEffects(Value: TForceFeedbackEffects);
  180.     procedure SetEnabled(Value: Boolean);
  181.     procedure SetForceFeedback(Value: Boolean);
  182.     procedure SetWindowHandle(Value: Integer);
  183.   public
  184.     constructor Create(DXInput: TCustomDXInput); virtual;
  185.     destructor Destroy; override;
  186.     procedure Update; virtual; abstract;
  187.     property ButtonCount: Integer read FButtonCount;
  188.     property Buttons[Index: Integer]: Boolean read GetButton;
  189.     property States: TDXInputStates read FStates;
  190.   published
  191.     property BindInputStates: Boolean read FBindInputStates write FBindInputStates;
  192.     property Effects: TForceFeedbackEffects read FEffects write SetEffects;
  193.     property Enabled: Boolean read FEnabled write SetEnabled;
  194.     property ForceFeedback: Boolean read FForceFeedback write SetForceFeedback;
  195.   end;
  196.  
  197.   {  TKeyboard  }
  198.  
  199.   PKeyAssign = ^TKeyAssign;
  200.   TKeyAssign = array[0..2] of Integer;
  201.  
  202.   TKeyAssignList = array[TDXInputState] of TKeyAssign;
  203.  
  204.   TKeyboard = class(TCustomInput)
  205.   private
  206.     FKeyStates: TKeyboardState;
  207.     procedure Finalize; override;
  208.     procedure Initialize; override;
  209.     function GetKey(Key: Integer): Boolean;
  210.     procedure ReadAssigns(Stream: TStream);
  211.     procedure WriteAssigns(Stream: TStream);
  212.   protected
  213.     procedure DefineProperties(Filer: TFiler); override;
  214.   public
  215.     KeyAssigns: TKeyAssignList;
  216.     constructor Create(DXInput: TCustomDXInput); override;
  217.     procedure Update; override;
  218.     property Keys[Key: Integer]: Boolean read GetKey;
  219.   end;
  220.  
  221.   {  TMouse  }
  222.  
  223.   TMouse = class(TCustomInput)
  224.   private  
  225.     Fdims: TDIMouseState;
  226.     procedure Finalize; override;
  227.     procedure Initialize; override;
  228.     function GetX: Integer;
  229.     function GetY: Integer;
  230.     function GetZ: Integer;
  231.   public
  232.     constructor Create(DXInput: TCustomDXInput); override;
  233.     procedure Update; override;
  234.     property X: Integer read GetX;
  235.     property Y: Integer read GetY;
  236.     property Z: Integer read GetZ;
  237.   end;
  238.  
  239.   {  TJoystick  }
  240.  
  241.   TJoystick = class(TCustomInput)
  242.   private
  243.     Fdijs: TDIJoyState2;
  244.     FAutoCenter: Boolean;
  245.     FDeviceGUID: TGUID;
  246.     FEnumFlag: Boolean;
  247.     FEnumIndex: Integer;
  248.     FID: Integer;
  249.     FID2: Integer;
  250.     FJoyCaps: TJoyCaps;
  251.     FDeadZone: array[0..SizeOf(TDIJoyState2)-1] of Integer;
  252.     FRange: array[0..SizeOf(TDIJoyState2)-1] of Integer;
  253.     procedure Finalize; override;
  254.     procedure Initialize; override;
  255.     function GetCooperativeLevel: Integer; override;
  256.     function GetDeadZone(Obj: Integer): Integer;
  257.     function GetRange(Obj: Integer): Integer;
  258.     function GetX: Integer;
  259.     function GetY: Integer;
  260.     function GetZ: Integer;
  261.     procedure SetDeadZone(Obj: Integer; Value: Integer);
  262.     procedure SetRange(Obj: Integer; Value: Integer);
  263.     procedure SetAutoCenter(Value: Boolean);
  264.     procedure SetID(Value: Integer);
  265.   public
  266.     constructor Create(DXInput: TCustomDXInput); override;
  267.     procedure Update; override;
  268.     property DeadZone[Obj: Integer]: Integer read GetDeadZone write SetDeadZone;
  269.     property Range[Obj: Integer]: Integer read GetRange write SetRange;
  270.     property Joystate: TDIJoyState2 read Fdijs;
  271.     property X: Integer read GetX;
  272.     property Y: Integer read GetY;
  273.     property Z: Integer read GetZ;
  274.   published
  275.     property AutoCenter: Boolean read FAutoCenter write SetAutoCenter;
  276.     property DeadZoneX: Integer index DIJOFS_X read GetDeadZone write SetDeadZone;
  277.     property DeadZoneY: Integer index DIJOFS_Y read GetDeadZone write SetDeadZone;
  278.     property DeadZoneZ: Integer index DIJOFS_Z read GetDeadZone write SetDeadZone;
  279.     property ID: Integer read FID write SetID;
  280.     property RangeX: Integer index DIJOFS_X read GetRange write SetRange;
  281.     property RangeY: Integer index DIJOFS_Y read GetRange write SetRange;
  282.     property RangeZ: Integer index DIJOFS_Z read GetRange write SetRange;
  283.   end;
  284.  
  285.   {  TCustomDXInput  }
  286.  
  287.   TCustomDXInput = class(TComponent)
  288.   private
  289.     FActiveOnly: Boolean;
  290.     FDevice: TList;
  291.     FDInput: IDirectInput;
  292.     FForm: TCustomForm;
  293.     FJoystick: TJoystick;
  294.     FKeyboard: TKeyboard;
  295.     FMouse: TMouse;
  296.     FOldStates: TDXInputStates;
  297.     FStates: TDXInputStates;
  298.     FSubClass: TControlSubClass;
  299.     FUseDirectInput: Boolean;
  300.     procedure Finalize;
  301.     procedure Initialize;
  302.     procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  303.     procedure SetActiveOnly(Value: Boolean);
  304.     procedure SetJoystick(Value: TJoystick);
  305.     procedure SetKeyboard(Value: TKeyboard);
  306.     procedure SetMouse(Value: TMouse);
  307.     procedure SetWindowHandle;
  308.     procedure SetUseDirectInput(Value: Boolean);
  309.   protected
  310.     procedure Loaded; override;
  311.   public
  312.     constructor Create(AOwner: TComponent); override;
  313.     destructor Destroy; override;
  314.     procedure Update;
  315.     property ActiveOnly: Boolean read FActiveOnly write SetActiveOnly;
  316.     property Joystick: TJoystick read FJoystick write SetJoystick;
  317.     property Keyboard: TKeyboard read FKeyboard write SetKeyboard;
  318.     property Mouse: TMouse read FMouse write SetMouse;
  319.     property States: TDXInputStates read FStates write FStates;
  320.     property UseDirectInput: Boolean read FUseDirectInput write SetUseDirectInput;
  321.   end;
  322.  
  323.   {  TDXInput  }
  324.  
  325.   TDXInput = class(TCustomDXInput)
  326.   published
  327.     property ActiveOnly;
  328.     property Joystick;
  329.     property Keyboard;
  330.     property Mouse;
  331.     property UseDirectInput;
  332.   end;
  333.  
  334. function DefKeyAssign: TKeyAssignList;
  335. function DefKeyAssign2_1: TKeyAssignList;
  336. function DefKeyAssign2_2: TKeyAssignList;
  337.  
  338. implementation
  339.  
  340. uses DXConsts;
  341.  
  342. procedure AssignKey(var KeyAssignList: TKeyAssignList; State: TDXInputState;
  343.   const Keys: array of Integer);
  344. var
  345.   i, i2: Integer;
  346.   KeyAssign: PKeyAssign;
  347. begin
  348.   KeyAssign := @KeyAssignList[State];
  349.   FillChar(KeyAssign^, SizeOf(TKeyAssign), 0);
  350.  
  351.   i2 := 0;
  352.   for i:=LOW(Keys) to HIGH(Keys) do
  353.   begin
  354.     if i2<3 then
  355.       KeyAssign^[i2] := Keys[i]
  356.     else
  357.       Exit;
  358.     Inc(i2);
  359.   end;
  360. end;
  361.  
  362. function DefKeyAssign: TKeyAssignList;
  363. begin
  364.   FillChar(Result, SizeOf(Result), 0);
  365.  
  366.   AssignKey(Result, isUp,      [Ord('K'), VK_UP, VK_NUMPAD8]);
  367.   AssignKey(Result, isDown,    [Ord('J'), VK_DOWN, VK_NUMPAD2]);
  368.   AssignKey(Result, isLeft,    [Ord('H'), VK_LEFT, VK_NUMPAD4]);
  369.   AssignKey(Result, isRight,   [Ord('L'), VK_RIGHT, VK_NUMPAD6]);
  370.   AssignKey(Result, isButton1, [Ord('Z'), VK_SPACE]);
  371.   AssignKey(Result, isButton2, [Ord('X'), VK_RETURN]);
  372.   AssignKey(Result, isButton9, [VK_F2]);
  373. end;
  374.  
  375. function DefKeyAssign2_1: TKeyAssignList;
  376. begin
  377.   FillChar(Result, SizeOf(Result), 0);
  378.  
  379.   AssignKey(Result, isUp,      [Ord('K'), VK_UP, VK_NUMPAD8]);
  380.   AssignKey(Result, isDown,    [Ord('J'), VK_DOWN, VK_NUMPAD2]);
  381.   AssignKey(Result, isLeft,    [Ord('H'), VK_LEFT, VK_NUMPAD4]);
  382.   AssignKey(Result, isRight,   [Ord('L'), VK_RIGHT, VK_NUMPAD6]);
  383.   AssignKey(Result, isButton1, [VK_SPACE , VK_NUMPAD0]);
  384.   AssignKey(Result, isButton2, [VK_RETURN, VK_NUMPAD5]);
  385.   AssignKey(Result, isButton9, [VK_F2]);
  386. end;
  387.  
  388. function DefKeyAssign2_2: TKeyAssignList;
  389. begin
  390.   FillChar(Result, SizeOf(Result), 0);
  391.  
  392.   AssignKey(Result, isUp,      [Ord('E')]);
  393.   AssignKey(Result, isDown,    [Ord('C')]);
  394.   AssignKey(Result, isLeft,    [Ord('S')]);
  395.   AssignKey(Result, isRight,   [Ord('F')]);
  396.   AssignKey(Result, isButton1, [Ord('Z')]);
  397.   AssignKey(Result, isButton2, [Ord('X')]);
  398.   AssignKey(Result, isButton9, [VK_F2]);
  399. end;
  400.  
  401. {  TForceFeedbackEffectObject  }
  402.  
  403. destructor TForceFeedbackEffectObject.Destroy;
  404. begin
  405.   Release;                      
  406.   inherited Destroy;
  407. end;
  408.  
  409. function ConvertTime(i: Integer): DWORD;
  410. begin
  411.   if i=-1 then Result := INFINITE else Result := i*1000;
  412. end;
  413.  
  414. procedure TForceFeedbackEffectObject.Clear;
  415. begin
  416.   FillChar(Feff, SizeOf(Feff), 0);
  417. end;
  418.  
  419. procedure TForceFeedbackEffectObject.Init(Effect: TForceFeedbackEffect);
  420. begin
  421.   with FEnvelope do
  422.   begin
  423.     dwSize := SizeOf(FEnvelope);
  424.  
  425.     dwAttackLevel := Effect.FAttackLevel;
  426.     if Effect.FTime<0 then
  427.       dwAttackTime := Effect.FAttackTime*1000
  428.     else
  429.       dwAttackTime := Min(Effect.FAttackTime, Effect.FTime)*1000;
  430.                                              
  431.     if Effect.FTime<0 then
  432.     begin
  433.       dwFadeLevel := 0;
  434.       dwFadeTime := 0;
  435.     end else
  436.     begin
  437.       dwFadeLevel := Effect.FFadeLevel;
  438.       dwFadeTime := Min(Effect.FFadeTime, Effect.FTime)*1000;
  439.     end;
  440.   end;
  441.  
  442.   FillChar(Feff, SizeOf(Feff), 0);
  443.   with Feff do
  444.   begin
  445.     dwSize := SizeOf(Feff);
  446.     dwFlags := DIEFF_CARTESIAN or DIEFF_OBJECTOFFSETS;
  447.     dwDuration := ConvertTime(Effect.FTime);
  448.     dwSamplePeriod := 0;
  449.     dwGain := Effect.FPower;
  450.     dwTriggerButton := DIEB_NOTRIGGER;
  451.     dwTriggerRepeatInterval := 0;
  452.     cAxes := FAxesCount;
  453.     rgdwAxes := @FAxes;
  454.     rglDirection := @FDirections;
  455.     lpEnvelope := @FEnvelope;
  456.     //dwStartDelay := Effect.FStartDelayTime;
  457.   end;
  458. end;
  459.  
  460. procedure TForceFeedbackEffectObject.Release;
  461. begin
  462.   FEffect := nil;
  463. end;
  464.  
  465. {  TForceFeedbackEffect  }
  466.  
  467. constructor TForceFeedbackEffect.Create(AParent: TForceFeedbackEffect);
  468. begin
  469.   inherited Create;
  470.   FParent := AParent;
  471.   FList := TList.Create;
  472.  
  473.   if FParent<>nil then
  474.   begin
  475.     FParent.FList.Add(Self);
  476.     FRoot := FParent.FRoot;
  477.   end else
  478.   begin
  479.     FName := 'Effects';
  480.     FRoot := Self as TForceFeedbackEffects;
  481.   end;
  482.  
  483.   FObject := TForceFeedbackEffectObject.Create;
  484.   FObject2 := TForceFeedbackEffectObject.Create;
  485.  
  486.   AttackTime := 0;
  487.   Constant := Point(0, 0);
  488.   EffectType := etNone;
  489.   FadeTime := 0;
  490.   Period := 50;
  491.   Power := 10000;
  492.   Time := 1000;
  493. end;
  494.  
  495. destructor TForceFeedbackEffect.Destroy;
  496. begin
  497.   Clear;
  498.   FObject.Free;
  499.   FObject2.Free;
  500.   FList.Free;
  501.   if FParent<>nil then
  502.     FParent.FList.Remove(Self);
  503.   inherited Destroy;
  504. end;
  505.  
  506. function TForceFeedbackEffect.GetOwner: TPersistent;
  507. begin
  508.   Result := Parent;
  509. end;
  510.  
  511. procedure TForceFeedbackEffect.Assign(Source: TPersistent);
  512. var
  513.   i: Integer;
  514. begin
  515.   if Source is TForceFeedbackEffect then
  516.   begin
  517.     if Source<>Self then
  518.     begin
  519.       Clear;
  520.  
  521.       EffectType := etNone;
  522.  
  523.       Name := TForceFeedbackEffect(Source).Name;
  524.  
  525.       AttackLevel := TForceFeedbackEffect(Source).AttackLevel;
  526.       AttackTime := TForceFeedbackEffect(Source).AttackTime;
  527.       Constant := TForceFeedbackEffect(Source).Constant;
  528.       Condition := TForceFeedbackEffect(Source).Condition;
  529.       EffectType := TForceFeedbackEffect(Source).EffectType;
  530.       FadeLevel := TForceFeedbackEffect(Source).FadeLevel;
  531.       FadeTime := TForceFeedbackEffect(Source).FadeTime;
  532.       Period := TForceFeedbackEffect(Source).Period;
  533.       Power := TForceFeedbackEffect(Source).Power;
  534.       Time := TForceFeedbackEffect(Source).Time;
  535.       StartDelayTime := TForceFeedbackEffect(Source).StartDelayTime;
  536.  
  537.       EffectType := TForceFeedbackEffect(Source).EffectType;
  538.  
  539.       for i:=0 to TForceFeedbackEffect(Source).Count-1 do
  540.         TForceFeedbackEffect.Create(Self).Assign(TForceFeedbackEffect(Source)[i]);
  541.     end;
  542.   end else
  543.     inherited Assign(Source);
  544. end;
  545.  
  546. procedure TForceFeedbackEffect.Acquire;
  547. var
  548.   i: Integer;
  549. begin
  550.   if Playing and (Time=-1) then
  551.     Start;
  552.  
  553.   for i:=0 to Count-1 do
  554.     Effects[i].Initialize;
  555. end;
  556.  
  557. procedure TForceFeedbackEffect.Clear;
  558. begin
  559.   while Count>0 do
  560.     Effects[Count-1].Free;
  561. end;
  562.  
  563. procedure TForceFeedbackEffect.Initialize;
  564. var
  565.   i: Integer;
  566. begin
  567.   CreateEffect;
  568.   for i:=0 to Count-1 do
  569.     Effects[i].Initialize;
  570. end;
  571.  
  572. procedure TForceFeedbackEffect.Finalize;
  573. var
  574.   i: Integer;
  575. begin
  576.   try
  577.     Stop;
  578.     FObject.Release;
  579.     FObject2.Release;
  580.   finally
  581.     for i:=0 to Count-1 do
  582.       Effects[i].Finalize;
  583.   end;
  584. end;
  585.  
  586. function TForceFeedbackEffect.Find(const Name: string): TForceFeedbackEffect;
  587. var
  588.   i, p: Integer;
  589.   Effect: TForceFeedbackEffect;
  590.   AName: string;
  591. begin
  592.   AName := Name;
  593.   Effect := Self;
  594.  
  595.   p := AnsiPos('.', AName);
  596.   while p<>0 do
  597.   begin
  598.     i := Effect.IndexOf(AName);
  599.     if i<>-1 then
  600.     begin
  601.       Result := Effect[i];
  602.       Exit;
  603.     end else
  604.     begin
  605.       i := Effect.IndexOf(Copy(Name, 1, p-1));
  606.       if i=-1 then
  607.         raise EForceFeedbackEffectError.CreateFmt(SEffectNotFound, [Name]);
  608.       Effect := Effect[i];
  609.       AName := Copy(Name, p+1, MaxInt);
  610.       p := AnsiPos('.', AName);
  611.     end;
  612.   end;
  613.  
  614.   i := Effect.IndexOf(Name);
  615.   if i=-1 then
  616.     raise EForceFeedbackEffectError.CreateFmt(SEffectNotFound, [Name]);
  617.   Result := Effect[i];
  618. end;
  619.  
  620. function TForceFeedbackEffect.IndexOf(const Name: string): Integer;
  621. var
  622.   i: Integer;
  623. begin
  624.   Result := -1;
  625.   for i:=0 to Count-1 do
  626.     if Effects[i].Name=Name then
  627.     begin
  628.       Result := i;
  629.       Break;
  630.     end;
  631. end;
  632.  
  633. function TForceFeedbackEffect.HasInterface: Boolean;
  634. begin
  635.   Result := (FEffectType<>etNone) and ((FObject.FEffect<>nil) or (FObject2.FEffect<>nil));
  636. end;
  637.  
  638. procedure TForceFeedbackEffect.MakeEff;
  639. var
  640.   Constant2: TPoint;
  641. begin
  642.   FObject.Clear;
  643.   FObject2.Clear;
  644.  
  645.   with Constant2 do
  646.   begin
  647.     X := -FConstant.X;
  648.     Y := -FConstant.Y;
  649.   end;
  650.  
  651.   case FEffectType of
  652.     etConstantForce:  { etConstantForce }
  653.         begin
  654.           with FObject do
  655.           begin
  656.             FDirections[0] := Constant2.X;
  657.             FDirections[1] := Constant2.Y;
  658.  
  659.             FAxesCount := 2;
  660.             FAxes[0] := DIJOFS_X;
  661.             FAxes[1] := DIJOFS_Y;
  662.  
  663.             with Constant2 do
  664.               FConstantForce.lMagnitude := Trunc(Sqrt(X*X+Y*Y));
  665.  
  666.             Init(Self);
  667.             with Feff do
  668.             begin
  669.               cbTypeSpecificParams := SizeOf(FConstantForce);
  670.               lpvTypeSpecificParams := @FConstantForce;
  671.             end;
  672.           end;
  673.         end;
  674.     etPeriodic:       { etPeriodic }
  675.         begin
  676.           with FObject do
  677.           begin
  678.             FDirections[0] := Constant2.X;
  679.             FDirections[1] := Constant2.Y;
  680.  
  681.             FAxesCount := 2;
  682.             FAxes[0] := DIJOFS_X;
  683.             FAxes[1] := DIJOFS_Y;
  684.  
  685.             with FPeriodic do
  686.             begin
  687.               with Constant2 do
  688.                 dwMagnitude := Trunc(Sqrt(X*X+Y*Y));
  689.               lOffset := 0;
  690.               dwPhase := 0;
  691.               dwPeriod := ConvertTime(FPeriod);
  692.             end;
  693.  
  694.             Init(Self);
  695.             with Feff do
  696.             begin
  697.               cbTypeSpecificParams := SizeOf(FPeriodic);
  698.               lpvTypeSpecificParams := @FPeriodic;
  699.             end;
  700.           end;
  701.         end;
  702.     etCondition:      { etCondition }
  703.         begin
  704.           with FObject do
  705.           begin
  706.             FillChar(FDirections, SizeOf(FDirections), 0);
  707.  
  708.             FAxesCount := 1;
  709.             FAxes[0] := DIJOFS_X;
  710.                    
  711.             with FCondition do
  712.             begin
  713.               lOffset := -Constant2.X;
  714.               lPositiveCoefficient := Self.FCondition.X;
  715.               lNegativeCoefficient := -Self.FCondition.X;
  716.               dwPositiveSaturation := 0;
  717.               dwNegativeSaturation := 0;
  718.               lDeadBand := 0;
  719.             end;
  720.  
  721.             Init(Self);
  722.             with Feff do
  723.             begin
  724.               cbTypeSpecificParams := SizeOf(FCondition);
  725.               lpvTypeSpecificParams := @FCondition;
  726.             end;
  727.           end;
  728.  
  729.           with FObject2 do
  730.           begin
  731.             FillChar(FDirections, SizeOf(FDirections), 0);
  732.  
  733.             FAxesCount := 1;
  734.             FAxes[0] := DIJOFS_Y;
  735.  
  736.             with FCondition do
  737.             begin
  738.               lOffset := -Constant2.Y;
  739.               lPositiveCoefficient := Self.FCondition.Y;
  740.               lNegativeCoefficient := -Self.FCondition.Y;
  741.               dwPositiveSaturation := 0;
  742.               dwNegativeSaturation := 0;
  743.               lDeadBand := 0;
  744.             end;
  745.  
  746.             Init(Self);
  747.             with Feff do
  748.             begin
  749.               cbTypeSpecificParams := SizeOf(FCondition);
  750.               lpvTypeSpecificParams := @FCondition;
  751.             end;
  752.           end;
  753.         end;
  754.   end;
  755. end;
  756.  
  757. procedure TForceFeedbackEffect.CreateEffect;
  758.                                            
  759.   function FindEffectCallBack(const pdei: TDIEffectInfoA;
  760.     pvRef: Pointer): HRESULT; stdcall;
  761.   begin
  762.     with TForceFeedbackEffect(pvRef) do
  763.     begin
  764.       FFindEffectFlag := True;
  765.       FFindEffectGUID := pdei.guid;
  766.     end;
  767.  
  768.     Result := DIENUM_STOP;
  769.   end;
  770.  
  771.   procedure CreateIEffectGuid(const GUID: TGUID;
  772.     EffectObject: TForceFeedbackEffectObject);
  773.   begin
  774.     if EffectObject.Feff.dwSize=0 then Exit;
  775.  
  776.     if FRoot.FInput.FDevice2<>nil then
  777.       FRoot.FInput.FDevice2.CreateEffect(GUID, EffectObject.Feff, EffectObject.FEffect, nil);
  778.   end;
  779.  
  780.   procedure CreateIEffect(dwFlags: DWORD;
  781.     EffectObject: TForceFeedbackEffectObject);
  782.   begin
  783.     if EffectObject.Feff.dwSize=0 then Exit;
  784.  
  785.     if FRoot.FInput.FDevice2<>nil then
  786.     begin
  787.       FFindEffectFlag := False;
  788.       FRoot.FInput.FDevice2.EnumEffects(@FindEffectCallBack,
  789.         Self, dwFlags);
  790.       if FFindEffectFlag then
  791.         CreateIEffectGuid(FFindEffectGUID, EffectObject);
  792.     end;
  793.   end;
  794.  
  795. begin
  796.   FObject.Release;
  797.   FObject2.Release;
  798.  
  799.   if (FRoot.FInput=nil) or (FRoot.FInput.FDevice2=nil) or
  800.     (not FRoot.FInput.FForceFeedbackDevice) or
  801.     (not FRoot.FInput.FForceFeedback) then Exit;
  802.  
  803.   if FEffectType=etNone then Exit;
  804.  
  805.   MakeEff;
  806.   case FEffectType of
  807.     etConstantForce:
  808.         begin
  809.           CreateIEffectGUID(GUID_ConstantForce, FObject);
  810.         end;
  811.     etPeriodic:
  812.         begin
  813.           CreateIEffect(DIEFT_PERIODIC, FObject);
  814.         end;
  815.     etCondition:
  816.         begin
  817.           CreateIEffect(DIEFT_CONDITION, FObject);
  818.           CreateIEffect(DIEFT_CONDITION, FObject2);
  819.         end;
  820.   end;
  821.  
  822.   if Playing and (Time=-1) then
  823.     Start;
  824. end;
  825.  
  826. procedure TForceFeedbackEffect.ChangeEffect;
  827. var
  828.   dwFlags: DWORD;
  829. begin
  830.   if HasInterface then
  831.   begin
  832.     MakeEff;
  833.  
  834.     dwFlags := DIEP_DIRECTION or DIEP_DURATION or DIEP_ENVELOPE or
  835.       DIEP_GAIN or DIEP_SAMPLEPERIOD or DIEP_TRIGGERBUTTON or
  836.       DIEP_TRIGGERREPEATINTERVAL or DIEP_TYPESPECIFICPARAMS;
  837.  
  838.     if Playing then
  839.       dwFlags := dwFlags or DIEP_START;
  840.  
  841.     if FObject.FEffect<>nil then FObject.FEffect.SetParameters(FObject.Feff, dwFlags);
  842.     if FObject2.FEffect<>nil then FObject2.FEffect.SetParameters(FObject2.Feff, dwFlags);
  843.   end;
  844. end;
  845.  
  846. function TForceFeedbackEffect.GetPlaying: Boolean;
  847. var
  848.   dwFlags: DWORD;
  849. begin
  850.   Result := False;
  851.  
  852.   if not FPlaying then Exit;
  853.  
  854.   if FPlaying and (FTime=-1) then
  855.   begin
  856.     Result := True;
  857.     Exit;
  858.   end;
  859.  
  860.   if FObject.FEffect<>nil then
  861.   begin
  862.     dwFlags := 0;
  863.     FObject.FEffect.GetEffectStatus(dwFlags);
  864.     if dwFlags and DIEGES_PLAYING<>0 then
  865.     begin
  866.       Result := True;
  867.       Exit;
  868.     end;
  869.   end;
  870.  
  871.   if FObject2.FEffect<>nil then
  872.   begin
  873.     dwFlags := 0;
  874.     FObject2.FEffect.GetEffectStatus(dwFlags);
  875.     if dwFlags and DIEGES_PLAYING<>0 then
  876.     begin
  877.       Result := True;
  878.       Exit;
  879.     end;
  880.   end;
  881.  
  882.   if not Result then
  883.     FPlaying := False;
  884. end;
  885.  
  886. function TForceFeedbackEffect.GetCount: Integer;
  887. begin
  888.   Result := FList.Count;
  889. end;
  890.  
  891. function TForceFeedbackEffect.GetEffect(Index: Integer): TForceFeedbackEffect;
  892. begin
  893.   Result :=FList[Index];
  894. end;
  895.  
  896. function TForceFeedbackEffect.GetIndex: Integer;
  897. begin
  898.   if FParent<>nil then
  899.     Result := FParent.FList.IndexOf(Self)
  900.   else
  901.     Result := 0;
  902. end;
  903.  
  904. procedure TForceFeedbackEffect.SetIndex(Value: Integer);
  905. begin
  906.   if FParent<>nil then
  907.   begin
  908.     FParent.FList.Remove(Self);
  909.     FParent.FList.Insert(Value, Self);
  910.   end;
  911. end;
  912.  
  913. procedure TForceFeedbackEffect.SetParent(Value: TForceFeedbackEffect);
  914. begin
  915.   if Parent<>Value then
  916.   begin
  917.     if (Value=nil) or (FRoot<>Value.FRoot) then
  918.       raise EForceFeedbackEffectError.CreateFmt(SCannotChanged, ['Parent']);
  919.  
  920.     FParent.FList.Remove(Self);
  921.     FParent := Value;
  922.     FParent.FList.Add(Self);
  923.   end;
  924. end;
  925.  
  926. procedure TForceFeedbackEffect.SetAttackLevel(Value: Integer);
  927. begin
  928.   if Value<0 then Value := 0;
  929.   if Value>10000 then Value := 10000;
  930.  
  931.   if FAttackLevel<>Value then
  932.   begin
  933.     FAttackLevel := Value;
  934.     ChangeEffect;
  935.   end;
  936. end;
  937.  
  938. procedure TForceFeedbackEffect.SetAttackTime(Value: Integer);
  939. begin
  940.   if Value<0 then Value := 0;
  941.  
  942.   if FAttackTime<>Value then
  943.   begin
  944.     FAttackTime := Value;
  945.     ChangeEffect;
  946.   end;
  947. end;
  948.  
  949. procedure TForceFeedbackEffect.SetCondition(Value: TPoint);
  950. begin
  951.   with Value do
  952.   begin
  953.     if X<-10000 then X := -10000;
  954.     if X>+10000 then X := +10000;
  955.  
  956.     if Y<-10000 then Y := -10000;
  957.     if Y>+10000 then Y := +10000;
  958.   end;
  959.  
  960.   if not CompareMem(@FCondition, @Value, SizeOf(FCondition)) then
  961.   begin
  962.     FCondition := Value;
  963.  
  964.     if HasInterface then
  965.       ChangeEffect;
  966.   end;
  967. end;
  968.  
  969. procedure TForceFeedbackEffect.SetConstant(Value: TPoint);
  970. begin
  971.   with Value do
  972.   begin
  973.     if X<-10000 then X := -10000;
  974.     if X>+10000 then X := +10000;
  975.  
  976.     if Y<-10000 then Y := -10000;
  977.     if Y>+10000 then Y := +10000;
  978.   end;
  979.  
  980.   if not CompareMem(@FConstant, @Value, SizeOf(FConstant)) then
  981.   begin
  982.     FConstant := Value;
  983.  
  984.     if HasInterface then
  985.       ChangeEffect;
  986.   end;
  987. end;
  988.  
  989. procedure TForceFeedbackEffect.SetEffectType(Value: TForceFeedbackEffectType);
  990. begin
  991.   if FEffectType<>Value then
  992.   begin
  993.     FEffectType := Value;
  994.     Stop;
  995.     CreateEffect;
  996.   end;
  997. end;
  998.  
  999. procedure TForceFeedbackEffect.SetFadeLevel(Value: Integer);
  1000. begin
  1001.   if Value<0 then Value := 0;
  1002.   if Value>10000 then Value := 10000;
  1003.  
  1004.   if FFadeLevel<>Value then
  1005.   begin
  1006.     FFadeLevel := Value;
  1007.     ChangeEffect;
  1008.   end;
  1009. end;
  1010.  
  1011. procedure TForceFeedbackEffect.SetFadeTime(Value: Integer);
  1012. begin
  1013.   if Value<0 then Value := 0;
  1014.  
  1015.   if FFadeTime<>Value then
  1016.   begin
  1017.     FFadeTime := Value;
  1018.     ChangeEffect;
  1019.   end;
  1020. end;
  1021.  
  1022. procedure TForceFeedbackEffect.SetPeriod(Value: Integer);
  1023. begin
  1024.   if Value<0 then Value := 0;
  1025.  
  1026.   if FPeriod<>Value then
  1027.   begin
  1028.     FPeriod := Value;
  1029.     ChangeEffect;
  1030.   end;
  1031. end;
  1032.  
  1033. procedure TForceFeedbackEffect.SetPower(Value: Integer);
  1034. begin
  1035.   if Value<0 then Value := 0;
  1036.   if Value>10000 then Value := 10000;
  1037.  
  1038.   if FPower<>Value then
  1039.   begin
  1040.     FPower := Value;
  1041.     ChangeEffect;
  1042.   end;
  1043. end;
  1044.  
  1045. procedure TForceFeedbackEffect.SetTime(Value: Integer);
  1046. begin
  1047.   if (Value<>-1) and (Value<0) then Value := 0;
  1048.  
  1049.   if FTime<>Value then
  1050.   begin
  1051.     FTime := Value;
  1052.     Stop;
  1053.     ChangeEffect;
  1054.   end;
  1055. end;
  1056.  
  1057. procedure TForceFeedbackEffect.SetStartDelayTime(Value: Integer);
  1058. begin
  1059.   if Value<0 then Value := 0;
  1060.  
  1061.   if FStartDelayTime<>Value then
  1062.   begin
  1063.     FStartDelayTime := Value;
  1064.     Stop;
  1065.     ChangeEffect;
  1066.   end;
  1067. end;
  1068.  
  1069. procedure TForceFeedbackEffect.Start;
  1070.  
  1071.   procedure StartEffect(Effect: IDirectInputEffect);
  1072.   var
  1073.     hr: HRESULT;
  1074.   begin
  1075.     if Effect<>nil then
  1076.     begin
  1077.       hr := Effect.Start(1, 0);
  1078.       if (hr=DIERR_INPUTLOST) or (hr=DIERR_NOTACQUIRED) then
  1079.       begin
  1080.         FRoot.FInput.Acquire;
  1081.         Effect.Start(1, 0);
  1082.       end;
  1083.     end;
  1084.   end;
  1085.  
  1086. var
  1087.   i: Integer;
  1088. begin
  1089.   for i:=0 to Count-1 do
  1090.     Effects[i].Start;
  1091.  
  1092.   if not HasInterface then
  1093.   begin
  1094.     CreateEffect;
  1095.     if not HasInterface then Exit;
  1096.   end;
  1097.  
  1098.   StartEffect(FObject.FEffect);
  1099.   StartEffect(FObject2.FEffect);
  1100.  
  1101.   FPlaying := True;
  1102. end;
  1103.  
  1104. procedure TForceFeedbackEffect.Stop;
  1105. var
  1106.   i: Integer;
  1107. begin
  1108.   if Playing then
  1109.   begin
  1110.     FPlaying := False;
  1111.     if FObject.FEffect<>nil then FObject.FEffect.Stop;
  1112.     if FObject2.FEffect<>nil then FObject2.FEffect.Stop;
  1113.   end;
  1114.  
  1115.   for i:=0 to Count-1 do
  1116.     Effects[i].Stop;
  1117. end;
  1118.  
  1119. procedure TForceFeedbackEffect.Unload(Recurse: Boolean);
  1120. var
  1121.   i: Integer;
  1122. begin
  1123.   if Playing then
  1124.   begin
  1125.     if FObject.FEffect<>nil then FObject.FEffect.Stop;
  1126.     if FObject2.FEffect<>nil then FObject2.FEffect.Stop;
  1127.   end;
  1128.  
  1129.   if FObject.FEffect<>nil then FObject.FEffect.Unload;
  1130.   if FObject2.FEffect<>nil then FObject2.FEffect.Unload;
  1131.  
  1132.   if Recurse then
  1133.   begin
  1134.     for i:=0 to Count-1 do
  1135.       Effects[i].Unload(True);
  1136.   end;
  1137. end;
  1138.  
  1139. type
  1140.   TForceFeedbackEffectItem = class(TCollectionItem)
  1141.   private
  1142.     FName: string;
  1143.     FEffectType: TForceFeedbackEffectType;
  1144.     FAttackLevel: Integer;
  1145.     FAttackTime: Integer;
  1146.     FConditionX: Integer;
  1147.     FConditionY: Integer;
  1148.     FConstantX: Integer;
  1149.     FConstantY: Integer;
  1150.     FFadeLevel: Integer;
  1151.     FFadeTime: Integer;
  1152.     FPeriod: Integer;
  1153.     FPower: Integer;
  1154.     FTime: Integer;
  1155.     FStartDelayTime: Integer;
  1156.     FEffects: TCollection;
  1157.     function GetStoredEffects: Boolean;
  1158.   public
  1159.     constructor Create(Collection: TCollection); override;
  1160.     destructor Destroy; override;
  1161.     procedure Assign(Source: TPersistent); override;
  1162.     procedure AssignTo(Dest: TPersistent); override;
  1163.   published
  1164.     property Name: string read FName write FName;
  1165.     property EffectType: TForceFeedbackEffectType read FEffectType write FEffectType;
  1166.     property AttackLevel: Integer read FAttackLevel write FAttackLevel default 0;
  1167.     property AttackTime: Integer read FAttackTime write FAttackTime default 0;
  1168.     property ConditionX: Integer read FConditionX write FConditionX default 0;
  1169.     property ConditionY: Integer read FConditionY write FConditionY default 0;
  1170.     property ConstantX: Integer read FConstantX write FConstantX default 0;
  1171.     property ConstantY: Integer read FConstantY write FConstantY default 0;
  1172.     property FadeLevel: Integer read FFadeLevel write FFadeLevel default 0;
  1173.     property FadeTime: Integer read FFadeTime write FFadeTime default 0;
  1174.     property Period: Integer read FPeriod write FPeriod;
  1175.     property Power: Integer read FPower write FPower;
  1176.     property Time: Integer read FTime write FTime;
  1177.     property StartDelayTime: Integer read FStartDelayTime write FStartDelayTime;
  1178.     property Effects: TCollection read FEffects write FEffects stored GetStoredEffects;
  1179.   end;
  1180.  
  1181.   TForceFeedbackEffectComponent = class(TComponent)
  1182.   private
  1183.     FEffects: TCollection;
  1184.   published
  1185.     property Effects: TCollection read FEffects write FEffects;
  1186.   end;
  1187.  
  1188. constructor TForceFeedbackEffectItem.Create(Collection: TCollection);
  1189. begin
  1190.   inherited Create(Collection);
  1191.   FEffects := TCollection.Create(TForceFeedbackEffectItem);
  1192. end;
  1193.  
  1194. destructor TForceFeedbackEffectItem.Destroy;
  1195. begin
  1196.   FEffects.Free;
  1197.   inherited Destroy;
  1198. end;
  1199.  
  1200. procedure TForceFeedbackEffectItem.Assign(Source: TPersistent);
  1201. var
  1202.   Effect: TForceFeedbackEffect;
  1203.   i: Integer;
  1204. begin
  1205.   Effect := Source as TForceFeedbackEffect;
  1206.  
  1207.   FName := Effect.Name;
  1208.   FEffectType := Effect.EffectType;
  1209.   FAttackLevel := Effect.AttackLevel;
  1210.   FAttackTime := Effect.AttackTime;
  1211.   FConditionX := Effect.Condition.X;
  1212.   FConditionY := Effect.Condition.Y;
  1213.   FConstantX := Effect.Constant.X;
  1214.   FConstantY := Effect.Constant.Y;
  1215.   FFadeLevel := Effect.FadeLevel;
  1216.   FFadeTime := Effect.FadeTime;
  1217.   FPeriod := Effect.Period;
  1218.   FPower := Effect.Power;
  1219.   FTime := Effect.Time;
  1220.   FStartDelayTime := Effect.StartDelayTime;
  1221.  
  1222.   for i:=0 to Effect.Count-1 do
  1223.     TForceFeedbackEffectItem.Create(FEffects).Assign(Effect[i]);
  1224. end;
  1225.  
  1226. procedure TForceFeedbackEffectItem.AssignTo(Dest: TPersistent);
  1227. var
  1228.   Effect: TForceFeedbackEffect;
  1229.   i: Integer;
  1230. begin
  1231.   Effect := Dest as TForceFeedbackEffect;
  1232.  
  1233.   Effect.EffectType := etNone;
  1234.  
  1235.   Effect.Name := FName;
  1236.   Effect.AttackLevel := FAttackLevel;
  1237.   Effect.AttackTime := FAttackTime;
  1238.   Effect.Condition := Point(FConditionX, FConditionY);
  1239.   Effect.Constant := Point(FConstantX, FConstantY);
  1240.   Effect.FadeLevel := FFadeLevel;
  1241.   Effect.FadeTime := FFadeTime;
  1242.   Effect.Period := FPeriod;
  1243.   Effect.Power := FPower;
  1244.   Effect.Time := FTime;
  1245.   Effect.StartDelayTime := FStartDelayTime;
  1246.  
  1247.   Effect.EffectType := FEffectType;
  1248.  
  1249.   for i:=0 to FEffects.Count-1 do
  1250.     TForceFeedbackEffectItem(FEffects.Items[i]).AssignTo(TForceFeedbackEffect.Create(Effect));
  1251. end;
  1252.  
  1253. function TForceFeedbackEffectItem.GetStoredEffects: Boolean;
  1254. begin
  1255.   Result := FEffects.Count>0;
  1256. end;
  1257.  
  1258. procedure TForceFeedbackEffect.LoadFromFile(const FileName: string);
  1259. var
  1260.   Stream: TFileStream;
  1261. begin
  1262.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  1263.   try
  1264.     LoadFromStream(Stream);
  1265.   finally
  1266.     Stream.Free;
  1267.   end;
  1268. end;
  1269.  
  1270. procedure TForceFeedbackEffect.LoadFromStream(Stream: TStream);
  1271. var
  1272.   Component: TForceFeedbackEffectComponent;
  1273. begin
  1274.   Clear;
  1275.  
  1276.   Component := TForceFeedbackEffectComponent(FRoot.FComponent);
  1277.   try
  1278.     Component.FEffects := TCollection.Create(TForceFeedbackEffectItem);
  1279.     Stream.ReadComponentRes(Component);
  1280.     TForceFeedbackEffectItem(Component.FEffects.Items[0]).AssignTo(Self);
  1281.   finally
  1282.     Component.FEffects.Free;
  1283.     Component.FEffects := nil;
  1284.   end;
  1285. end;
  1286.  
  1287. procedure TForceFeedbackEffect.SaveToFile(const FileName: string);
  1288. var
  1289.   Stream: TFileStream;
  1290. begin
  1291.   Stream := TFileStream.Create(FileName, fmCreate);
  1292.   try
  1293.     SaveToStream(Stream);
  1294.   finally
  1295.     Stream.Free;
  1296.   end;
  1297. end;
  1298.  
  1299. procedure TForceFeedbackEffect.SaveToStream(Stream: TStream);
  1300. var
  1301.   Component: TForceFeedbackEffectComponent;
  1302. begin
  1303.   Component := TForceFeedbackEffectComponent(FRoot.FComponent);
  1304.   try
  1305.     Component.FEffects := TCollection.Create(TForceFeedbackEffectItem);
  1306.     TForceFeedbackEffectItem.Create(Component.FEffects).Assign(Self);
  1307.     Stream.WriteComponentRes('DelphiXForceFeedbackEffect', Component);
  1308.   finally
  1309.     Component.FEffects.Free;
  1310.     Component.FEffects := nil;
  1311.   end;
  1312. end;
  1313.  
  1314. {  TForceFeedbackEffects  }
  1315.  
  1316. constructor TForceFeedbackEffects.Create(Input: TCustomInput);
  1317. begin
  1318.   inherited Create(nil);
  1319.   FInput := Input;
  1320.   FComponent := TForceFeedbackEffectComponent.Create(nil);
  1321. end;
  1322.  
  1323. destructor TForceFeedbackEffects.Destroy;
  1324. begin
  1325.   FComponent.Free;
  1326.   inherited Destroy;
  1327. end;
  1328.  
  1329. procedure TForceFeedbackEffects.DefineProperties(Filer: TFiler);
  1330. begin
  1331.   inherited DefineProperties(Filer);
  1332.   Filer.DefineBinaryProperty('Effects', LoadFromStream, SaveToStream, True);
  1333. end;
  1334.  
  1335. {  TCustomInput  }
  1336.  
  1337. constructor TCustomInput.Create(DXInput: TCustomDXInput);
  1338. begin
  1339.   inherited Create;
  1340.   FDXInput := DXInput;
  1341.   FDXInput.FDevice.Add(Self);
  1342.   FEffects := TForceFeedbackEffects.Create(Self);
  1343.   FEnabled := True;
  1344.   FBindInputStates := True;
  1345. end;
  1346.  
  1347. destructor TCustomInput.Destroy;
  1348. begin
  1349.   Finalize;
  1350.   FEffects.Free;
  1351.   FDXInput.FDevice.Remove(Self);
  1352.   inherited Destroy;
  1353. end;
  1354.  
  1355. procedure TCustomInput.Acquire;
  1356. begin
  1357.   if FDXInput.FActiveOnly and (GetForegroundWindow<>FDXInput.FForm.Handle) then
  1358.     Exit;
  1359.  
  1360.   if FDevice<>nil then
  1361.     FDevice.Acquire;
  1362.  
  1363.   FEffects.Acquire;
  1364. end;
  1365.  
  1366. procedure TCustomInput.Finalize;
  1367. begin
  1368.   if FDevice<>nil then FDevice.Unacquire;
  1369.   FInitialized := False;
  1370.   FButtonCount := 0;
  1371.   FEffects.Finalize;
  1372.   FDevice := nil;
  1373.   FDevice2 := nil;
  1374.   FForceFeedbackDevice := False;
  1375.   FStates := [];
  1376. end;
  1377.  
  1378. procedure TCustomInput.Initialize;
  1379. begin
  1380.   FInitialized := True;
  1381.   FEffects.Initialize;
  1382. end;
  1383.  
  1384. function TCustomInput.GetButton(Index: Integer): Boolean;
  1385. begin
  1386.   if Index in [0..31] then
  1387.     Result := TDXInputState(Integer(isButton1)+Index) in FStates
  1388.   else
  1389.     Result := False;
  1390. end;
  1391.  
  1392. function TCustomInput.GetCooperativeLevel: Integer;
  1393. const
  1394.   Levels: array[Boolean] of Integer = (DISCL_NONEXCLUSIVE, DISCL_EXCLUSIVE);
  1395.   Levels2: array[Boolean] of Integer = (DISCL_BACKGROUND, DISCL_FOREGROUND);
  1396. begin
  1397.   Result := Levels[FForceFeedbackDevice and FForceFeedback] or Levels2[FDXInput.ActiveOnly];
  1398. end;
  1399.  
  1400. function TCustomInput.GetDeviceState(dwSize: Integer; var Data): Boolean;
  1401. var
  1402.   hr: HRESULT;
  1403. begin
  1404.   FillChar(Data, dwSize, 0);
  1405.  
  1406.   if FDevice<>nil then
  1407.   begin
  1408.     hr := FDevice.GetDeviceState(dwSize, Data);
  1409.     if (hr=DIERR_INPUTLOST) or (hr=DIERR_NOTACQUIRED) then
  1410.     begin
  1411.       FDevice.Acquire;
  1412.       hr := FDevice.GetDeviceState(dwSize, Data);
  1413.     end;
  1414.     Result := hr=DI_OK;
  1415.   end else
  1416.     Result := False;
  1417. end;
  1418.  
  1419. function TCustomInput.SetDataFormat: Boolean;
  1420.  
  1421.   function DIEnumDeviceObjectsProc(const peff: TDIDeviceObjectInstanceA;
  1422.     pvRef: Pointer): HRESULT; stdcall;
  1423.   begin
  1424.     Result := DIENUM_CONTINUE;
  1425.  
  1426.     if CompareMem(@peff.guidType, @GUID_Unknown, SizeOf(TGUID)) then Exit;
  1427.  
  1428.     with TCustomInput(pvRef) do
  1429.     begin
  1430.       if peff.dwOfs<FDataFormat.dwDataSize then
  1431.       begin
  1432.         FDataFormatGUIDs[FDataFormat.dwNumObjs] := peff.guidType;
  1433.  
  1434.         with FDataFormatObjects[FDataFormat.dwNumObjs] do
  1435.         begin
  1436.           pguid := @FDataFormatGUIDs[FDataFormat.dwNumObjs];
  1437.           dwOfs := peff.dwOfs;
  1438.           dwType := peff.dwType;
  1439.           dwFlags := 0;
  1440.         end;
  1441.         Inc(FDataFormat.dwNumObjs);
  1442.       end;
  1443.     end;
  1444.   end;
  1445.  
  1446. begin
  1447.   Result := False;
  1448.   if FDevice<>nil then
  1449.   begin
  1450.     with FDataFormat do
  1451.     begin
  1452.       dwSize := SizeOf(FDataFormat);
  1453.       dwObjSize := SizeOf(TDIObjectDataFormat);
  1454.       dwNumObjs := 0;
  1455.       rgodf := @FDataFormatObjects;
  1456.     end;
  1457.  
  1458.     FDevice.EnumObjects(@DIEnumDeviceObjectsProc, Self, DIDFT_ALL);
  1459.     if FDevice.SetDataFormat(FDataFormat)<>DI_OK then Exit;
  1460.   end;
  1461.   Result := True;
  1462. end;
  1463.  
  1464. procedure TCustomInput.SetEffects(Value: TForceFeedbackEffects);
  1465. begin
  1466.   FEffects.Assign(Value);
  1467. end;
  1468.  
  1469. procedure TCustomInput.SetEnabled(Value: Boolean);
  1470. begin
  1471.   if FEnabled<>Value then
  1472.   begin
  1473.     FEnabled := Value;
  1474.     if FDXInput.ComponentState*[csLoading, csReading]=[] then
  1475.       Initialize;
  1476.   end;
  1477. end;
  1478.  
  1479. procedure TCustomInput.SetForceFeedback(Value: Boolean);
  1480. begin
  1481.   if FForceFeedback<>Value then
  1482.   begin
  1483.     FForceFeedback := Value;
  1484.     if FDXInput.ComponentState*[csLoading, csReading]=[] then
  1485.       Initialize;
  1486.   end;
  1487. end;
  1488.  
  1489. procedure TCustomInput.SetWindowHandle(Value: Integer);
  1490. begin
  1491.   if FDevice<>nil then
  1492.     FDevice.SetCooperativeLevel(Value, GetCooperativeLevel);
  1493. end;
  1494.  
  1495. {  TKeyboard  }
  1496.  
  1497. constructor TKeyboard.Create(DXInput: TCustomDXInput);
  1498. begin
  1499.   inherited Create(DXInput);
  1500.   KeyAssigns := DefKeyAssign;
  1501. end;
  1502.  
  1503. procedure TKeyboard.DefineProperties(Filer: TFiler);
  1504. begin
  1505.   inherited DefineProperties(Filer);
  1506.   Filer.DefineBinaryProperty('Aissgns', ReadAssigns, WriteAssigns, False);
  1507.   Filer.DefineBinaryProperty('Assigns', ReadAssigns, WriteAssigns, True);
  1508. end;
  1509.  
  1510. function TKeyboard.GetKey(Key: Integer): Boolean;
  1511. begin
  1512.   if Key in [1..255] then
  1513.     Result := FKeyStates[Key] and $80<>0
  1514.   else
  1515.     Result := False;
  1516. end;
  1517.  
  1518. procedure TKeyboard.Finalize;
  1519. begin
  1520.   FillChar(FKeyStates, SizeOf(FKeyStates), 0);
  1521.   inherited Finalize;
  1522. end;
  1523.  
  1524. procedure TKeyboard.Initialize;
  1525. begin
  1526.   Finalize;
  1527.  
  1528.   if (not FEnabled) or (csDesigning in FDXInput.ComponentState) then Exit;
  1529.  
  1530.   if FDXInput.FDInput<>nil then
  1531.   begin
  1532.     if FDXInput.FDInput.CreateDevice(GUID_SysKeyboard, FDevice, nil)<>DI_OK then Exit;
  1533.     FDevice.SetDataFormat(c_dfDIKeyboard);
  1534.   end;
  1535.  
  1536.   FButtonCount := 32;
  1537.  
  1538.   inherited Initialize;
  1539. end;
  1540.  
  1541. procedure TKeyboard.Update;
  1542.  
  1543.   function DIKEYtoVK(Key: Byte): Integer;
  1544.   begin
  1545.     Result := 0;
  1546.     case Key of
  1547.       DIK_ESCAPE       : Result := VK_ESCAPE;
  1548.       DIK_1            : Result := Ord('1');
  1549.       DIK_2            : Result := Ord('2');
  1550.       DIK_3            : Result := Ord('3');
  1551.       DIK_4            : Result := Ord('4');
  1552.       DIK_5            : Result := Ord('5');
  1553.       DIK_6            : Result := Ord('6');
  1554.       DIK_7            : Result := Ord('7');
  1555.       DIK_8            : Result := Ord('8');
  1556.       DIK_9            : Result := Ord('9');
  1557.       DIK_0            : Result := Ord('0');
  1558.       DIK_EQUALS       : Result := Ord('=');
  1559.       DIK_BACK         : Result := VK_BACK;
  1560.       DIK_TAB          : Result := VK_TAB;
  1561.       DIK_Q            : Result := Ord('Q');
  1562.       DIK_W            : Result := Ord('W');
  1563.       DIK_E            : Result := Ord('E');
  1564.       DIK_R            : Result := Ord('R');
  1565.       DIK_T            : Result := Ord('T');
  1566.       DIK_Y            : Result := Ord('Y');
  1567.       DIK_U            : Result := Ord('U');
  1568.       DIK_I            : Result := Ord('I');
  1569.       DIK_O            : Result := Ord('O');
  1570.       DIK_P            : Result := Ord('P');
  1571.       DIK_LBRACKET     : Result := Ord('[');
  1572.       DIK_RBRACKET     : Result := Ord(']');
  1573.       DIK_RETURN       : Result := VK_RETURN;
  1574.       DIK_LCONTROL     : Result := VK_CONTROL;
  1575.       DIK_A            : Result := Ord('A');
  1576.       DIK_S            : Result := Ord('S');
  1577.       DIK_D            : Result := Ord('D');
  1578.       DIK_F            : Result := Ord('F');
  1579.       DIK_G            : Result := Ord('G');
  1580.       DIK_H            : Result := Ord('H');
  1581.       DIK_J            : Result := Ord('J');
  1582.       DIK_K            : Result := Ord('K');
  1583.       DIK_L            : Result := Ord('L');
  1584.       DIK_SEMICOLON    : Result := Ord(';');
  1585.       DIK_APOSTROPHE   : Result := Ord('''');
  1586.       DIK_LSHIFT       : Result := VK_SHIFT;
  1587.       DIK_BACKSLASH    : Result := Ord('\');
  1588.       DIK_Z            : Result := Ord('Z');
  1589.       DIK_X            : Result := Ord('X');
  1590.       DIK_C            : Result := Ord('C');
  1591.       DIK_V            : Result := Ord('V');
  1592.       DIK_B            : Result := Ord('B');
  1593.       DIK_N            : Result := Ord('N');
  1594.       DIK_M            : Result := Ord('M');
  1595.       DIK_COMMA        : Result := Ord(',');
  1596.       DIK_PERIOD       : Result := Ord('.');
  1597.       DIK_SLASH        : Result := Ord('/');
  1598.       DIK_RSHIFT       : Result := VK_SHIFT;
  1599.       DIK_MULTIPLY     : Result := Ord('*');
  1600.       DIK_LMENU        : Result := VK_MENU;
  1601.       DIK_SPACE        : Result := VK_SPACE;
  1602.       DIK_CAPITAL      : Result := VK_CAPITAL;
  1603.       DIK_F1           : Result := VK_F1;
  1604.       DIK_F2           : Result := VK_F2;
  1605.       DIK_F3           : Result := VK_F3;
  1606.       DIK_F4           : Result := VK_F4;
  1607.       DIK_F5           : Result := VK_F5;
  1608.       DIK_F6           : Result := VK_F6;
  1609.       DIK_F7           : Result := VK_F7;
  1610.       DIK_F8           : Result := VK_F8;
  1611.       DIK_F9           : Result := VK_F9;
  1612.       DIK_F10          : Result := VK_F10;
  1613.       DIK_NUMLOCK      : Result := VK_NUMLOCK;
  1614.       DIK_SCROLL       : Result := VK_SCROLL;
  1615.       DIK_NUMPAD7      : Result := VK_NUMPAD7;
  1616.       DIK_NUMPAD8      : Result := VK_NUMPAD8;
  1617.       DIK_NUMPAD9      : Result := VK_NUMPAD9;
  1618.       DIK_SUBTRACT     : Result := VK_SUBTRACT;
  1619.       DIK_NUMPAD4      : Result := VK_NUMPAD4;
  1620.       DIK_NUMPAD5      : Result := VK_NUMPAD5;
  1621.       DIK_NUMPAD6      : Result := VK_NUMPAD6;
  1622.       DIK_ADD          : Result := VK_ADD;
  1623.       DIK_NUMPAD1      : Result := VK_NUMPAD1;
  1624.       DIK_NUMPAD2      : Result := VK_NUMPAD2;
  1625.       DIK_NUMPAD3      : Result := VK_NUMPAD3;
  1626.       DIK_NUMPAD0      : Result := VK_NUMPAD0;
  1627.       DIK_DECIMAL      : Result := VK_DECIMAL;
  1628.       DIK_F11          : Result := VK_F11;
  1629.       DIK_F12          : Result := VK_F12;
  1630.       DIK_NUMPADENTER  : Result := VK_RETURN;
  1631.       DIK_RCONTROL     : Result := VK_CONTROL;
  1632.       DIK_DIVIDE       : Result := VK_DIVIDE;
  1633.       DIK_RMENU        : Result := VK_MENU;
  1634.       DIK_HOME         : Result := VK_HOME;
  1635.       DIK_UP           : Result := VK_UP;
  1636.       DIK_PRIOR        : Result := VK_PRIOR;
  1637.       DIK_LEFT         : Result := VK_LEFT;
  1638.       DIK_RIGHT        : Result := VK_RIGHT;
  1639.       DIK_END          : Result := VK_END;
  1640.       DIK_DOWN         : Result := VK_DOWN;
  1641.       DIK_NEXT         : Result := VK_NEXT;
  1642.       DIK_INSERT       : Result := VK_INSERT;
  1643.       DIK_DELETE       : Result := VK_DELETE;
  1644.       DIK_LWIN         : Result := VK_LWIN;
  1645.       DIK_RWIN         : Result := VK_RWIN;
  1646.       DIK_APPS         : Result := VK_APPS;
  1647.     end;
  1648.   end;
  1649.  
  1650. var      
  1651.   j: Integer;
  1652.   i: TDXInputState;
  1653.   dikb: TDIKeyboardState;
  1654. begin
  1655.   FillChar(FKeyStates, SizeOf(FKeyStates), 0);
  1656.   FStates := [];
  1657.  
  1658.   if (not FInitialized) or FDXInput.FActiveOnly and (GetForegroundWindow<>FDXInput.FForm.Handle) then
  1659.     Exit;
  1660.  
  1661.   if FDevice<>nil then
  1662.   begin
  1663.     FillChar(dikb, SizeOf(dikb), 0);
  1664.  
  1665.     if GetDeviceState(SizeOf(dikb), dikb) then
  1666.     begin
  1667.       {  The DirectInput key code is converted into the Windows virtual key code.  }
  1668.       for j:=Low(dikb) to High(dikb) do
  1669.         if dikb[j] and $80<>0 then
  1670.           FKeyStates[Byte(DIKEYtoVK(j))] := $80;
  1671.     end;
  1672.   end else
  1673.   begin          
  1674.     GetKeyboardState(FKeyStates);
  1675.   end;
  1676.  
  1677.   for i:=LOW(TDXInputState) to HIGH(TDXInputState) do
  1678.   begin
  1679.     for j:=0 to 2 do
  1680.       if Keys[KeyAssigns[i, j]] then
  1681.       begin
  1682.         FStates := FStates + [i];
  1683.         Break;
  1684.       end;
  1685.   end;
  1686. end;
  1687.  
  1688. procedure TKeyboard.ReadAssigns(Stream: TStream);
  1689. begin
  1690.   Stream.ReadBuffer(KeyAssigns, SizeOf(KeyAssigns));
  1691. end;
  1692.  
  1693. procedure TKeyboard.WriteAssigns(Stream: TStream);
  1694. begin
  1695.   Stream.WriteBuffer(KeyAssigns, SizeOf(KeyAssigns));
  1696. end;
  1697.  
  1698. {  TMouse  }
  1699.  
  1700. constructor TMouse.Create(DXInput: TCustomDXInput);
  1701. begin
  1702.   inherited Create(DXInput);
  1703.   BindInputStates := False;
  1704.   Enabled := False;
  1705. end;              
  1706.  
  1707. function TMouse.GetX: Integer;
  1708. begin
  1709.   Result := Fdims.lX;
  1710. end;
  1711.  
  1712. function TMouse.GetY: Integer;
  1713. begin
  1714.   Result := Fdims.lY;
  1715. end;
  1716.  
  1717. function TMouse.GetZ: Integer;
  1718. begin
  1719.   Result := Fdims.lZ;
  1720. end;
  1721.  
  1722. procedure TMouse.Finalize;
  1723. begin
  1724.   FillChar(Fdims, SizeOf(Fdims), 0);
  1725.   inherited Finalize;
  1726. end;
  1727.  
  1728. procedure TMouse.Initialize;
  1729. begin
  1730.   Finalize;
  1731.  
  1732.   if (not FEnabled) or (csDesigning in FDXInput.ComponentState) then Exit;
  1733.  
  1734.   if FDXInput.FDInput<>nil then
  1735.   begin
  1736.     if FDXInput.FDInput.CreateDevice(GUID_SysMouse, FDevice, nil)<>DI_OK then Exit;
  1737.     FDevice.SetDataFormat(c_dfDIMouse);
  1738.   end else
  1739.     raise EDXInputError.Create(SNecessaryDirectInputUseMouse);
  1740.  
  1741.   FButtonCount := 3;
  1742.  
  1743.   inherited Initialize;
  1744. end;
  1745.  
  1746. procedure TMouse.Update;
  1747. begin
  1748.   FillChar(Fdims, SizeOf(Fdims), 0);
  1749.   FStates := [];
  1750.  
  1751.   if (not FInitialized) or FDXInput.FActiveOnly and (GetForegroundWindow<>FDXInput.FForm.Handle) then
  1752.     Exit;
  1753.  
  1754.   if FDevice<>nil then
  1755.   begin
  1756.     FillChar(Fdims, SizeOf(Fdims), 0);
  1757.     GetDeviceState(SizeOf(Fdims), Fdims);
  1758.   end;
  1759.  
  1760.   if Fdims.lX<0 then FStates := FStates + [isLeft];
  1761.   if Fdims.lX>0 then FStates := FStates + [isRight];
  1762.   if Fdims.lY<0 then FStates := FStates + [isUp];
  1763.   if Fdims.lY>0 then FStates := FStates + [isDown];
  1764.  
  1765.   if Fdims.rgbButtons[0] and $80<>0 then FStates := FStates + [isButton1];
  1766.   if Fdims.rgbButtons[1] and $80<>0 then FStates := FStates + [isButton2];
  1767.   if Fdims.rgbButtons[2] and $80<>0 then FStates := FStates + [isButton3];
  1768. end;
  1769.  
  1770. {  TJoystick  }
  1771.  
  1772. function SetDWORDProperty(pdev: IDirectInputDevice; guidProperty: PGUID;
  1773.   dwObject, dwHow, dwValue: DWORD): HResult;
  1774. var
  1775.   dipdw: TDIPropDWORD;
  1776. begin
  1777.   dipdw.diph.dwSize       := SizeOf(dipdw);
  1778.   dipdw.diph.dwHeaderSize := SizeOf(dipdw.diph);
  1779.   dipdw.diph.dwObj        := dwObject;
  1780.   dipdw.diph.dwHow        := dwHow;
  1781.   dipdw.dwData            := dwValue;
  1782.  
  1783.   Result := pdev.SetProperty(guidProperty, dipdw.diph);
  1784. end;
  1785.  
  1786. function SetRangeProperty(pdev: IDirectInputDevice; guidProperty: PGUID;
  1787.   dwObject, dwHow, Value: DWORD): HResult;
  1788. var
  1789.   diprg: TDIPropRange;
  1790. begin
  1791.   diprg.diph.dwSize       := SizeOf(diprg);
  1792.   diprg.diph.dwHeaderSize := SizeOf(diprg.diph);
  1793.   diprg.diph.dwObj        := dwObject;
  1794.   diprg.diph.dwHow        := dwHow;
  1795.   diprg.lMin              := -Value;
  1796.   diprg.lMax              := +Value;
  1797.  
  1798.   Result := pdev.SetProperty(guidProperty, diprg.diph);
  1799. end;
  1800.  
  1801. constructor TJoystick.Create(DXInput: TCustomDXInput);
  1802. begin
  1803.   inherited Create(DXInput);
  1804.   FAutoCenter := True;
  1805.  
  1806.   FID := 0;
  1807.  
  1808.   DeadZoneX := 50;
  1809.   DeadZoneY := 50;
  1810.   DeadZoneZ := 50;
  1811.  
  1812.   RangeX := 1000;
  1813.   RangeY := 1000;
  1814.   RangeZ := 1000;
  1815. end;
  1816.  
  1817. function TJoystick.GetX: Integer;
  1818. begin
  1819.   Result := Fdijs.lX;
  1820. end;
  1821.  
  1822. function TJoystick.GetY: Integer;
  1823. begin
  1824.   Result := Fdijs.lY;
  1825. end;
  1826.  
  1827. function TJoystick.GetZ: Integer;
  1828. begin
  1829.   Result := Fdijs.lZ;
  1830. end;
  1831.  
  1832. procedure TJoystick.Finalize;
  1833. begin
  1834.   FID2 := -1;
  1835.   FillChar(Fdijs, SizeOf(Fdijs), 0);
  1836.   FillChar(FJoyCaps, SizeOf(FJoyCaps), 0);
  1837.   inherited Finalize;
  1838. end;
  1839.  
  1840. function TJoystick.GetCooperativeLevel: Integer;
  1841. begin
  1842.   if not FAutoCenter then
  1843.     Result := DISCL_EXCLUSIVE or DISCL_FOREGROUND
  1844.   else
  1845.     Result := inherited GetCooperativeLevel;
  1846. end;
  1847.                                                        
  1848. function TJoystick_EnumJoysticksCallback(const lpddi: TDIDeviceInstanceA;
  1849.   pvRef: Pointer): HRESULT; stdcall;
  1850. begin
  1851.   Result := DIENUM_CONTINUE;
  1852.  
  1853.   with TJoystick(pvRef) do
  1854.   begin
  1855.     if FEnumIndex=FID then
  1856.     begin
  1857.       FDeviceGUID := lpddi.guidInstance;
  1858.       FEnumFlag := True;
  1859.       Result := DIENUM_STOP;
  1860.       Exit;
  1861.     end;
  1862.     Inc(FEnumIndex);
  1863.   end;
  1864. end;
  1865.  
  1866. procedure TJoystick.Initialize;
  1867. var
  1868.   i, j: Integer;
  1869.   devcaps: TDIDevCaps;
  1870. begin        
  1871.   Finalize;
  1872.  
  1873.   if (not FEnabled) or (FID<0) or (csDesigning in FDXInput.ComponentState) then Exit;
  1874.  
  1875.   try
  1876.     try
  1877.       if FDXInput.FDInput<>nil then
  1878.       begin
  1879.         {  Device search.  }
  1880.         FEnumFlag := False;
  1881.         FEnumIndex := 0;
  1882.  
  1883.         FDXInput.FDInput.EnumDevices(DIDEVTYPE_JOYSTICK, @TJoystick_EnumJoysticksCallback,
  1884.           Self, DIEDFL_ATTACHEDONLY);
  1885.  
  1886.         if not FEnumFlag then Exit;
  1887.  
  1888.         {  Device making.  }
  1889.         if FDXInput.FDInput.CreateDevice(FDeviceGUID, FDevice, nil)<>DI_OK then Exit;
  1890.  
  1891.         devcaps.dwSize := SizeOf(devcaps);
  1892.         if FDevice.GetCapabilities(devcaps)=DI_OK then
  1893.         begin
  1894.           FButtonCount := devcaps.dwButtons;
  1895.           if devcaps.dwFlags and DIDC_FORCEFEEDBACK<>0 then
  1896.             FForceFeedbackDevice := True;
  1897.         end;
  1898.  
  1899.         if FDXInput.FDInput.CreateDevice(GUID_Joystick, FDevice, nil)<>DI_OK then Exit;
  1900.  
  1901.         {  Device data format (TDIDataFormat) making.  }
  1902.  
  1903.         with FDataFormat do
  1904.         begin
  1905.           dwFlags := DIDF_ABSAXIS;
  1906.           dwDataSize := SizeOf(Fdijs);
  1907.         end;            
  1908.  
  1909.         if not SetDataFormat then
  1910.         begin
  1911.           FDevice := nil;
  1912.           Exit;
  1913.         end;
  1914.          
  1915.         AutoCenter := FAutoCenter;
  1916.  
  1917.         for i:=Low(FDeadZone) to High(FDeadZone) do
  1918.           SetDeadZone(i, FDeadZone[i]);
  1919.  
  1920.         for i:=Low(FRange) to High(FRange) do
  1921.           SetRange(i, FRange[i]);
  1922.  
  1923.         FDevice2 := FDevice as IDirectInputDevice2;
  1924.       end;
  1925.     except
  1926.       Finalize;
  1927.       raise;
  1928.     end;
  1929.   finally
  1930.     if FDevice=nil then
  1931.     begin
  1932.       {  Because DirectInput cannot be used,  the GetJoyPosEx function is used.  }
  1933.       FID2 := -1;
  1934.  
  1935.       j := 0;
  1936.       for i:=0 to 255 do
  1937.       begin
  1938.         FillChar(FJoyCaps, SizeOf(FJoyCaps), 0);
  1939.         if joyGetDevCaps(i, @FJoyCaps, SizeOf(FJoyCaps))=JOYERR_NOERROR then
  1940.         begin
  1941.           if FID=j then
  1942.           begin
  1943.             FID2 := i;
  1944.             Break;
  1945.           end;
  1946.           Inc(j);
  1947.         end;
  1948.       end;
  1949.  
  1950.       if FID2<>-1 then
  1951.       begin
  1952.         if joyGetDevCaps(FID2, @FJoyCaps, SizeOf(FJoyCaps))=JOYERR_NOERROR then
  1953.         begin
  1954.           FButtonCount := FJoyCaps.wNumButtons;
  1955.         end else
  1956.         begin
  1957.           FID2 := -1;
  1958.         end;
  1959.       end;
  1960.     end;
  1961.   end;
  1962.  
  1963.   inherited Initialize;
  1964. end;
  1965.  
  1966. procedure TJoystick.SetAutoCenter(Value: Boolean);
  1967. begin
  1968.   FAutoCenter := Value;
  1969.  
  1970.   if FDevice<>nil then
  1971.     SetDWORDProperty(FDevice, DIPROP_AUTOCENTER, 0, DIPH_DEVICE, Ord(Value));
  1972. end;
  1973.  
  1974. procedure TJoystick.SetID(Value: Integer);
  1975. begin
  1976.   if Value<>FID then
  1977.   begin
  1978.     FID := Value;
  1979.     Initialize;
  1980.   end;
  1981. end;
  1982.  
  1983. function TJoystick.GetDeadZone(Obj: Integer): Integer;
  1984. begin
  1985.   Result := 0;
  1986.   if (Obj>=Low(FDeadZone)) and (Obj<High(FDeadZone)) then
  1987.     Result := FDeadZone[Obj];
  1988. end;
  1989.  
  1990. function TJoystick.GetRange(Obj: Integer): Integer;
  1991. begin
  1992.   Result := 0;
  1993.   if (Obj>=Low(FRange)) and (Obj<High(FRange)) then
  1994.     Result := FRange[Obj];
  1995. end;
  1996.  
  1997. procedure TJoystick.SetDeadZone(Obj: Integer; Value: Integer);
  1998. begin
  1999.   if (Obj<Low(FDeadZone)) or (Obj>=High(FDeadZone)) then Exit;
  2000.  
  2001.   if Value<0 then Value := 0;
  2002.   if Value>100 then Value := 100;
  2003.  
  2004.   if Obj=Integer(@PDIJoyState2(nil).rgdwPOV[0]) then
  2005.   begin
  2006.     FDeadZone[Obj] := -1;
  2007.     Exit;
  2008.   end;
  2009.  
  2010.   FDeadZone[Obj] := Value;
  2011.  
  2012.   if FDevice<>nil then
  2013.   begin
  2014.     if SetDWORDProperty(FDevice, DIPROP_DEADZONE, Obj, DIPH_BYOFFSET, Value*100)<>DI_OK then
  2015.       FDeadZone[Obj] := -1;
  2016.   end;
  2017. end;
  2018.  
  2019. procedure TJoystick.SetRange(Obj: Integer; Value: Integer);
  2020. begin
  2021.   if (Obj<Low(FRange)) or (Obj>=High(FRange)) then Exit;
  2022.  
  2023.   if Value<0 then Value := 0;
  2024.  
  2025.   if Obj=Integer(@PDIJoyState2(nil).rgdwPOV[0]) then
  2026.   begin
  2027.     FRange[Obj] := -1;
  2028.     Exit;
  2029.   end;
  2030.  
  2031.   FRange[Obj] := Value;
  2032.  
  2033.   if FDevice<>nil then
  2034.   begin
  2035.     if SetRangeProperty(FDevice, DIPROP_RANGE, Obj, DIPH_BYOFFSET, Value)<>DI_OK then
  2036.       FRange[Obj] := -1;
  2037.   end;
  2038. end;
  2039.  
  2040. procedure TJoystick.Update;
  2041.  
  2042.   function ConvertValue(Value, wXmax, wXmin, DeadZone, Range: Integer): Integer;
  2043.   var
  2044.     c, w: Integer;
  2045.   begin
  2046.     Result := 0;
  2047.  
  2048.     c := (wXmax - wXmin) div 2;
  2049.     Value := Value-c;
  2050.  
  2051.     w := c*DeadZone div 100;
  2052.     c := c - w;
  2053.  
  2054.     if c=0 then Exit;
  2055.  
  2056.     if Abs(Value)>w then
  2057.     begin
  2058.       if Value>0 then
  2059.         Result := MulDiv(Value-w, Range, c)
  2060.       else
  2061.         Result := MulDiv(Value+w, Range, c);
  2062.     end;
  2063.   end;
  2064.  
  2065. var
  2066.   i: Integer;
  2067.   JoyInfo: TJoyInfoEx;
  2068. begin
  2069.   FillChar(Fdijs, SizeOf(Fdijs), 0);
  2070.   FStates := [];
  2071.  
  2072.   if (not FInitialized) or FDXInput.FActiveOnly and (GetForegroundWindow<>FDXInput.FForm.Handle) then
  2073.     Exit;
  2074.  
  2075.   if FDevice<>nil then
  2076.   begin
  2077.     FDevice2.Poll;
  2078.     GetDeviceState(SizeOf(Fdijs), Fdijs);
  2079.   end else
  2080.   begin
  2081.     if FID2<>-1 then
  2082.     begin
  2083.       JoyInfo.dwSize := SizeOf(JoyInfo);
  2084.       JoyInfo.dwFlags := JOY_RETURNX or JOY_RETURNY or JOY_RETURNZ or JOY_RETURNPOV or
  2085.         JOY_RETURNBUTTONS or JOY_RETURNCENTERED;
  2086.  
  2087.       joyGetPosEx(FID2, @JoyInfo);
  2088.  
  2089.       with FJoyCaps do
  2090.         Fdijs.lX := ConvertValue(JoyInfo.wXpos, wXmax, wXmin, FDeadZone[DIJOFS_X], FRange[DIJOFS_X]);
  2091.  
  2092.       with FJoyCaps do
  2093.         Fdijs.lY := ConvertValue(JoyInfo.wYpos, wYmax, wYmin, FDeadZone[DIJOFS_Y], FRange[DIJOFS_Y]);
  2094.  
  2095.       with FJoyCaps do
  2096.         Fdijs.lZ := ConvertValue(JoyInfo.wZpos, wZmax, wZmin, FDeadZone[DIJOFS_Z], FRange[DIJOFS_Z]);
  2097.  
  2098.       Fdijs.rgdwPOV[0] := JoyInfo.dwPOV;
  2099.  
  2100.       for i:=0 to FJoyCaps.wNumButtons-1 do
  2101.         if JoyInfo.wButtons and (1 shl i)<>0 then
  2102.           Fdijs.rgbButtons[i] := $80;
  2103.     end;
  2104.   end;
  2105.  
  2106.   for i:=0 to 31 do
  2107.     if Fdijs.rgbButtons[i] and $80<>0 then
  2108.       FStates := FStates + [TDXInputState(Ord(isButton1)+i)];
  2109.  
  2110.   if Fdijs.lX<0 then FStates := FStates + [isLeft];
  2111.   if Fdijs.lX>0 then FStates := FStates + [isRight];
  2112.   if Fdijs.lY<0 then FStates := FStates + [isUp];
  2113.   if Fdijs.lY>0 then FStates := FStates + [isDown];
  2114. end;
  2115.  
  2116. {  TCustomDXInput  }
  2117.  
  2118. var
  2119.   FDirectInput: IDirectInput;
  2120.   FDirectInputCount: Integer;
  2121.  
  2122. procedure InitDirectInput(out DI: IDirectInput);
  2123. type
  2124.   TDirectInputCreate = function(hinst: THandle; dwVersion: DWORD;
  2125.     out ppDI: IDirectInputA; punkOuter: IUnknown): HRESULT; stdcall;
  2126. begin
  2127.   if FDirectInput=nil then
  2128.   begin
  2129.     try
  2130.       TDirectInputCreate(DXLoadLibrary('DInput.dll', 'DirectInputCreateA'))
  2131.         (HInstance, DIRECTINPUT_VERSION, FDirectInput, nil);
  2132.     except
  2133.       FDirectInput := nil;
  2134.     end;
  2135.   end;
  2136.  
  2137.   DI := FDirectInput;
  2138.   if FDirectInput<>nil then
  2139.     Inc(FDirectInputCount);
  2140. end;
  2141.  
  2142. procedure FinDirectInput(var DI: IDirectInput);
  2143. begin
  2144.   if DI<>nil then
  2145.   begin
  2146.     DI := nil;
  2147.     Dec(FDirectInputCount);
  2148.     if FDirectInputCount<=0 then
  2149.     begin
  2150.       FDirectInputCount := 0;
  2151.       FDirectInput := nil;
  2152.     end;
  2153.   end;
  2154. end;
  2155.  
  2156. constructor TCustomDXInput.Create(AOwner: TComponent);
  2157. var
  2158.   Component: TComponent;
  2159. begin
  2160.   inherited Create(AOwner);
  2161.  
  2162.   FDevice := TList.Create;
  2163.  
  2164.   FActiveOnly := True;
  2165.   FJoystick := TJoystick.Create(Self);
  2166.   FKeyboard := TKeyboard.Create(Self);
  2167.   FMouse := TMouse.Create(Self);
  2168.   FUseDirectInput := True;
  2169.  
  2170.   Component := Owner;
  2171.   while (Component<>nil) and (not (Component is TCustomForm)) do
  2172.     Component := Component.Owner;
  2173.   if Component=nil then
  2174.     raise EDXInputError.CreateFmt(SNoForm, ['Owner']);
  2175.   FForm := TCustomForm(Component);
  2176.  
  2177.   FSubClass := TControlSubClass.Create(FForm, FormWndProc);
  2178. end;
  2179.  
  2180. destructor TCustomDXInput.Destroy;
  2181. begin
  2182.   Finalize;
  2183.   FJoystick.Free;
  2184.   FKeyboard.Free;
  2185.   FMouse.Free;
  2186.   FSubClass.Free;
  2187.   while FDevice.Count>0 do
  2188.     TCustomInput(FDevice[FDevice.Count-1]).Free;
  2189.   FDevice.Free;
  2190.   inherited Destroy;
  2191. end;
  2192.  
  2193. procedure TCustomDXInput.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  2194.  
  2195.   procedure AcquireDevice;
  2196.   var
  2197.     i: Integer;
  2198.   begin
  2199.     for i:=0 to FDevice.Count-1 do
  2200.       TCustomInput(FDevice[i]).Acquire;
  2201.   end;
  2202.  
  2203. begin
  2204.   case Message.Msg of
  2205.     WM_CREATE:
  2206.         begin
  2207.           {  Window handle of Form changed.  }
  2208.           DefWindowProc(Message);
  2209.           SetWindowHandle;
  2210.           Exit;
  2211.         end;
  2212.     WM_ACTIVATEAPP:
  2213.         begin
  2214.           DefWindowProc(Message);
  2215.           if TWMActivateApp(Message).Active then
  2216.             AcquireDevice;
  2217.           Exit;
  2218.         end;
  2219.     WM_ACTIVATE:
  2220.         begin
  2221.           DefWindowProc(Message);
  2222.           if TWMActivate(Message).Active<>WA_INACTIVE then
  2223.             AcquireDevice;
  2224.           Exit;
  2225.         end;
  2226.   end;
  2227.   DefWindowProc(Message);
  2228. end;
  2229.  
  2230. procedure TCustomDXInput.Finalize;
  2231. var
  2232.   i: Integer;
  2233. begin
  2234.   for i:=0 to FDevice.Count-1 do
  2235.     TCustomInput(FDevice[i]).Finalize;
  2236.   FinDirectInput(FDInput);
  2237. end;
  2238.  
  2239. procedure TCustomDXInput.Loaded;
  2240. begin
  2241.   Initialize;
  2242. end;
  2243.  
  2244. procedure TCustomDXInput.Initialize;
  2245. var
  2246.   i: Integer;
  2247. begin
  2248.   Finalize;
  2249.   if not (csDesigning in ComponentState) then
  2250.   begin
  2251.     if FUseDirectInput then InitDirectInput(FDInput);
  2252.  
  2253.     for i:=0 to FDevice.Count-1 do
  2254.       TCustomInput(FDevice[i]).Initialize;
  2255.  
  2256.     SetWindowHandle;
  2257.  
  2258.     Update;
  2259.   end;
  2260. end;
  2261.  
  2262. procedure TCustomDXInput.SetActiveOnly(Value: Boolean);
  2263. begin
  2264.   if Value<>FActiveOnly then
  2265.   begin
  2266.     FActiveOnly := Value;
  2267.     if [csLoading, csReading]*ComponentState=[] then SetWindowHandle;
  2268.   end;
  2269. end;
  2270.  
  2271. procedure TCustomDXInput.SetJoystick(Value: TJoystick);
  2272. begin
  2273.   FJoystick.Assign(Value);
  2274. end;
  2275.  
  2276. procedure TCustomDXInput.SetKeyboard(Value: TKeyboard);
  2277. begin
  2278.   FKeyboard.Assign(Value);
  2279. end;
  2280.  
  2281. procedure TCustomDXInput.SetMouse(Value: TMouse);
  2282. begin
  2283.   FMouse.Assign(Value);
  2284. end;
  2285.  
  2286. procedure TCustomDXInput.SetUseDirectInput(Value: Boolean);
  2287. begin
  2288.   if FUseDirectInput<>Value then
  2289.   begin
  2290.     FUseDirectInput := Value;
  2291.     Initialize;
  2292.   end;
  2293. end;
  2294.  
  2295. procedure TCustomDXInput.SetWindowHandle;
  2296. var
  2297.   i: Integer;
  2298. begin
  2299.   for i:=0 to FDevice.Count-1 do
  2300.     TCustomInput(FDevice[i]).SetWindowHandle(FForm.Handle);
  2301. end;
  2302.  
  2303. procedure TCustomDXInput.Update;
  2304. var
  2305.   j: Integer;
  2306.   i: TDXInputState;
  2307.   s: TDXInputStates;
  2308. begin
  2309.   s := [];
  2310.  
  2311.   for j:=0 to FDevice.Count-1 do
  2312.   begin
  2313.     TCustomInput(FDevice[j]).Update;
  2314.     if TCustomInput(FDevice[j]).FBindInputStates then
  2315.       s := s + TCustomInput(FDevice[j]).States;
  2316.   end;
  2317.  
  2318.   for i:=Low(TDXInputState) to High(TDXInputState) do
  2319.   begin
  2320.     if (i in s) and (not (i in FOldStates)) then
  2321.       FStates := FStates + [i];
  2322.     if (not (i in s)) and (i in FOldStates) then
  2323.       FStates := FStates - [i];
  2324.   end;
  2325.  
  2326.   FOldStates := s;
  2327. end;
  2328.  
  2329. end.
  2330.