Subversion Repositories spacemission

unit DXPlay;

interface

{$INCLUDE DelphiXcfg.inc}

{$IFNDEF UseDirectPlay} // Daniel Marschall 12.04.2024 Added to avoid Windows showing "This app requires DirectPlay"

{$MESSAGE ERROR 'If you want to use DXPlay.pas, please enable the IFDEF UseDirectPlay in DelphiXcfg.inc'}

{$ENDIF}

uses

  Windows, SysUtils, Classes, Forms, DXClass, ActiveX, DXETable,  

{$IfDef StandardDX}

  DirectDraw,

// Delphi 2010 cannot be use DirectPlay8 because structure was not rewriten

//  {$IfDef DX9}

//  DirectPlay8, DX7toDX8;

//  {$Else}

  DirectPlay; //old wersion, current in directory

//  {$EndIf}

{$Else}

  DirectX;

{$EndIf}

type

  {$IfDef DX9}

  TDPID = DWORD;

  {$EndIf}

  {  TDXPlayPlayer  }

  TDXPlayPlayer = class(TCollectionItem)

  private

    FData: Pointer;

    FID: TDPID;

    FName: string;

    FRemotePlayer: Boolean;

  public

    property Data: Pointer read FData write FData;

    property ID: TDPID 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: TDPID): TDXPlayPlayer;

    function IndexOf(ID: TDPID): 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;

    procedure Assign(Source: TPersistent); override;

    property ModemName: string read FModemName write FModemName;

    property ModemNames: TStrings read GetModemNames;

  published

    property Enabled: Boolean read FEnabled write FEnabled;

    property PhoneNumber: string read FPhoneNumber write FPhoneNumber;

  end;

  {  TDXPlayTCPIPSetting  }

  TDXPlayTCPIPSetting = class(TPersistent)

  private

    FEnabled: Boolean;

    FHostName: string;

    FPort: Word;

  public

    procedure Assign(Source: TPersistent); override;

  published

    property Enabled: Boolean read FEnabled write FEnabled;

    property HostName: string read FHostName write FHostName;

    property Port: Word read FPort write FPort;

  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;

  TDXPlaySendCompleteResult = (crOk, crAbort, crGeneric);

  TDXPlaySendCompleteEvent = procedure(Sender: TObject; MessageID: DWORD;

    Result: TDXPlaySendCompleteResult; SendTime: Integer) of object;

  TCustomDXPlay = class(TComponent)

  private

    FDPlay: //{$IfDef DX7}

      IDirectPlay4A;//{$Else}IDirectPlay8Address{$EndIf};

    FGUID: string;

    FIsHost: Boolean;

    FLocalPlayer: TDXPlayPlayer;

    FMaxPlayers: Integer;

    FPlayers: TDXPlayPlayers;

    FCalledDoOpen: Boolean;

    FOnAddPlayer: TDXPlayEvent;

    FOnClose: TNotifyEvent;

    FOnDeletePlayer: TDXPlayEvent;

    FOnMessage: TDXPlayMessageEvent;

    FOnOpen: TNotifyEvent;

    FOnSendComplete: TDXPlaySendCompleteEvent;

    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;

    FAsync: Boolean;

    FAsyncSupported: Boolean;

    procedure ChangeDPlay;

    procedure CreateDPlayWithoutDialog(out DPlay:

     //{$IfDef DX7}

     IDirectPlay4A;

     //{$Else}IDirectPlay8Address{$EndIf};

      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;

    function GetProviders: TStrings;

    function GetSessionsPty: TStrings;

    procedure ClearSessionList;

    procedure SetGUID(const Value: string);

    procedure SetModemSetting(Value: TDXPlayModemSetting);

    procedure SetProviderName(const Value: string);

    procedure SetTCPIPSetting(Value: TDXPlayTCPIPSetting);

  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;

    procedure DoSendComplete(MessageID: DWORD; Result: TDXPlaySendCompleteResult;

      SendTime: Integer); virtual;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;

    procedure Close;

    procedure Open;

    procedure Open2(NewSession: Boolean; const SessionName, PlayerName: string);

    function GetProviderNameFromGUID(const ProviderGUID: TGUID): string;

    procedure GetSessions;

    procedure SendMessage(ToID: TDPID; Data: Pointer; DataSize: Integer);

    function SendMessageEx(ToID: TDPID; Data: Pointer; DataSize: Integer;

      dwFlags: DWORD): DWORD;

    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 OnSendComplete: TDXPlaySendCompleteEvent read FOnSendComplete write FOnSendComplete;

    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 write SetModemSetting;

    property TCPIPSetting: TDXPlayTCPIPSetting read FTCPIPSetting write SetTCPIPSetting;

    property Async: Boolean read FAsync write FAsync;

    property AsyncSupported: Boolean read FAsyncSupported;

  end;

  TDXPlay = class(TCustomDXPlay)

  published

    property Async;

    property GUID;

    property MaxPlayers;

    property ModemSetting;

    property TCPIPSetting;

    property OnAddPlayer;

    property OnClose;

    property OnDeletePlayer;

    property OnMessage;

    property OnOpen;

    property OnSendComplete;

    property OnSessionLost;

  end;

function DXPlayMessageType(P: Pointer): DWORD;

function DXPlayStringToGUID(const S: string): TGUID;

function DXDirectPlayCreate(const lpGUID: TGUID; out lplpDP:

  //{$IfDef DX7}

  IDirectPlay;

  //{$Else}IDirectPlay8Server{$EndIf};

  pUnk: IUnknown): HRESULT;

implementation

uses DXPlayFm, DXConsts;

function DXPlayMessageType(P: Pointer): DWORD;

begin

  Result := PDPMSG_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:

  //{$IfDef DX7}

  IDirectPlay;

  //{$Else}IDirectPlay8Server{$EndIf};

  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;

{$IFDEF UNICODE}

function DXDirectPlayEnumerate(lpEnumDPCallback: TDPEnumDPCallbackW; lpContext: Pointer): HRESULT;

type

  TDirectPlayEnumerateW= function(lpEnumDPCallback: TDPEnumDPCallbackW; lpContext: Pointer): HRESULT; stdcall;

begin

  Result := TDirectPlayEnumerateW(DXLoadLibrary('DPlayX.dll', 'DirectPlayEnumerateW'))

    (lpEnumDPCallback, lpContext);

end;

function DXDirectPlayLobbyCreate(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyW;

  lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT;

type

  TDirectPlayLobbyCreateW = function(const lpguidSP: TGUID; out lplpDPL: IDirectPlayLobbyW;

    lpUnk: IUnknown; lpData: Pointer; dwDataSize: DWORD): HRESULT; stdcall;

begin

  Result := TDirectPlayLobbyCreateW(DXLoadLibrary('DPlayX.dll', 'DirectPlayLobbyCreateW'))

    (lpguidSP, lplpDPL, lpUnk, lpData, dwDataSize);

end;

{$ELSE}

function DXDirectPlayEnumerate(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT;

type

  TDirectPlayEnumerateA= function(lpEnumDPCallback: TDPEnumDPCallbackA; lpContext: Pointer): HRESULT; stdcall;

begin

  Result := TDirectPlayEnumerateA(DXLoadLibrary('DPlayX.dll', 'DirectPlayEnumerateA'))

    (lpEnumDPCallback, lpContext);

end;

function DXDirectPlayLobbyCreate(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;

{$ENDIF}

{  TDXPlayPlayers  }

constructor TDXPlayPlayers.Create;

begin

  inherited Create(TDXPlayPlayer);

end;

function TDXPlayPlayers.Find(ID: TDPID): TDXPlayPlayer;

var

  i: Integer;

begin

  i := IndexOf(ID);

  if i=-1 then

    raise EDXPlayError.Create(SDXPlayPlayerNotFound);

  Result := Players[i];

end;

function TDXPlayPlayers.IndexOf(ID: TDPID): 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;

procedure TDXPlayModemSetting.Assign(Source: TPersistent);

begin

  if Source is TDXPlayModemSetting then

  begin

    FEnabled := TDXPlayModemSetting(Source).FEnabled;

    FPhoneNumber := TDXPlayModemSetting(Source).FPhoneNumber;

    FModemName := TDXPlayModemSetting(Source).FModemName;

  end else

    inherited Assign(Source);

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

  {$IFDEF UNICODE}

  Lobby1: IDirectPlayLobbyW;

  Lobby: IDirectPlayLobby2W;

  DPlay: IDirectPlay4W;

  {$ELSE}

  Lobby1: IDirectPlayLobbyA;

  Lobby: IDirectPlayLobby2A;

  DPlay: IDirectPlay4A;

  {$ENDIF}

  DPlay1: IDirectPlay;

  lpAddress: Pointer;

  dwAddressSize: DWORD;

begin

  if FModemNames=nil then

  begin

    FModemNames := TStringList.Create;

    try

      if DXDirectPlayLobbyCreate(PGUID(nil)^, Lobby1, nil, nil, 0)<>0 then

        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);

      Lobby := Lobby1 as {$IFDEF UNICODE}IDirectPlayLobby2W{$ELSE}IDirectPlayLobby2A{$ENDIF};

      if DXDirectPlayCreate(DPSPGUID_MODEM, DPlay1, nil)<>0 then

        raise EDXPlayError.CreateFmt(SCannotInitialized, [SDirectPlay]);

      DPlay := DPlay1 as {$IFDEF UNICODE}IDirectPlay4W{$ELSE}IDirectPlay4A{$ENDIF};

      {  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;

{  TDXPlayTCPIPSetting  }

procedure TDXPlayTCPIPSetting.Assign(Source: TPersistent);

begin

  if Source is TDXPlayTCPIPSetting then

  begin

    FEnabled := TDXPlayTCPIPSetting(Source).FEnabled;

    FHostName := TDXPlayTCPIPSetting(Source).FHostName;

  end else

    inherited Assign(Source);

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: PDPMSG_CREATEPLAYERORGROUP;

  Msg_DeletePlayerOrGroup: PDPMSG_DESTROYPLAYERORGROUP;

  Msg_SendComplete: PDPMsg_SendComplete;

  SendCompleteResult: TDXPlaySendCompleteResult;

  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(TDPMSG_GENERIC)) then

          begin

            if idFrom=DPID_SYSMSG then

            begin

              {  System message  }

              case PDPMSG_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

                        {$IFDEF UNICODE}

                        if lpszShortNameW<>nil then

                          Player.FName := lpszShortNameW;

                        {$ELSE}

                        if lpszShortNameA<>nil then

                          Player.FName := lpszShortNameA;

                        {$ENDIF}

                      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

                        Player := Players[i];

                        DoDeletePlayer(Player);

                        Player.Free;

                      end;

                    end;

                  end;

                DPSYS_SESSIONLOST:

                  begin

                    {  The session was lost.  }

                    DoSessionLost;

                    Close;

                  end;

                DPSYS_HOST:

                  begin

                    {  Here became a host.  }

                    FIsHost := True;

                  end;

                DPSYS_SENDCOMPLETE:

                   begin

                     { Send complete  }

                     Msg_SendComplete := lpvMsgBuffer;

                     if Msg_SendComplete.idFrom=FLocalPlayer.FID then

                     begin

                       case Msg_SendComplete.hr of

                         DP_OK        : SendCompleteResult := crOk;

                         DPERR_ABORTED: SendCompleteResult := crAbort;

                         else           SendCompleteResult := crGeneric;

                       end;

                       DoSendComplete(Msg_SendComplete^.dwMsgID, SendCompleteResult, Msg_SendComplete^.dwSendTime);

                     end;

                   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;

procedure TCustomDXPlay.DoSendComplete(MessageID: DWORD; Result: TDXPlaySendCompleteResult;

  SendTime: Integer);

begin

  if Assigned(FOnSendComplete) then FOnSendComplete(Self, MessageID, Result, SendTime);

end;

function TCustomDXPlay.GetProviders: TStrings;

  function EnumProviderCallback(const lpguidSP: TGUID; lpSPName: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPSTR{$ENDIF};

      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

      DXDirectPlayEnumerate(@EnumProviderCallback, FProviders);

    except

      FProviders.Free; FProviders := nil;

      raise;

    end;

  end;

  Result := FProviders;

end;

procedure TCustomDXPlay.GetSessions;

  function EnumSessionsCallback(const lpThisSD: TDPSessionDesc2;

    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));

    {$IFDEF UNICODE}

    TStrings(lpContext).AddObject(lpThisSD.lpszSessionNameW, TObject(Guid));

    {$ELSE}

    TStrings(lpContext).AddObject(lpThisSD.lpszSessionNameA, TObject(Guid));

    {$ENDIF}

    Result := True;

  end;

var

  dpDesc: TDPSessionDesc2;

  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;