dxplay.pas

为delphi量身打造的 direct x控件代码

unit DXPlay;

interface

{$INCLUDE DelphiXcfg.inc}

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

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

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;