io Programmo 23/IOPROG_23.ISO/SOFT/DELPHIX.ZIP/Source/DXPlay.pas

Pascal/Delphi Source File | 1998-10-06 | 28.4 KB | 1,017 lines

unit DXPlay;

interface

{$INCLUDE DelphiXcfg.inc}

uses
  Windows, SysUtils, Classes, Forms, DXClass, ActiveX, DirectX, DXETable;

type

  {  TDXPlayPlayer  }

  TDXPlayPlayer = class(TCollectionItem)
  private
    FData: Pointer;
    FID: DPID;
    FName: string;
    FRemotePlayer: Boolean;
  public
    property Data: Pointer read FData write FData;
    property ID: DPID read FID;
    property Name: string read FName;
    property RemotePlayer: Boolean read FRemotePlayer;
  end;

  {  TDXPlayPlayers  }

  TDXPlayPlayers = class(TCollection)
  private
    function GetPlayer(Index: Integer): TDXPlayPlayer;
  public
    constructor Create;
    function Find(ID: DPID): TDXPlayPlayer;
    function IndexOf(ID: DPID): Integer;
    property Players[Index: Integer]: TDXPlayPlayer read GetPlayer; default;
  end;

  {  TDXPlayModemSetting  }

  TDXPlayModemSetting = class(TPersistent)
  private
    FEnabled: Boolean;
    FPhoneNumber: string;
    FModemName: string;
    FModemNames: TStrings;
    function GetModemNames: TStrings;
  public
    destructor Destroy; override;
    property Enabled: Boolean read FEnabled write FEnabled;
    property PhoneNumber: string read FPhoneNumber write FPhoneNumber;
    property ModemName: string read FModemName write FModemName;
    property ModemNames: TStrings read GetModemNames;
  end;

  {  TDXPlayTCPIPSetting  }

  TDXPlayTCPIPSetting = class(TPersistent)
  private
    FEnabled: Boolean;
    FHostName: string;
  public
    property Enabled: Boolean read FEnabled write FEnabled;
    property HostName: string read FHostName write FHostName;
  end;

  {  EDXPlayError  }

  EDXPlayError = class(Exception);

  {  TCustomDXPlay  }

  TDXPlayEvent = procedure(Sender: TObject; Player: TDXPlayPlayer) of object;

  TDXPlayMessageEvent = procedure(Sender: TObject; From: TDXPlayPlayer;
    Data: Pointer; DataSize: Integer) of object;

  TCustomDXPlay = class(TComponent)
  private
    FDPlay: IDirectPlay3A;
    FGUID: string;
    FIsHost: Boolean;
    FLocalPlayer: TDXPlayPlayer;
    FMaxPlayers: Integer;
    FPlayers: TDXPlayPlayers;
    FCalledDoOpen: Boolean;
    FOnAddPlayer: TDXPlayEvent;
    FOnClose: TNotifyEvent;
    FOnDeletePlayer: TDXPlayEvent;
    FOnMessage: TDXPlayMessageEvent;
    FOnOpen: TNotifyEvent;
    FOnSessionLost: TNotifyEvent;
    FOpened: Boolean;
    FRecvEvent: array[0..1] of THandle;
    FRecvThread: TThread;
    FInThread: Boolean;
    FProviderName: string;
    FProviders: TStrings;
    FSessionName: string;
    FSessions: TStrings;
    FReadSessioned: Boolean;
    FModemSetting: TDXPlayModemSetting;
    FTCPIPSetting: TDXPlayTCPIPSetting;
    procedure CreateDPlayWithoutDialog(out DPlay: IDirectPlay3A; const ProviderName: string);
    function OpenDPlayWithLobby(out Name: string): Boolean;
    function OpenDPlayWithoutLobby(out Name: string): Boolean;
    function OpenDPlayWithoutLobby2(const NewSession: Boolean; const ProviderName, SessionName, PlayerName: string): Boolean;
    procedure Open_(NameS: string);
    procedure ReceiveMessage;
    procedure SendMessageEx(ToID: DPID; Data: Pointer; DataSize: Integer; dwFlags: DWORD);
    function GetProviders: TStrings;
    function GetSessionsPty: TStrings;
    procedure ClearSessionList;
    procedure SetGUID(const Value: string);
    procedure SetProviderName(const Value: string);
  protected
    procedure DoAddPlayer(Player: TDXPlayPlayer); virtual;
    procedure DoClose; virtual;
    procedure DoDeletePlayer(Player: TDXPlayPlayer); virtual;
    procedure DoMessage(From: TDXPlayPlayer; Data: Pointer; DataSize: Integer); virtual;
    procedure DoOpen; virtual;
    procedure DoSessionLost; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close;
    procedure Open;
    procedure Open2(const NewSession: Boolean; const SessionName, PlayerName: string);
    function GetProviderNameFromGUID(const ProviderGUID: TGUID): string;
    procedure GetSessions;
    procedure SendMessage(ToID: DPID; Data: Pointer; DataSize: Integer);
    property GUID: string read FGUID write SetGUID;
    property IsHost: Boolean read FIsHost;
    property LocalPlayer: TDXPlayPlayer read FLocalPlayer;
    property MaxPlayers: Integer read FMaxPlayers write FMaxPlayers;
    property OnAddPlayer: TDXPlayEvent read FOnAddPlayer write FOnAddPlayer;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnDeletePlayer: TDXPlayEvent read FOnDeletePlayer write FOnDeletePlayer;
    property OnMessage: TDXPlayMessageEvent read FOnMessage write FOnMessage;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnSessionLost: TNotifyEvent read FOnSessionLost write FOnSessionLost;
    property Opened: Boolean read FOpened;
    property Players: TDXPlayPlayers read FPlayers;
    property ProviderName: string read FProviderName write SetProviderName;
    property Providers: TStrings read GetProviders;
    property SessionName: string read FSessionName;
    property Sessions: TStrings read GetSessionsPty;
    property ModemSetting: TDXPlayModemSetting read FModemSetting;
    property TCPIPSetting: TDXPlayTCPIPSetting read FTCPIPSetting;
  end;

  TDXPlay = class(TCustomDXPlay)
  published
    property GUID;
    property MaxPlayers;
    property OnAddPlayer;
    property OnClose;
    property OnDeletePlayer;
    property OnMessage;
    property OnOpen;
    property OnSessionLost;
  end;

function DXPlayMessageType(P: Pointer): DWORD;

function DXPlayStringToGUID(const S: string): TGUID;
function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
  pUnk: IUnknown): HRESULT;

implementation

uses DXPlayFm, DXConsts;

function DXPlayMessageType(P: Pointer): DWORD;
begin
  Result := LPDPMSG_GENERIC(P)^.dwType;
end;

function DXPlayStringToGUID(const S: string): TGUID;
var
  ErrorCode: Integer;
begin
  ErrorCode := CLSIDFromString(PWideChar(WideString(S)), Result);
  if ErrorCode<0 then
    raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
end;

function GUIDToString(const ClassID: TGUID): string;
var
  ErrorCode: Integer;
  P: PWideChar;
begin
  ErrorCode := StringFromCLSID(ClassID, P);
  if ErrorCode<0 then
    raise EDXPlayError.Create(WindowsErrorMsg(ErrorCode));
  Result := P;
  CoTaskMemFree(P);
end;

function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP: IDirectPlay;
  pUnk: IUnknown): HRESULT;
type
  TDirectPlayCreate= function(const lpGUID: TGUID; out lplpDP: IDirectPlay; pUnk: IUnknown): HRESULT; stdcall;
begin
  Result := TDirectPlayCreate(DXLoadLibrary('DPlayX.dll', 'DirectPlayCreate'))
    (lpGUID, lplpDP, pUnk);
end;

function DXDirectPlayEnumerateA(lpEnumDPCallback: LPDPENUMDPCALLBACKA; lpContext: Pointer): HRESULT;
type
  TDirectPlayEnumerateA= function(lpEnumDPCallback: LPDPENUMDPCALLBACKA; lpContext: Pointer): HRESULT; stdcall;
begin
  Result := TDirectPlayEnumerateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayEnumerateA'))
    (lpEnumDPCallback, lpContext);
end;

function DXDirectPlayLobbyCreateA(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
    lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT;
type
  TDirectPlayLobbyCreateA = function(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyA;
      lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT; stdcall;
begin
  Result := TDirectPlayLobbyCreateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayLobbyCreateA'))
    (lpguidSP, lplpDPL, lpUnk, lpData, dwDataSize);
end;

{  TDXPlayPlayers  }

constructor TDXPlayPlayers.Create;
begin
  inherited Create(TDXPlayPlayer);
end;

function TDXPlayPlayers.Find(ID: DPID): TDXPlayPlayer;
var
  i: Integer;
begin
  i := IndexOf(ID);
  if i=-1 then
    raise EDXPlayError.Create(SDXPlayPlayerNotFound);
  Result := Players[i];
end;

function TDXPlayPlayers.IndexOf(ID: DPID): Integer;
var
  i: Integer;
begin
  for i:=0 to Count-1 do
    if Players[i].FID=ID then
    begin
      Result := i;
      Exit;
    end;
  Result := -1;
end;

function TDXPlayPlayers.GetPlayer(Index: Integer): TDXPlayPlayer;
begin
  Result := TDXPlayPlayer(Items[Index]);
end;

{  TDXPlayModemSetting  }

destructor TDXPlayModemSetting.Destroy;
begin
  FModemNames.Free;
  inherited Destroy;
end;

function TDXPlayModemSetting.GetModemNames: TStrings;

  function EnumModemAddress(const guidDataType: TGUID;
    dwDataSize: DWORD; lpData: Pointer; lpContext: Pointer): BOOL; stdcall;
  begin
    if CompareMem(@guidDataType, @DPAID_Modem, SizeOf(TGUID)) then
      TStrings(lpContext).Add( PChar(lpData));
    Result := True;
  end;

var
  Lobby1: IDirectPlayLobbyA;
  Lobby: IDirectPlayLobby2A;
  DPlay1: IDirectPlay;
  DPlay: IDirectPlay3A;
  lpAddress: Pointer;
  dwAddressSize: DWORD;
begin
  if FModemNames=nil then
  begin
    FModemNames := TStringList.Create;
    try
      if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then
        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
      Lobby := Lobby1 as IDirectPlayLobby2A;

      if DirectPlayCreate(DPSPGUID_MODEM, DPlay1, nil)<>0 then
        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
      DPlay := DPlay1 as IDirectPlay3A;

      {  get size of player address for all players  }
      if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, nil^, dwAddressSize)<>DPERR_BUFFERTOOSMALL then
        raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);

      GetMem(lpAddress, dwAddressSize);
      try
        FillChar(lpAddress^, dwAddressSize, 0);

        {  get the address  }
        if DPlay.GetPlayerAddress(DPID_ALLPLAYERS, lpAddress^, dwAddressSize)<>0 then
          raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);

        {  get modem strings from address and put them in the combo box  }
        if Lobby.EnumAddress(@EnumModemAddress, lpAddress^, dwAddressSize, FModemNames)<>0 then
          raise EDXPlayError.Create(SDXPlayModemListCannotBeAcquired);
      finally
        FreeMem(lpAddress);
      end;
    except
      FModemNames.Free; FModemNames := nil;
      raise;
    end;
  end;

  Result := FModemNames;
end;

{  TCustomDXPlay  }

constructor TCustomDXPlay.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPlayers := TDXPlayPlayers.Create;
  FModemSetting := TDXPlayModemSetting.Create;
  FTCPIPSetting := TDXPlayTCPIPSetting.Create;
  FSessions := TStringList.Create;

  FGUID := GUIDToString(GUID_NULL);
  FMaxPlayers := 0;
end;

destructor TCustomDXPlay.Destroy;
var
  i: Integer;
begin
  Close;

  FPlayers.Free;

  if FProviders<>nil then
  begin
    for i:=0 to FProviders.Count-1 do
      Dispose(PGUID(FProviders.Objects[i]));
  end;
  FProviders.Free;
  FModemSetting.Free;
  FTCPIPSetting.Free;
  ClearSessionList;
  FSessions.Free;
  inherited Destroy;
end;

type
  TDXPlayRecvThread = class(TThread)
  private
    FDXPlay: TCustomDXPlay;
    constructor Create(DXPlay: TCustomDXPlay);
    destructor Destroy; override;
    procedure Execute; override;
  end;

constructor TDXPlayRecvThread.Create(DXPlay: TCustomDXPlay);
begin
  FDXPlay := DXPlay;

  FDXPlay.FRecvEvent[1] := CreateEvent(nil, False, False, nil);

  FreeOnTerminate := True;
  inherited Create(True);
end;

destructor TDXPlayRecvThread.Destroy;
begin
  FreeOnTerminate := False;
  SetEvent(FDXPlay.FRecvEvent[1]);

  inherited Destroy;

  CloseHandle(FDXPlay.FRecvEvent[1]);

  FDXPlay.FRecvThread := nil;
  FDXPlay.Close;
end;

procedure TDXPlayRecvThread.Execute;
begin
  while WaitForMultipleObjects(2, @FDXPlay.FRecvEvent, False, INFINITE)=WAIT_OBJECT_0 do
  begin
    Synchronize(FDXPlay.ReceiveMessage);
  end;
end;

procedure TCustomDXPlay.ReceiveMessage;
var
  idFrom, idTo: DWORD;
  hr: HRESULT;
  lpvMsgBuffer: Pointer;
  dwMsgBufferSize: DWORD;
  Msg_CreatePlayerOrGroup: LPDPMSG_CREATEPLAYERORGROUP;
  Msg_DeletePlayerOrGroup: LPDPMSG_CREATEPLAYERORGROUP;
  Player: TDXPlayPlayer;
  i: Integer;
begin
  FInThread := True;
  try
    try
      lpvMsgBuffer := nil;
      dwMsgBufferSize := 0;

      try
        repeat
          hr := FDPlay.Receive(idFrom, idTo, DPRECEIVE_ALL, lpvMsgBuffer^, dwMsgBufferSize);

          if hr=DPERR_BUFFERTOOSMALL then
          begin
            ReAllocMem(lpvMsgBuffer, dwMsgBufferSize);
            hr := FDPlay.Receive(idFrom, idTo, DPRECEIVE_ALL, lpvMsgBuffer^, dwMsgBufferSize);
          end;

          if (hr=0) and (dwMsgBufferSize>=SizeOf(DPMSG_GENERIC)) then
          begin
            if idFrom=DPID_SYSMSG then
            begin
              {  System message  }
              case LPDPMSG_GENERIC(lpvMsgBuffer)^.dwType of
                DPSYS_CREATEPLAYERORGROUP:
                    begin
                      {  New player  }
                      Msg_CreatePlayerOrGroup := lpvMsgBuffer;

                      if Msg_CreatePlayerOrGroup.dpId<>FLocalPlayer.FID then
                      begin
                        Player := TDXPlayPlayer.Create(Players);
                        Player.FID := Msg_CreatePlayerOrGroup.dpId;
                        Player.FRemotePlayer := True;

                        with Msg_CreatePlayerOrGroup.dpnName do
                        begin
                          if lpszShortNameA<>nil then
                            Player.FName := lpszShortNameA;
                        end;

                        DoAddPlayer(Player);
                      end;
                    end;
                DPSYS_DESTROYPLAYERORGROUP:
                    begin
                      {  Player deletion  }
                      Msg_DeletePlayerOrGroup := lpvMsgBuffer;

                      if Msg_DeletePlayerOrGroup.dpId<>FLocalPlayer.FID then
                      begin
                        i := Players.IndexOf(Msg_DeletePlayerOrGroup.dpId);
                        if i<>-1 then
                        begin
                          DoDeletePlayer(Players[i]);
                          Players[i].Free;
                        end;
                      end;
                    end;
                DPSYS_SESSIONLOST:
                    begin
                      {  The session was lost.  }
                      DoSessionLost;
                      Close;
                    end;
                DPSYS_HOST:
                    begin
                      {  Here became a host.  }
                      FIsHost := True;
                    end;
              end;
            end else
            begin
              {  Application definition message  }
              DoMessage(Players.Find(idFrom), lpvMsgBuffer, dwMsgBufferSize);
            end;
          end;
        until hr<>0;
      finally
        FreeMem(lpvMsgBuffer);
      end;
    except
      on E: Exception do
        Application.HandleException(E);
    end;
  finally
    FInThread := False;
  end;
end;

procedure TCustomDXPlay.DoAddPlayer(Player: TDXPlayPlayer);
begin
  if Assigned(FOnAddPlayer) then FOnAddPlayer(Self, Player)
end;

procedure TCustomDXPlay.DoClose;
begin
  if Assigned(FOnClose) then FOnClose(Self);
end;

procedure TCustomDXPlay.DoDeletePlayer(Player: TDXPlayPlayer);
begin
  if Assigned(FOnDeletePlayer) then FOnDeletePlayer(Self, Player)
end;

procedure TCustomDXPlay.DoMessage(From: TDXPlayPlayer; Data: Pointer; DataSize: Integer);
begin
  if Assigned(FOnMessage) then FOnMessage(Self, From, Data, DataSize);
end;

procedure TCustomDXPlay.DoOpen;
begin
  if Assigned(FOnOpen) then FOnOpen(Self);
end;

procedure TCustomDXPlay.DoSessionLost;
begin
  if Assigned(FOnSessionLost) then FOnSessionLost(Self);
end;

function TCustomDXPlay.GetProviders: TStrings;

  function EnumProviderCallback(const lpguidSP: TGUID; lpSPName: LPSTR;
      dwMajorVersion: DWORD; dwMinorVersion: DWORD; lpContext: Pointer):
      BOOL; stdcall;
  var
    GUID: PGUID;
  begin
    GUID := New(PGUID);
    Move(lpguidSP, GUID^, SizeOf(TGUID));
    TStrings(lpContext).AddObject(lpSPName, TObject(GUID));
    Result := True;
  end;

begin
  if FProviders=nil then
  begin
    FProviders := TStringList.Create;
    try
      DXDirectPlayEnumerateA(@EnumProviderCallback, FProviders);
    except
      FProviders.Free; FProviders := nil;
      raise;
    end;
  end;

  Result := FProviders;
end;

procedure TCustomDXPlay.GetSessions;

  function EnumSessionsCallback(const lpThisSD: DPSESSIONDESC2;
      var lpdwTimeOut: DWORD; dwFlags: DWORD; lpContext: Pointer): BOOL; stdcall;
  var
    Guid: PGUID;
  begin
    if dwFlags and DPESC_TIMEDOUT<>0 then
    begin
      Result := False;
      Exit;
    end;

    Guid := New(PGUID);
    Move(lpThisSD.guidInstance, Guid^, SizeOf(TGUID));
    TStrings(lpContext).AddObject(lpThisSD.lpszSessionNameA, TObject(Guid));

    Result := True;
  end;

var
  dpDesc: DPSESSIONDESC2;
  hr: HRESULT;
begin
  if FDPlay=nil then
    raise EDXPlayError.Create(SDXPlayNotConnectedNow);

  ClearSessionList;

  FillChar(dpDesc, SizeOf(dpDesc), 0);
  dpDesc.dwSize := SizeOf(dpDesc);
  dpDesc.guidApplication := DXPlayStringToGUID(FGUID);

  hr := FDPlay.EnumSessions(dpDesc, 0, @EnumSessionsCallback, FSessions, DPENUMSESSIONS_AVAILABLE);
  if hr=DPERR_USERCANCEL then Abort;
  if hr<>0 then
    raise EDXPlayError.Create(SDXPlaySessionListCannotBeAcquired);

  FReadSessioned := True;
end;

function TCustomDXPlay.GetSessionsPty: TStrings;
begin
  if not FReadSessioned then GetSessions;
  Result := FSessions;
end;

function TCustomDXPlay.GetProviderNameFromGUID(const ProviderGUID: TGUID): string;
var
  i: Integer;
begin
  for i:=0 to Providers.Count-1 do
    if CompareMem(PGUID(Providers.Objects[i]), @ProviderGUID, SizeOf(TGUID)) then
    begin
      Result := Providers[i];
      Exit;
    end;

  raise EDXPlayError.Create(SDXPlayProviderSpecifiedGUIDNotFound);
end;

procedure TCustomDXPlay.CreateDPlayWithoutDialog(out DPlay: IDirectPlay3A; const ProviderName: string);
var
  i: Integer;
  ProviderGUID: TGUID;
  addressElements: array[0..15] of DPCOMPOUNDADDRESSELEMENT;
  dwElementCount: Integer;
  Lobby1: IDirectPlayLobbyA;
  Lobby: IDirectPlayLobby2A;
  lpAddress: Pointer;
  dwAddressSize: DWORD;
begin
  i := Providers.IndexOf(ProviderName);
  if i=-1 then
    raise EDXPlayError.CreateFmt(SDXPlayProviderNotFound, [ProviderName]);
  ProviderGUID := PGUID(Providers.Objects[i])^;

  {  DirectPlay address making  }
  if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then
    raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
  Lobby := Lobby1 as IDirectPlayLobby2A;

  FillChar(addressElements, SizeOf(addressElements), 0);
  dwElementCount := 0;

  addressElements[dwElementCount].guidDataType := DPAID_ServiceProvider;
  addressElements[dwElementCount].dwDataSize := SizeOf(TGUID);
  addressElements[dwElementCount].lpData := @ProviderGUID;
  Inc(dwElementCount);

  if CompareMem(@ProviderGUID, @DPSPGUID_MODEM, SizeOf(TGUID)) and ModemSetting.Enabled then
  begin
    {  Modem  }
    if ModemSetting.FModemName<>'' then
    begin
      addressElements[dwElementCount].guidDataType := DPAID_Modem;
      addressElements[dwElementCount].dwDataSize := Length(ModemSetting.FModemName)+1;
      addressElements[dwElementCount].lpData := PChar(ModemSetting.FModemName);
      Inc(dwElementCount);
    end;

    if ModemSetting.FPhoneNumber<>'' then
    begin
      addressElements[dwElementCount].guidDataType := DPAID_Phone;
      addressElements[dwElementCount].dwDataSize := Length(ModemSetting.FPhoneNumber)+1;
      addressElements[dwElementCount].lpData := PChar(ModemSetting.FPhoneNumber);
      Inc(dwElementCount);
    end;
  end else
  if CompareMem(@ProviderGUID, @DPSPGUID_TCPIP, SizeOf(TGUID)) and TCPIPSetting.Enabled then
  begin
    {  TCP/IP  }
    if TCPIPSetting.FHostName<>'' then
    begin
      addressElements[dwElementCount].guidDataType := DPAID_INet;
      addressElements[dwElementCount].dwDataSize := Length(TCPIPSetting.FHostName)+1;
      addressElements[dwElementCount].lpData := PChar(TCPIPSetting.FHostName);
      Inc(dwElementCount);
    end;
  end;

  if Lobby.CreateCompoundAddress(addressElements[0], dwElementCount, nil^, dwAddressSize)<>DPERR_BUFFERTOOSMALL then
    raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);

  GetMem(lpAddress, dwAddressSize);
  try
    FillChar(lpAddress^, dwAddressSize, 0);

    if Lobby.CreateCompoundAddress(addressElements[0], dwElementCount, lpAddress^, dwAddressSize)<>0 then
      raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);

    {  DirectPlay initialization  }
    if CoCreateInstance(CLSID_DirectPlay, nil, CLSCTX_INPROC_SERVER, IID_IDirectPlay3A, DPlay)<>0 then
      raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
    try
      {  DirectPlay address initialization  }
      if DPlay.InitializeConnection(lpAddress, 0)<>0 then
        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);
    except
      DPlay := nil;
      raise;
    end;
  finally
    FreeMem(lpAddress);
  end;
end;

procedure TCustomDXPlay.ClearSessionList;
var
  i: Integer;
begin
  FReadSessioned := False;
  for i:=0 to FSessions.Count-1 do
    Dispose(PGUID(FSessions.Objects[i]));
  FSessions.Clear;
end;

procedure TCustomDXPlay.Open;
var
  PlayerName: string;
begin
  Close;
  try
    if not OpenDPlayWithLobby(PlayerName) then
    begin
      if not OpenDPlayWithoutLobby(PlayerName) then
        Abort;
    end;

    Open_(PlayerName);
  except
    Close;
    raise;
  end;
end;

procedure TCustomDXPlay.Open2(const NewSession: Boolean; const SessionName, PlayerName: string);
begin
  if not OpenDPlayWithoutLobby2(NewSession, ProviderName, SessionName, PlayerName) then
    Abort;

  Open_(PlayerName);
end;

procedure TCustomDXPlay.Open_(NameS: string);

  function EnumPlayersCallback2(dpId: DPID; dwPlayerType: DWORD;
    const lpName: DPNAME; dwFlags: DWORD; lpContext: Pointer): BOOL;
    stdcall;
  var
    Player: TDXPlayPlayer;
  begin
    Player := TDXPlayPlayer.Create(TCustomDXPlay(lpContext).Players);
    Player.FID := dpId;
    Player.FRemotePlayer := True;

    with lpName do
    begin
      if lpszShortNameA<>nil then
        Player.FName := lpszShortNameA;
    end;

    Result := True;
  end;

var
  Name2: array[0..1023] of Char;
  Name: DPNAME;
begin
  if FOpened then Close;
  FOpened := True;
  try
    {  Player making  }
    StrLCopy(@Name2, PChar(NameS), SizeOf(Name2));

    Name.lpszShortNameA := @Name2;
    Name.lpszLongNameA := nil;

    FRecvEvent[0] := CreateEvent(nil, False, False, nil);

    FLocalPlayer := TDXPlayPlayer.Create(FPlayers);
    FLocalPlayer.FName := NameS;

    if FDPlay.CreatePlayer(FLocalPlayer.FID, Name, FRecvEvent[0], nil^, 0, 0)<>DP_OK then
      raise EDXPlayError.CreateFmt(SCannotOpened, [FSessionName]);

    {  Player enumeration  }
    FDPlay.EnumPlayers(PGUID(nil)^, @EnumPlayersCallback2, Self, DPENUMPLAYERS_REMOTE);

    FIsHost := FPlayers.Count=1;

    FCalledDoOpen := True; DoOpen;
    DoAddPlayer(FLocalPlayer);

    {  Thread start  }
    FRecvThread := TDXPlayRecvThread.Create(Self);
    FRecvThread.Resume;
  except
    Close;
    raise;
  end;
end;

function TCustomDXPlay.OpenDPlayWithLobby(out Name: string): Boolean;
var
  DPlay1: IDirectPlay2;
  Lobby: IDirectPlayLobbyA;
  dwSize: DWORD;
  ConnectionSettings: ^DPLCONNECTION;
begin
  Result := False;

  if DXDirectPlayLobbyCreateA(PGUID(nil)^, Lobby, nil, nil, 0)<>0 then
    Exit;

  if Lobby.GetConnectionSettings(0, DPLCONNECTION(nil^), dwSize)<>DPERR_BUFFERTOOSMALL then
    Exit;

  GetMem(ConnectionSettings, dwSize);
  try
    if Lobby.GetConnectionSettings(0, ConnectionSettings^, dwSize)<>0 then
      Exit;

    with ConnectionSettings^.lpSessionDesc^ do
    begin
      dwFlags := DPSESSION_MIGRATEHOST or DPSESSION_KEEPALIVE;
      dwMaxPlayers := FMaxPlayers;
    end;

    if Lobby.SetConnectionSettings(0, 0, ConnectionSettings^)<>0 then
      Exit;

    if Lobby.Connect(0, DPlay1, nil)<>0 then
      Exit;
    FDPlay := DPlay1 as IDirectPlay3A;

    with ConnectionSettings.lpSessionDesc^ do
    begin
      if lpszSessionNameA<>nil then
        FSessionName := lpszSessionNameA;
    end;

    with ConnectionSettings.lpPlayerName^ do
    begin
      if lpszShortNameA<>nil then
        Name := lpszShortNameA;
    end;
  finally
    FreeMem(ConnectionSettings);
  end;

  Result := True;
end;

function TCustomDXPlay.OpenDPlayWithoutLobby(out Name: string): Boolean;
var
  Form: TDelphiXDXPlayForm;
begin
  Form := TDelphiXDXPlayForm.Create(Application);
  try
    Form.DXPlay := Self;
    Form.ShowModal;

    Result := Form.Tag<>0;

    FDPlay := Form.DPlay;
    Name := Form.PlayerName;
    FProviderName := Form.ProviderName;
    FSessionName := Form.SessionName;
  finally
    Form.Free;
  end;
end;

function TCustomDXPlay.OpenDPlayWithoutLobby2(const NewSession: Boolean;
  const ProviderName, SessionName, PlayerName: string): Boolean;
var
  dpDesc: DPSESSIONDESC2;
  i: Integer;
  hr: HRESULT;
begin
  Result := False;

  if FDPlay=nil then
    raise EDXPlayError.Create(SDXPlayNotConnectedNow);

  if SessionName='' then
    raise EDXPlayError.Create(SDXPlaySessionNameIsNotSpecified);

  if PlayerName='' then
    raise EDXPlayError.Create(SDXPlayPlayerNameIsNotSpecified);

  if NewSession then
  begin
    {  Session connection  }
    FillChar(dpDesc, SizeOf(dpDesc), 0);
    dpDesc.dwSize := SizeOf(dpDesc);
    dpDesc.dwFlags := DPSESSION_MIGRATEHOST or DPSESSION_KEEPALIVE;
    dpDesc.lpszSessionNameA := PChar(SessionName);
    dpDesc.guidApplication := DXPlayStringToGUID(GUID);
    dpDesc.dwMaxPlayers := MaxPlayers;

    hr := FDPlay.Open(dpDesc, DPOPEN_CREATE);
    if hr=DPERR_USERCANCEL then Exit;
    if hr<>0 then
      raise EDXPlayError.CreateFmt(SDXPlaySessionCannotOpened, [FSessionName]);
  end else
  begin
    {  Session connection  }
    {  Enum session  }
    i := Sessions.IndexOf(SessionName);
    if i=-1 then raise EDXPlayError.CreateFmt(SDXPlaySessionNotFound, [SessionName]);

    FillChar(dpDesc, SizeOf(dpDesc), 0);
    dpDesc.dwSize := SizeOf(dpDesc);
    dpDesc.guidInstance := PGUID(Sessions.Objects[i])^;
    dpDesc.guidApplication := DXPlayStringToGUID(GUID);

    hr := FDPlay.Open(dpDesc, DPOPEN_JOIN);
    if hr=DPERR_USERCANCEL then Exit;
    if hr<>0 then
      raise EDXPlayError.CreateFmt(SDXPlaySessionCannotOpened, [FSessionName]);
  end;

  Result := True;

  FSessionName := SessionName;
end;

procedure TCustomDXPlay.Close;
begin
  FOpened := False;
  FReadSessioned := False;

  try
    if FCalledDoOpen then
    begin
      FCalledDoOpen := False;
      DoClose;
    end;
  finally
    if FDPlay<>nil then
    begin
      if FLocalPlayer<>nil then FDPlay.DestroyPlayer(FLocalPlayer.FID);
      FDPlay.Close;
    end;

    FProviderName := '';
    FSessionName := '';
    ClearSessionList;

    FDPlay := nil;

    if FInThread then
      SetEvent(FRecvEvent[1])
    else
      FRecvThread.Free;
    CloseHandle(FRecvEvent[0]);

    FPlayers.Clear;

    FLocalPlayer := nil;
  end;
end;

procedure TCustomDXPlay.SendMessage(ToID: DPID; Data: Pointer; DataSize: Integer);
begin
  SendMessageEx(ToID, Data, DataSize, DPSEND_GUARANTEED);
end;

procedure TCustomDXPlay.SendMessageEx(ToID: DPID; Data: Pointer; DataSize: Integer; dwFlags: DWORD);
begin
  if not Opened then Exit;

  if DataSize<SizeOf(DPMSG_GENERIC) then
    raise EDXPlayError.Create(SDXPlayMessageIllegal);

  if ToID=FLocalPlayer.ID then
  begin
    {  Message to me  }
    DoMessage(FLocalPlayer, Data, DataSize);
  end else
    FDPlay.Send(FLocalPlayer.ID, ToID, dwFlags, Data^, DataSize)
end;

procedure TCustomDXPlay.SetGUID(const Value: string);
begin
  if Value<>FGUID then
  begin
    if Value='' then
    begin
      FGUID := GUIDToString(GUID_NULL);
    end else
    begin
      FGUID := GUIDToString(DXPlayStringToGUID(Value));
    end;
  end;
end;

procedure TCustomDXPlay.SetProviderName(const Value: string);
begin
  Close;
  FProviderName := Value;
  if FProviderName='' then Exit;
  try
    CreateDPlayWithoutDialog(FDPlay, Value);
  except
    FProviderName := '';
    raise;
  end;
end;

initialization
  CoInitialize(nil);
finalization
  CoUninitialize;
end.