dxplay.pas

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

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(TDPID: TDPID; dwPlayerType: DWORD;
    const lpName: DPNAME; dwFlags: DWORD; lpContext: Pointer): BOOL;
    stdcall;
  var
    Player: TDXPlayPlayer;
  begin
    Player := TDXPlayPlayer.Create(TCustomDXPlay(lpContext).Players);
    Player.FID := TDPID;
    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: TDPID; Data: Pointer; DataSize: Integer);
begin
  SendMessageEx(ToID, Data, DataSize, DPSEND_GUARANTEED);
end;

procedure TCustomDXPlay.SendMessageEx(ToID: TDPID; 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.