Subversion Repositories spacemission

Rev

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

  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.
  1147.