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,
4	daniel-mar	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}
1	daniel-mar	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(XX+YY));
		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(XX+YY));
		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
4	daniel-mar	781	Result := Integer(DIENUM_STOP);
1	daniel-mar	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
4	daniel-mar	790	FRoot.FInput.FDevice2.CreateEffect(GUID, @EffectObject.Feff, EffectObject.FEffect, nil);
1	daniel-mar	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
4	daniel-mar	1421	hr := FDevice.GetDeviceState(dwSize, @Data);
1	daniel-mar	1422	if (hr=DIERR_INPUTLOST) or (hr=DIERR_NOTACQUIRED) then
		1423	begin
		1424	FDevice.Acquire;
4	daniel-mar	1425	hr := FDevice.GetDeviceState(dwSize, @Data);
1	daniel-mar	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
4	daniel-mar	1437	Result := Integer(DIENUM_CONTINUE);
1	daniel-mar	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;
4	daniel-mar	1662	{$IFDEF StandardDX}
		1663	type
		1664	TDIKeyboardState = array[0..255] of Byte;
		1665	{$ENDIF}
		1666	var
1	daniel-mar	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
4	daniel-mar	1867	Result := Integer(DIENUM_CONTINUE);
1	daniel-mar	1868
		1869	with TJoystick(pvRef) do
		1870	begin
		1871	if FEnumIndex=FID then
		1872	begin
		1873	FDeviceGUID := lpddi.guidInstance;
		1874	FEnumFlag := True;
4	daniel-mar	1875	Result := Integer(DIENUM_STOP);
1	daniel-mar	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
4	daniel-mar	1899	FDXInput.FDInput.EnumDevices({DIDEVTYPE_JOYSTICK}4, @TJoystick_EnumJoysticksCallback,
1	daniel-mar	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
4	daniel-mar	1915	//if FDXInput.FDInput.CreateDevice(GUID_Joystick, FDevice, nil)<>DI_OK then Exit; get out by Paul van Dinther
1	daniel-mar	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;
4	daniel-mar	2141	out ppDI: {$IFDEF UNICODE}IDirectInputW{$ELSE}IDirectInputA{$ENDIF}; punkOuter: IUnknown): HRESULT; stdcall;
1	daniel-mar	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
4	daniel-mar	2345	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXInput.pas – Rev 4