WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DXInput.pas

Rev	Author	Line No.	Line
1	daniel-mar	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(XX+YY));
		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(XX+YY));
		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.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXInput.pas – Rev 1