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

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXPlay;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
		8	Windows, SysUtils, Classes, Forms, DXClass, ActiveX, DirectX, DXETable;
		9
		10	type
		11
		12	{ TDXPlayPlayer }
		13
		14	TDXPlayPlayer = class(TCollectionItem)
		15	private
		16	FData: Pointer;
		17	FID: TDPID;
		18	FName: string;
		19	FRemotePlayer: Boolean;
		20	public
		21	property Data: Pointer read FData write FData;
		22	property ID: TDPID read FID;
		23	property Name: string read FName;
		24	property RemotePlayer: Boolean read FRemotePlayer;
		25	end;
		26
		27	{ TDXPlayPlayers }
		28
		29	TDXPlayPlayers = class(TCollection)
		30	private
		31	function GetPlayer(Index: Integer): TDXPlayPlayer;
		32	public
		33	constructor Create;
		34	function Find(ID: TDPID): TDXPlayPlayer;
		35	function IndexOf(ID: TDPID): Integer;
		36	property Players[Index: Integer]: TDXPlayPlayer read GetPlayer; default;
		37	end;
		38
		39	{ TDXPlayModemSetting }
		40
		41	TDXPlayModemSetting = class(TPersistent)
		42	private
		43	FEnabled: Boolean;
		44	FPhoneNumber: string;
		45	FModemName: string;
		46	FModemNames: TStrings;
		47	function GetModemNames: TStrings;
		48	public
		49	destructor Destroy; override;
		50	procedure Assign(Source: TPersistent); override;
		51	property ModemName: string read FModemName write FModemName;
		52	property ModemNames: TStrings read GetModemNames;
		53	published
		54	property Enabled: Boolean read FEnabled write FEnabled;
		55	property PhoneNumber: string read FPhoneNumber write FPhoneNumber;
		56	end;
		57
		58	{ TDXPlayTCPIPSetting }
		59
		60	TDXPlayTCPIPSetting = class(TPersistent)
		61	private
		62	FEnabled: Boolean;
		63	FHostName: string;
		64	FPort: Word;
		65	public
		66	procedure Assign(Source: TPersistent); override;
		67	published
		68	property Enabled: Boolean read FEnabled write FEnabled;
		69	property HostName: string read FHostName write FHostName;
		70	property Port: Word read FPort write FPort;
		71	end;
		72
		73	{ EDXPlayError }
		74
		75	EDXPlayError = class(Exception);
		76
		77	{ TCustomDXPlay }
		78
		79	TDXPlayEvent = procedure(Sender: TObject; Player: TDXPlayPlayer) of object;
		80
		81	TDXPlayMessageEvent = procedure(Sender: TObject; From: TDXPlayPlayer;
		82	Data: Pointer; DataSize: Integer) of object;
		83
		84	TDXPlaySendCompleteResult = (crOk, crAbort, crGeneric);
		85
		86	TDXPlaySendCompleteEvent = procedure(Sender: TObject; MessageID: DWORD;
		87	Result: TDXPlaySendCompleteResult; SendTime: Integer) of object;
		88
		89	TCustomDXPlay = class(TComponent)
		90	private
		91	FDPlay: IDirectPlay4A;
		92	FGUID: string;
		93	FIsHost: Boolean;
		94	FLocalPlayer: TDXPlayPlayer;
		95	FMaxPlayers: Integer;
		96	FPlayers: TDXPlayPlayers;
		97	FCalledDoOpen: Boolean;
		98	FOnAddPlayer: TDXPlayEvent;
		99	FOnClose: TNotifyEvent;
		100	FOnDeletePlayer: TDXPlayEvent;
		101	FOnMessage: TDXPlayMessageEvent;
		102	FOnOpen: TNotifyEvent;
		103	FOnSendComplete: TDXPlaySendCompleteEvent;
		104	FOnSessionLost: TNotifyEvent;
		105	FOpened: Boolean;
		106	FRecvEvent: array[0..1] of THandle;
		107	FRecvThread: TThread;
		108	FInThread: Boolean;
		109	FProviderName: string;
		110	FProviders: TStrings;
		111	FSessionName: string;
		112	FSessions: TStrings;
		113	FReadSessioned: Boolean;
		114	FModemSetting: TDXPlayModemSetting;
		115	FTCPIPSetting: TDXPlayTCPIPSetting;
		116	FAsync: Boolean;
		117	FAsyncSupported: Boolean;
		118	procedure ChangeDPlay;
		119	procedure CreateDPlayWithoutDialog(out DPlay: IDirectPlay4A; const ProviderName: string);
		120	function OpenDPlayWithLobby(out Name: string): Boolean;
		121	function OpenDPlayWithoutLobby(out Name: string): Boolean;
		122	function OpenDPlayWithoutLobby2(const NewSession: Boolean; const ProviderName, SessionName, PlayerName: string): Boolean;
		123	procedure Open_(NameS: string);
		124	procedure ReceiveMessage;
		125	function GetProviders: TStrings;
		126	function GetSessionsPty: TStrings;
		127	procedure ClearSessionList;
		128	procedure SetGUID(const Value: string);
		129	procedure SetModemSetting(Value: TDXPlayModemSetting);
		130	procedure SetProviderName(const Value: string);
		131	procedure SetTCPIPSetting(Value: TDXPlayTCPIPSetting);
		132	protected
		133	procedure DoAddPlayer(Player: TDXPlayPlayer); virtual;
		134	procedure DoClose; virtual;
		135	procedure DoDeletePlayer(Player: TDXPlayPlayer); virtual;
		136	procedure DoMessage(From: TDXPlayPlayer; Data: Pointer; DataSize: Integer); virtual;
		137	procedure DoOpen; virtual;
		138	procedure DoSessionLost; virtual;
		139	procedure DoSendComplete(MessageID: DWORD; Result: TDXPlaySendCompleteResult;
		140	SendTime: Integer); virtual;
		141	public
		142	constructor Create(AOwner: TComponent); override;
		143	destructor Destroy; override;
		144	procedure Close;
		145	procedure Open;
		146	procedure Open2(NewSession: Boolean; const SessionName, PlayerName: string);
		147	function GetProviderNameFromGUID(const ProviderGUID: TGUID): string;
		148	procedure GetSessions;
		149	procedure SendMessage(ToID: TDPID; Data: Pointer; DataSize: Integer);
		150	function SendMessageEx(ToID: TDPID; Data: Pointer; DataSize: Integer;
		151	dwFlags: DWORD): DWORD;
		152	property GUID: string read FGUID write SetGUID;
		153	property IsHost: Boolean read FIsHost;
		154	property LocalPlayer: TDXPlayPlayer read FLocalPlayer;
		155	property MaxPlayers: Integer read FMaxPlayers write FMaxPlayers;
		156	property OnAddPlayer: TDXPlayEvent read FOnAddPlayer write FOnAddPlayer;
		157	property OnClose: TNotifyEvent read FOnClose write FOnClose;
		158	property OnDeletePlayer: TDXPlayEvent read FOnDeletePlayer write FOnDeletePlayer;
		159	property OnMessage: TDXPlayMessageEvent read FOnMessage write FOnMessage;
		160	property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
		161	property OnSendComplete: TDXPlaySendCompleteEvent read FOnSendComplete write FOnSendComplete;
		162	property OnSessionLost: TNotifyEvent read FOnSessionLost write FOnSessionLost;
		163	property Opened: Boolean read FOpened;
		164	property Players: TDXPlayPlayers read FPlayers;
		165	property ProviderName: string read FProviderName write SetProviderName;
		166	property Providers: TStrings read GetProviders;
		167	property SessionName: string read FSessionName;
		168	property Sessions: TStrings read GetSessionsPty;
		169	property ModemSetting: TDXPlayModemSetting read FModemSetting write SetModemSetting;
		170	property TCPIPSetting: TDXPlayTCPIPSetting read FTCPIPSetting write SetTCPIPSetting;
		171	property Async: Boolean read FAsync write FAsync;
		172	property AsyncSupported: Boolean read FAsyncSupported;
		173	end;
		174
		175	TDXPlay = class(TCustomDXPlay)
		176	published
		177	property Async;
		178	property GUID;
		179	property MaxPlayers;
		180	property ModemSetting;
		181	property TCPIPSetting;
		182	property OnAddPlayer;
		183	property OnClose;
		184	property OnDeletePlayer;
		185	property OnMessage;
		186	property OnOpen;
		187	property OnSendComplete;
		188	property OnSessionLost;
		189	end;
		190
		191	function DXPlayMessageType(P: Pointer): DWORD;
		192
		193	function DXPlayStringToGUID(const S: string): TGUID;
		194	function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
		195	pUnk: IUnknown): HRESULT;
		196
		197	implementation
		198
		199	uses DXPlayFm, DXConsts;
		200
		201	function DXPlayMessageType(P: Pointer): DWORD;
		202	begin
		203	Result := PDPMSG_GENERIC(P)^.dwType;
		204	end;
		205
		206	function DXPlayStringToGUID(const S: string): TGUID;
		207	var
		208	ErrorCode: Integer;
		209	begin
		210	ErrorCode := CLSIDFromString(PWideChar(WideString(S)), Result);
		211	if ErrorCode<0 then
		212	raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
		213	end;
		214
		215	function GUIDToString(const ClassID: TGUID): string;
		216	var
		217	ErrorCode: Integer;
		218	P: PWideChar;
		219	begin
		220	ErrorCode := StringFromCLSID(ClassID, P);
		221	if ErrorCode<0 then
		222	raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
		223	Result := P;
		224	CoTaskMemFree(P);
		225	end;
		226
		227	function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
		228	pUnk: IUnknown): HRESULT;
		229	type
		230	TDirectPlayCreate= function(const lpGUID: TGUID; out lplpDP: IDirectPlay; pUnk: IUnknown): HRESULT; stdcall;
		231	begin
		232	Result := TDirectPlayCreate(DXLoadLibrary('DPlayX.dll', 'DirectPlayCreate'))
		233	(lpGUID, lplpDP, pUnk);
		234	end;
		235
		236	function DXDirectPlayEnumerateA(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT;
		237	type
		238	TDirectPlayEnumerateA= function(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT; stdcall;
		239	begin
		240	Result := TDirectPlayEnumerateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayEnumerateA'))
		241	(lpEnumDPCallback, lpContext);
		242	end;
		243
		244	function DXDirectPlayLobbyCreateA(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
		245	lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT;
		246	type
		247	TDirectPlayLobbyCreateA = function(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
		248	lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT; stdcall;
		249	begin
		250	Result := TDirectPlayLobbyCreateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayLobbyCreateA'))
		251	(lpguidSP, lplpDPL, lpUnk, lpData, dwDataSize);
		252	end;
		253
		254	{ TDXPlayPlayers }
		255
		256	constructor TDXPlayPlayers.Create;
		257	begin
		258	inherited Create(TDXPlayPlayer);
		259	end;
		260
		261	function TDXPlayPlayers.Find(ID: TDPID): TDXPlayPlayer;
		262	var
		263	i: Integer;
		264	begin
		265	i := IndexOf(ID);
		266	if i=-1 then
		267	raise EDXPlayError.Create(SDXPlayPlayerNotFound);
		268	Result := Players[i];
		269	end;
		270
		271	function TDXPlayPlayers.IndexOf(ID: TDPID): Integer;
		272	var
		273	i: Integer;
		274	begin
		275	for i:=0 to Count-1 do
		276	if Players[i].FID=ID then
		277	begin
		278	Result := i;
		279	Exit;
		280	end;
		281	Result := -1;
		282	end;
		283
		284	function TDXPlayPlayers.GetPlayer(Index: Integer): TDXPlayPlayer;
		285	begin
		286	Result := TDXPlayPlayer(Items[Index]);
		287	end;
		288
		289	{ TDXPlayModemSetting }
		290
		291	destructor TDXPlayModemSetting.Destroy;
		292	begin
		293	FModemNames.Free;
		294	inherited Destroy;
		295	end;
		296
		297	procedure TDXPlayModemSetting.Assign(Source: TPersistent);
		298	begin
		299	if Source is TDXPlayModemSetting then
		300	begin
		301	FEnabled := TDXPlayModemSetting(Source).FEnabled;
		302	FPhoneNumber := TDXPlayModemSetting(Source).FPhoneNumber;
		303	FModemName := TDXPlayModemSetting(Source).FModemName;
		304	end else
		305	inherited Assign(Source);
		306	end;
		307
		308	function TDXPlayModemSetting.GetModemNames: TStrings;
		309
		310	function EnumModemAddress(const guidDataType: TGUID;
		311	dwDataSize: DWORD; lpData: Pointer; lpContext: Pointer): BOOL; stdcall;
		312	begin
		313	if CompareMem(@guidDataType, @DPAID_Modem, SizeOf(TGUID)) then
		314	TStrings(lpContext).Add( PChar(lpData));
		315	Result := True;
		316	end;
		317
		318	var
		319	Lobby1: IDirectPlayLobbyA;
		320	Lobby: IDirectPlayLobby2A;
		321	DPlay1: IDirectPlay;
		322	DPlay: IDirectPlay4A;
		323	lpAddress: Pointer;
		324	dwAddressSize: DWORD;
		325	begin
		326	if FModemNames=nil then
		327	begin
		328	FModemNames := TStringList.Create;
		329	try
		330	if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then
		331	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		332	Lobby := Lobby1 as IDirectPlayLobby2A;
		333
		334	if DXDirectPlayCreate(DPSPGUID_MODEM, DPlay1, nil)<>0 then
		335	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		336	DPlay := DPlay1 as IDirectPlay4A;
		337
		338	{ get size of player address for all players }
		339	if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, nil^, dwAddressSize)<>DPERR_BUFFERTOOSMALL then
		340	raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);
		341
		342	GetMem(lpAddress, dwAddressSize);
		343	try
		344	FillChar(lpAddress^, dwAddressSize, 0);
		345
		346	{ get the address }
		347	if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, lpAddress^, dwAddressSize)<>0 then
		348	raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);
		349
		350	{ get modem strings from address and put them in the combo box }
		351	if Lobby.EnumAddress(@EnumModemAddress, lpAddress^, dwAddressSize, FModemNames)<>0 then
		352	raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);
		353	finally
		354	FreeMem(lpAddress);
		355	end;
		356	except
		357	FModemNames.Free; FModemNames := nil;
		358	raise;
		359	end;
		360	end;
		361
		362	Result := FModemNames;
		363	end;
		364
		365	{ TDXPlayTCPIPSetting }
		366
		367	procedure TDXPlayTCPIPSetting.Assign(Source: TPersistent);
		368	begin
		369	if Source is TDXPlayTCPIPSetting then
		370	begin
		371	FEnabled := TDXPlayTCPIPSetting(Source).FEnabled;
		372	FHostName := TDXPlayTCPIPSetting(Source).FHostName;
		373	end else
		374	inherited Assign(Source);
		375	end;
		376
		377	{ TCustomDXPlay }
		378
		379	constructor TCustomDXPlay.Create(AOwner: TComponent);
		380	begin
		381	inherited Create(AOwner);
		382	FPlayers := TDXPlayPlayers.Create;
		383	FModemSetting := TDXPlayModemSetting.Create;
		384	FTCPIPSetting := TDXPlayTCPIPSetting.Create;
		385	FSessions := TStringList.Create;
		386
		387	FGUID := GUIDToString(GUID_NULL);
		388	FMaxPlayers := 0;
		389	end;
		390
		391	destructor TCustomDXPlay.Destroy;
		392	var
		393	i: Integer;
		394	begin
		395	Close;
		396
		397	FPlayers.Free;
		398
		399	if FProviders<>nil then
		400	begin
		401	for i:=0 to FProviders.Count-1 do
		402	Dispose(PGUID(FProviders.Objects[i]));
		403	end;
		404	FProviders.Free;
		405	FModemSetting.Free;
		406	FTCPIPSetting.Free;
		407	ClearSessionList;
		408	FSessions.Free;
		409	inherited Destroy;
		410	end;
		411
		412	type
		413	TDXPlayRecvThread = class(TThread)
		414	private
		415	FDXPlay: TCustomDXPlay;
		416	constructor Create(DXPlay: TCustomDXPlay);
		417	destructor Destroy; override;
		418	procedure Execute; override;
		419	end;
		420
		421	constructor TDXPlayRecvThread.Create(DXPlay: TCustomDXPlay);
		422	begin
		423	FDXPlay := DXPlay;
		424
		425	FDXPlay.FRecvEvent[1] := CreateEvent(nil, False, False, nil);
		426
		427	FreeOnTerminate := True;
		428	inherited Create(True);
		429	end;
		430
		431	destructor TDXPlayRecvThread.Destroy;
		432	begin
		433	FreeOnTerminate := False;
		434	SetEvent(FDXPlay.FRecvEvent[1]);
		435
		436	inherited Destroy;
		437
		438	CloseHandle(FDXPlay.FRecvEvent[1]);
		439
		440	FDXPlay.FRecvThread := nil;
		441	FDXPlay.Close;
		442	end;
		443
		444	procedure TDXPlayRecvThread.Execute;
		445	begin
		446	while WaitForMultipleObjects(2, @FDXPlay.FRecvEvent, False, INFINITE)=WAIT_OBJECT_0 do
		447	begin
		448	Synchronize(FDXPlay.ReceiveMessage);
		449	end;
		450	end;
		451
		452	procedure TCustomDXPlay.ReceiveMessage;
		453	var
		454	idFrom, idTo: DWORD;
		455	hr: HRESULT;
		456	lpvMsgBuffer: Pointer;
		457	dwMsgBufferSize: DWORD;
		458	Msg_CreatePlayerOrGroup: PDPMSG_CREATEPLAYERORGROUP;
		459	Msg_DeletePlayerOrGroup: PDPMSG_DESTROYPLAYERORGROUP;
		460	Msg_SendComplete: PDPMsg_SendComplete;
		461	SendCompleteResult: TDXPlaySendCompleteResult;
		462	Player: TDXPlayPlayer;
		463	i: Integer;
		464	begin
		465	FInThread := True;
		466	try
		467	try
		468	lpvMsgBuffer := nil;
		469	dwMsgBufferSize := 0;
		470
		471	try
		472	repeat
		473	hr := FDPlay.Receive(idFrom, idTo, DPRECEIVE_ALL, lpvMsgBuffer^, dwMsgBufferSize);
		474
		475	if hr=DPERR_BUFFERTOOSMALL then
		476	begin
		477	ReAllocMem(lpvMsgBuffer, dwMsgBufferSize);
		478	hr := FDPlay.Receive(idFrom, idTo, DPRECEIVE_ALL, lpvMsgBuffer^, dwMsgBufferSize);
		479	end;
		480
		481	if (hr=0) and (dwMsgBufferSize>=SizeOf(TDPMSG_GENERIC)) then
		482	begin
		483	if idFrom=DPID_SYSMSG then
		484	begin
		485	{ System message }
		486	case PDPMSG_GENERIC(lpvMsgBuffer)^.dwType of
		487	DPSYS_CREATEPLAYERORGROUP:
		488	begin
		489	{ New player }
		490	Msg_CreatePlayerOrGroup := lpvMsgBuffer;
		491
		492	if Msg_CreatePlayerOrGroup.DPID<>FLocalPlayer.FID then
		493	begin
		494	Player := TDXPlayPlayer.Create(Players);
		495	Player.FID := Msg_CreatePlayerOrGroup.DPID;
		496	Player.FRemotePlayer := True;
		497
		498	with Msg_CreatePlayerOrGroup.dpnName do
		499	begin
		500	if lpszShortNameA<>nil then
		501	Player.FName := lpszShortNameA;
		502	end;
		503
		504	DoAddPlayer(Player);
		505	end;
		506	end;
		507	DPSYS_DESTROYPLAYERORGROUP:
		508	begin
		509	{ Player deletion }
		510	Msg_DeletePlayerOrGroup := lpvMsgBuffer;
		511
		512	if Msg_DeletePlayerOrGroup.DPID<>FLocalPlayer.FID then
		513	begin
		514	i := Players.IndexOf(Msg_DeletePlayerOrGroup.DPID);
		515	if i<>-1 then
		516	begin
		517	Player := Players[i];
		518	DoDeletePlayer(Player);
		519	Player.Free;
		520	end;
		521	end;
		522	end;
		523	DPSYS_SESSIONLOST:
		524	begin
		525	{ The session was lost. }
		526	DoSessionLost;
		527	Close;
		528	end;
		529	DPSYS_HOST:
		530	begin
		531	{ Here became a host. }
		532	FIsHost := True;
		533	end;
		534	DPSYS_SENDCOMPLETE:
		535	begin
		536	{ Send complete }
		537	Msg_SendComplete := lpvMsgBuffer;
		538	if Msg_SendComplete.idFrom=FLocalPlayer.FID then
		539	begin
		540	case Msg_SendComplete.hr of
		541	DP_OK : SendCompleteResult := crOk;
		542	DPERR_ABORTED: SendCompleteResult := crAbort;
		543	else SendCompleteResult := crGeneric;
		544	end;
		545
		546	DoSendComplete(Msg_SendComplete^.dwMsgID, SendCompleteResult, Msg_SendComplete^.dwSendTime);
		547	end;
		548	end;
		549	end;
		550	end else
		551	begin
		552	{ Application definition message }
		553	DoMessage(Players.Find(idFrom), lpvMsgBuffer, dwMsgBufferSize);
		554	end;
		555	end;
		556	until hr<>0;
		557	finally
		558	FreeMem(lpvMsgBuffer);
		559	end;
		560	except
		561	on E: Exception do
		562	Application.HandleException(E);
		563	end;
		564	finally
		565	FInThread := False;
		566	end;
		567	end;
		568
		569	procedure TCustomDXPlay.DoAddPlayer(Player: TDXPlayPlayer);
		570	begin
		571	if Assigned(FOnAddPlayer) then FOnAddPlayer(Self, Player)
		572	end;
		573
		574	procedure TCustomDXPlay.DoClose;
		575	begin
		576	if Assigned(FOnClose) then FOnClose(Self);
		577	end;
		578
		579	procedure TCustomDXPlay.DoDeletePlayer(Player: TDXPlayPlayer);
		580	begin
		581	if Assigned(FOnDeletePlayer) then FOnDeletePlayer(Self, Player)
		582	end;
		583
		584	procedure TCustomDXPlay.DoMessage(From: TDXPlayPlayer; Data: Pointer; DataSize: Integer);
		585	begin
		586	if Assigned(FOnMessage) then FOnMessage(Self, From, Data, DataSize);
		587	end;
		588
		589	procedure TCustomDXPlay.DoOpen;
		590	begin
		591	if Assigned(FOnOpen) then FOnOpen(Self);
		592	end;
		593
		594	procedure TCustomDXPlay.DoSessionLost;
		595	begin
		596	if Assigned(FOnSessionLost) then FOnSessionLost(Self);
		597	end;
		598
		599	procedure TCustomDXPlay.DoSendComplete(MessageID: DWORD; Result: TDXPlaySendCompleteResult;
		600	SendTime: Integer);
		601	begin
		602	if Assigned(FOnSendComplete) then FOnSendComplete(Self, MessageID, Result, SendTime);
		603	end;
		604
		605	function TCustomDXPlay.GetProviders: TStrings;
		606
		607	function EnumProviderCallback(const lpguidSP: TGUID; lpSPName: LPSTR;
		608	dwMajorVersion: DWORD; dwMinorVersion: DWORD; lpContext: Pointer):
		609	BOOL; stdcall;
		610	var
		611	GUID: PGUID;
		612	begin
		613	GUID := New(PGUID);
		614	Move(lpguidSP, GUID^, SizeOf(TGUID));
		615	TStrings(lpContext).AddObject(lpSPName, TObject(GUID));
		616	Result := True;
		617	end;
		618
		619	begin
		620	if FProviders=nil then
		621	begin
		622	FProviders := TStringList.Create;
		623	try
		624	DXDirectPlayEnumerateA(@EnumProviderCallback, FProviders);
		625	except
		626	FProviders.Free; FProviders := nil;
		627	raise;
		628	end;
		629	end;
		630
		631	Result := FProviders;
		632	end;
		633
		634	procedure TCustomDXPlay.GetSessions;
		635
		636	function EnumSessionsCallback(const lpThisSD: TDPSessionDesc2;
		637	var lpdwTimeOut: DWORD; dwFlags: DWORD; lpContext: Pointer): BOOL; stdcall;
		638	var
		639	Guid: PGUID;
		640	begin
		641	if dwFlags and DPESC_TIMEDOUT<>0 then
		642	begin
		643	Result := False;
		644	Exit;
		645	end;
		646
		647	Guid := New(PGUID);
		648	Move(lpThisSD.guidInstance, Guid^, SizeOf(TGUID));
		649	TStrings(lpContext).AddObject(lpThisSD.lpszSessionNameA, TObject(Guid));
		650
		651	Result := True;
		652	end;
		653
		654	var
		655	dpDesc: TDPSessionDesc2;
		656	hr: HRESULT;
		657	begin
		658	if FDPlay=nil then
		659	raise EDXPlayError.Create(SDXPlayNotConnectedNow);
		660
		661	ClearSessionList;
		662
		663	FillChar(dpDesc, SizeOf(dpDesc), 0);
		664	dpDesc.dwSize := SizeOf(dpDesc);
		665	dpDesc.guidApplication := DXPlayStringToGUID(FGUID);
		666
		667	hr := FDPlay.EnumSessions(dpDesc, 0, @EnumSessionsCallback, FSessions, DPENUMSESSIONS_AVAILABLE);
		668	if hr=DPERR_USERCANCEL then Abort;
		669	if hr<>0 then
		670	raise EDXPlayError.Create(SDXPlaySessionListCannotBeAcquired);
		671
		672	FReadSessioned := True;
		673	end;
		674
		675	function TCustomDXPlay.GetSessionsPty: TStrings;
		676	begin
		677	if not FReadSessioned then GetSessions;
		678	Result := FSessions;
		679	end;
		680
		681	function TCustomDXPlay.GetProviderNameFromGUID(const ProviderGUID: TGUID): string;
		682	var
		683	i: Integer;
		684	begin
		685	for i:=0 to Providers.Count-1 do
		686	if CompareMem(PGUID(Providers.Objects[i]), @ProviderGUID, SizeOf(TGUID)) then
		687	begin
		688	Result := Providers[i];
		689	Exit;
		690	end;
		691
		692	raise EDXPlayError.Create(SDXPlayProviderSpecifiedGUIDNotFound);
		693	end;
		694
		695	procedure TCustomDXPlay.CreateDPlayWithoutDialog(out DPlay: IDirectPlay4A; const ProviderName: string);
		696	var
		697	i: Integer;
		698	ProviderGUID: TGUID;
		699	addressElements: array[0..15] of TDPCompoundAddressElement;
		700	dwElementCount: Integer;
		701	Lobby1: IDirectPlayLobbyA;
		702	Lobby: IDirectPlayLobby2A;
		703	lpAddress: Pointer;
		704	dwAddressSize: DWORD;
		705	begin
		706	i := Providers.IndexOf(ProviderName);
		707	if i=-1 then
		708	raise EDXPlayError.CreateFmt(SDXPlayProviderNotFound, [ProviderName]);
		709	ProviderGUID := PGUID(Providers.Objects[i])^;
		710
		711	{ DirectPlay address making }
		712	if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then
		713	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		714	Lobby := Lobby1 as IDirectPlayLobby2A;
		715
		716	FillChar(addressElements, SizeOf(addressElements), 0);
		717	dwElementCount := 0;
		718
		719	addressElements[dwElementCount].guidDataType := DPAID_ServiceProvider;
		720	addressElements[dwElementCount].dwDataSize := SizeOf(TGUID);
		721	addressElements[dwElementCount].lpData := @ProviderGUID;
		722	Inc(dwElementCount);
		723
		724	if CompareMem(@ProviderGUID, @DPSPGUID_MODEM, SizeOf(TGUID)) and ModemSetting.Enabled then
		725	begin
		726	{ Modem }
		727	if ModemSetting.FModemName<>'' then
		728	begin
		729	addressElements[dwElementCount].guidDataType := DPAID_Modem;
		730	addressElements[dwElementCount].dwDataSize := Length(ModemSetting.FModemName)+1;
		731	addressElements[dwElementCount].lpData := PChar(ModemSetting.FModemName);
		732	Inc(dwElementCount);
		733	end;
		734
		735	if ModemSetting.FPhoneNumber<>'' then
		736	begin
		737	addressElements[dwElementCount].guidDataType := DPAID_Phone;
		738	addressElements[dwElementCount].dwDataSize := Length(ModemSetting.FPhoneNumber)+1;
		739	addressElements[dwElementCount].lpData := PChar(ModemSetting.FPhoneNumber);
		740	Inc(dwElementCount);
		741	end;
		742	end else
		743	if CompareMem(@ProviderGUID, @DPSPGUID_TCPIP, SizeOf(TGUID)) and TCPIPSetting.Enabled then
		744	begin
		745	{ TCP/IP }
		746	if TCPIPSetting.FHostName<>'' then
		747	begin
		748	addressElements[dwElementCount].guidDataType := DPAID_INet;
		749	addressElements[dwElementCount].dwDataSize := Length(TCPIPSetting.FHostName)+1;
		750	addressElements[dwElementCount].lpData := PChar(TCPIPSetting.FHostName);
		751	Inc(dwElementCount);
		752	end;
		753
		754	if TCPIPSetting.Port<>0 then
		755	begin
		756	addressElements[dwElementCount].guidDataType := DPAID_INetPort;
		757	addressElements[dwElementCount].dwDataSize := SizeOf(TCPIPSetting.FPort);
		758	addressElements[dwElementCount].lpData := @TCPIPSetting.FPort;
		759	Inc(dwElementCount);
		760	end;
		761	end;
		762
		763	if Lobby.CreateCompoundAddress(addressElements[0], dwElementCount, nil^, dwAddressSize)<>DPERR_BUFFERTOOSMALL then
		764	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		765
		766	GetMem(lpAddress, dwAddressSize);
		767	try
		768	FillChar(lpAddress^, dwAddressSize, 0);
		769
		770	if Lobby.CreateCompoundAddress(addressElements[0], dwElementCount, lpAddress^, dwAddressSize)<>0 then
		771	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		772
		773	{ DirectPlay initialization }
		774	if CoCreateInstance(CLSID_DirectPlay, nil, CLSCTX_INPROC_SERVER, IID_IDirectPlay4A, DPlay)<>0 then
		775	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		776	try
		777	{ DirectPlay address initialization }
		778	if DPlay.InitializeConnection(lpAddress, 0)<>0 then
		779	raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
		780	except
		781	DPlay := nil;
		782	raise;
		783	end;
		784	finally
		785	FreeMem(lpAddress);
		786	end;
		787	end;
		788
		789	procedure TCustomDXPlay.ClearSessionList;
		790	var
		791	i: Integer;
		792	begin
		793	FReadSessioned := False;
		794	for i:=0 to FSessions.Count-1 do
		795	Dispose(PGUID(FSessions.Objects[i]));
		796	FSessions.Clear;
		797	end;
		798
		799	procedure TCustomDXPlay.Open;
		800	var
		801	PlayerName: string;
		802	begin
		803	Close;
		804	try
		805	if not OpenDPlayWithLobby(PlayerName) then
		806	begin
		807	if not OpenDPlayWithoutLobby(PlayerName) then
		808	Abort;
		809	end;
		810
		811	Open_(PlayerName);
		812	except
		813	Close;
		814	raise;
		815	end;
		816	end;
		817
		818	procedure TCustomDXPlay.Open2(NewSession: Boolean; const SessionName, PlayerName: string);
		819	begin
		820	if not OpenDPlayWithoutLobby2(NewSession, ProviderName, SessionName, PlayerName) then
		821	Abort;
		822
		823	Open_(PlayerName);
		824	end;
		825
		826	procedure TCustomDXPlay.Open_(NameS: string);
		827
		828	function EnumPlayersCallback2(TDPID: TDPID; dwPlayerType: DWORD;
		829	const lpName: TDPName; dwFlags: DWORD; lpContext: Pointer): BOOL;
		830	stdcall;
		831	var
		832	Player: TDXPlayPlayer;
		833	begin
		834	Player := TDXPlayPlayer.Create(TCustomDXPlay(lpContext).Players);
		835	Player.FID := TDPID;
		836	Player.FRemotePlayer := True;
		837
		838	with lpName do
		839	begin
		840	if lpszShortNameA<>nil then
		841	Player.FName := lpszShortNameA;
		842	end;
		843
		844	Result := True;
		845	end;
		846
		847	var
		848	Name2: array[0..1023] of Char;
		849	Name: TDPName;
		850	begin
		851	if FOpened then Close;
		852	FOpened := True;
		853	try
		854	{ Player making }
		855	StrLCopy(@Name2, PChar(NameS), SizeOf(Name2));
		856
		857	Name.lpszShortNameA := @Name2;
		858	Name.lpszLongNameA := nil;
		859
		860	FRecvEvent[0] := CreateEvent(nil, False, False, nil);
		861
		862	FLocalPlayer := TDXPlayPlayer.Create(FPlayers);
		863	FLocalPlayer.FName := NameS;
		864
		865	if FDPlay.CreatePlayer(FLocalPlayer.FID, Name, FRecvEvent[0], nil^, 0, 0)<>DP_OK then
		866	raise EDXPlayError.CreateFmt(SCannotOpened, [FSessionName]);
		867
		868	{ Player enumeration }
		869	FDPlay.EnumPlayers(PGUID(nil)^, @EnumPlayersCallback2, Self, DPENUMPLAYERS_REMOTE);
		870
		871	FIsHost := FPlayers.Count=1;
		872
		873	FCalledDoOpen := True; DoOpen;
		874	DoAddPlayer(FLocalPlayer);
		875
		876	{ Thread start }
		877	FRecvThread := TDXPlayRecvThread.Create(Self);
		878	FRecvThread.Resume;
		879	except
		880	Close;
		881	raise;
		882	end;
		883	end;
		884
		885	procedure TCustomDXPlay.ChangeDPlay;
		886	var
		887	caps: TDPCAPS;
		888	begin
		889	FAsyncSupported := False;
		890	if FDPlay<>nil then
		891	begin
		892	FillChar(caps, SizeOf(caps), 0);
		893	caps.dwSize := SizeOf(caps);
		894	FDPlay.GetCaps(caps, 0);
		895
		896	FAsyncSupported := caps.dwFlags and DPCAPS_ASYNCSUPPORTED<>0;
		897	end;
		898	end;
		899
		900	function TCustomDXPlay.OpenDPlayWithLobby(out Name: string): Boolean;
		901	var
		902	DPlay1: IDirectPlay2;
		903	Lobby: IDirectPlayLobbyA;
		904	dwSize: DWORD;
		905	ConnectionSettings: PDPLConnection;
		906	begin
		907	Result := False;
		908
		909	if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby, nil, nil, 0)<>0 then
		910	Exit;
		911
		912	if Lobby.GetConnectionSettings(0, PDPLConnection(nil)^, dwSize)<>DPERR_BUFFERTOOSMALL then
		913	Exit;
		914
		915	GetMem(ConnectionSettings, dwSize);
		916	try
		917	if Lobby.GetConnectionSettings(0, ConnectionSettings^, dwSize)<>0 then
		918	Exit;
		919
		920	with ConnectionSettings^.lpSessionDesc^ do
		921	begin
		922	dwFlags := DPSESSION_MIGRATEHOST or DPSESSION_KEEPALIVE or DPSESSION_DIRECTPLAYPROTOCOL;
		923	dwMaxPlayers := FMaxPlayers;
		924	end;
		925
		926	if Lobby.SetConnectionSettings(0, 0, ConnectionSettings^)<>0 then
		927	Exit;
		928
		929	if Lobby.Connect(0, DPlay1, nil)<>0 then
		930	Exit;
		931	FDPlay := DPlay1 as IDirectPlay4A;
		932	ChangeDPlay;
		933
		934	with ConnectionSettings.lpSessionDesc^ do
		935	begin
		936	if lpszSessionNameA<>nil then
		937	FSessionName := lpszSessionNameA;
		938	end;
		939
		940	with ConnectionSettings.lpPlayerName^ do
		941	begin
		942	if lpszShortNameA<>nil then
		943	Name := lpszShortNameA;
		944	end;
		945	finally
		946	FreeMem(ConnectionSettings);
		947	end;
		948
		949	Result := True;
		950	end;
		951
		952	function TCustomDXPlay.OpenDPlayWithoutLobby(out Name: string): Boolean;
		953	var
		954	Form: TDelphiXDXPlayForm;
		955	begin
		956	Form := TDelphiXDXPlayForm.Create(Application);
		957	try
		958	Form.DXPlay := Self;
		959	Form.ShowModal;
		960
		961	Result := Form.Tag<>0;
		962
		963	FDPlay := Form.DPlay;
		964	ChangeDPlay;
		965
		966	Name := Form.PlayerName;
		967	FProviderName := Form.ProviderName;
		968	FSessionName := Form.SessionName;
		969	finally
		970	Form.Free;
		971	end;
		972	end;
		973
		974	function TCustomDXPlay.OpenDPlayWithoutLobby2(const NewSession: Boolean;
		975	const ProviderName, SessionName, PlayerName: string): Boolean;
		976	var
		977	dpDesc: TDPSessionDesc2;
		978	i: Integer;
		979	hr: HRESULT;
		980	begin
		981	Result := False;
		982
		983	if FDPlay=nil then
		984	raise EDXPlayError.Create(SDXPlayNotConnectedNow);
		985
		986	if SessionName='' then
		987	raise EDXPlayError.Create(SDXPlaySessionNameIsNotSpecified);
		988
		989	if PlayerName='' then
		990	raise EDXPlayError.Create(SDXPlayPlayerNameIsNotSpecified);
		991
		992	if NewSession then
		993	begin
		994	{ Session connection }
		995	FillChar(dpDesc, SizeOf(dpDesc), 0);
		996	dpDesc.dwSize := SizeOf(dpDesc);
		997	dpDesc.dwFlags := DPSESSION_MIGRATEHOST or DPSESSION_KEEPALIVE;
		998	dpDesc.lpszSessionNameA := PChar(SessionName);
		999	dpDesc.guidApplication := DXPlayStringToGUID(GUID);
		1000	dpDesc.dwMaxPlayers := MaxPlayers;
		1001
		1002	hr := FDPlay.Open(dpDesc, DPOPEN_CREATE);
		1003	if hr=DPERR_USERCANCEL then Exit;
		1004	if hr<>0 then
		1005	raise EDXPlayError.CreateFmt(SDXPlaySessionCannotOpened, [FSessionName]);
		1006	end else
		1007	begin
		1008	{ Session connection }
		1009	{ Enum session }
		1010	i := Sessions.IndexOf(SessionName);
		1011	if i=-1 then raise EDXPlayError.CreateFmt(SDXPlaySessionNotFound, [SessionName]);
		1012
		1013	FillChar(dpDesc, SizeOf(dpDesc), 0);
		1014	dpDesc.dwSize := SizeOf(dpDesc);
		1015	dpDesc.guidInstance := PGUID(Sessions.Objects[i])^;
		1016	dpDesc.guidApplication := DXPlayStringToGUID(GUID);
		1017
		1018	hr := FDPlay.Open(dpDesc, DPOPEN_JOIN);
		1019	if hr=DPERR_USERCANCEL then Exit;
		1020	if hr<>0 then
		1021	raise EDXPlayError.CreateFmt(SDXPlaySessionCannotOpened, [FSessionName]);
		1022	end;
		1023
		1024	Result := True;
		1025
		1026	FSessionName := SessionName;
		1027	end;
		1028
		1029	procedure TCustomDXPlay.Close;
		1030	begin
		1031	FOpened := False;
		1032	FReadSessioned := False;
		1033
		1034	try
		1035	if FCalledDoOpen then
		1036	begin
		1037	FCalledDoOpen := False;
		1038	DoClose;
		1039	end;
		1040	finally
		1041	if FDPlay<>nil then
		1042	begin
		1043	if FLocalPlayer<>nil then FDPlay.DestroyPlayer(FLocalPlayer.FID);
		1044	FDPlay.Close;
		1045	end;
		1046
		1047	FProviderName := '';
		1048	FSessionName := '';
		1049	FAsyncSupported := False;
		1050
		1051	ClearSessionList;
		1052
		1053	FDPlay := nil;
		1054	ChangeDPlay;
		1055
		1056	if FInThread then
		1057	SetEvent(FRecvEvent[1])
		1058	else
		1059	FRecvThread.Free;
		1060
		1061	CloseHandle(FRecvEvent[0]); FRecvEvent[0] := 0;
		1062
		1063	FPlayers.Clear;
		1064
		1065	FLocalPlayer := nil;
		1066	end;
		1067	end;
		1068
		1069	procedure TCustomDXPlay.SendMessage(ToID: TDPID; Data: Pointer; DataSize: Integer);
		1070	begin
		1071	if not Opened then Exit;
		1072
		1073	if DataSize<SizeOf(TDPMSG_GENERIC) then
		1074	raise EDXPlayError.Create(SDXPlayMessageIllegal);
		1075
		1076	if ToID=FLocalPlayer.ID then
		1077	begin
		1078	{ Message to me }
		1079	DoMessage(FLocalPlayer, Data, DataSize);
		1080	end else
		1081	if FAsync and FAsyncSupported then
		1082	FDPlay.SendEx(FLocalPlayer.ID, ToID, DPSEND_GUARANTEED or DPSEND_ASYNC, Data^, DataSize, 0, 0, nil, nil)
		1083	else
		1084	FDPlay.Send(FLocalPlayer.ID, ToID, DPSEND_GUARANTEED, Data^, DataSize);
		1085	end;
		1086
		1087	function TCustomDXPlay.SendMessageEx(ToID: TDPID; Data: Pointer; DataSize: Integer;
		1088	dwFlags: DWORD): DWORD;
		1089	begin
		1090	if not Opened then Exit;
		1091
		1092	if DataSize<SizeOf(TDPMSG_GENERIC) then
		1093	raise EDXPlayError.Create(SDXPlayMessageIllegal);
		1094
		1095	Result := 0;
		1096	if ToID=FLocalPlayer.ID then
		1097	begin
		1098	{ ��̃��b�Z�[�W }
		1099	DoMessage(FLocalPlayer, Data, DataSize);
		1100	end else
		1101	FDPlay.SendEx(FLocalPlayer.ID, ToID, dwFlags, Data^, DataSize,
		1102	0, 0, nil, @Result); // 0 �ȊO�̓T�\|�[�g��Ȃ��f�o�C�X��̂Ŏg��Ȃ�
		1103	end;
		1104
		1105	procedure TCustomDXPlay.SetGUID(const Value: string);
		1106	begin
		1107	if Value<>FGUID then
		1108	begin
		1109	if Value='' then
		1110	begin
		1111	FGUID := GUIDToString(GUID_NULL);
		1112	end else
		1113	begin
		1114	FGUID := GUIDToString(DXPlayStringToGUID(Value));
		1115	end;
		1116	end;
		1117	end;
		1118
		1119	procedure TCustomDXPlay.SetModemSetting(Value: TDXPlayModemSetting);
		1120	begin
		1121	FModemSetting.Assign(Value);
		1122	end;
		1123
		1124	procedure TCustomDXPlay.SetProviderName(const Value: string);
		1125	begin
		1126	Close;
		1127	FProviderName := Value;
		1128	if FProviderName='' then Exit;
		1129	try
		1130	CreateDPlayWithoutDialog(FDPlay, Value);
		1131	except
		1132	FProviderName := '';
		1133	raise;
		1134	end;
		1135	end;
		1136
		1137	procedure TCustomDXPlay.SetTCPIPSetting(Value: TDXPlayTCPIPSetting);
		1138	begin
		1139	FTCPIPSetting.Assign(Value);
		1140	end;
		1141
		1142	initialization
		1143	CoInitialize(nil);
		1144	finalization
		1145	CoUninitialize;
		1146	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXPlay.pas – Rev 1