Subversion Repositories spacemission

Rev

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