vb6 tcp клиент / сервер winsock У меня проблема с подключением клиента к серверу - PullRequest
Новая
       57

vb6 tcp клиент / сервер winsock У меня проблема с подключением клиента к серверу

0 голосов
/ 21 марта 2019

У меня проблема с подключением клиента к серверу.когда более 4 человек с одного ip пытаются подключиться к серверу, клиент начинает мигать, и вы должны завершить процесс из диспетчера задач.А также, если можно настроить, сколько клиентов на устройство. Спасибо Это 2d mmorpg игра под названием Xiaspora.Игра не будет использоваться для получения денег, она просто для развлечения с моими друзьями и их друзьями.

Клиент winsock 

Dim Reconnect As Boolean
Sub Connect()
  Dim serveraddress As String
  Dim serverport As String
  If Start.Client.State = 0 Then
    ReadInfoText serveraddress, serverport
    Start.Client.Connect serveraddress, serverport
  End If
End Sub
Sub Disconnect()
  Start.ConnectTestTimer.Enabled = False
  AddPrivChatText 3, "Disconnected... Attempting to Reconnect"
  If Reconnect = True Then
    Start.Client.Close
    Start.Client.Connect
  Else
    CloseProgram
  End If
End Sub
Sub SendMessage(Message As String)
  If Start.Client.State = 7 Then
    Start.Client.SendData Message & Chr(13)
  End If
End Sub
Sub SendChatMessage(Message As String)
  Dim check As Integer
  Dim checkmessage As String
  If Len(Message) = 0 Then Exit Sub
  If Mid(Message, 1, 4) = ":g::" Then
    SendMessage "4," & Message
    Exit Sub
  End If
  If Mid(Message, 1, 4) = ":G::" Then
    SendMessage "4," & Message
    Exit Sub
  End If
  checkmessage = Mid(Message, 1, 30)
  Do
    check = check + 1
    If Mid(checkmessage, check, 2) = "::" Then Exit Do
  Loop Until check = Len(checkmessage)
  If check = Len(checkmessage) Then
    SendMessage "4," & Message
  Else
    SendMessage "5," & Mid(Message, 1, check - 1) & "," & Mid(Message,         check + 2)
  End If
End Sub
Sub SetReloginTrue()
  Reconnect = True
End Sub
Sub SetReloginFalse()
  Reconnect = False
End Sub
Function Relogin() As Boolean
  Relogin = Reconnect
End Function

Option Explicit

Dim intWCount As Integer    'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
  'WriteSub "Winsock-addserverlogtext" & Message
  If Len(Main.ServerLogText.Text) > 15000 Then
    Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Mid(Main.ServerLogText.Text, 1, 14000)
  Else
    Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Main.ServerLogText.Text
  End If
End Sub
Sub StartServer()
  Dim ThePort As String
  ReadInfoText ThePort
  Main.Server(0).LocalPort = ThePort
  Main.Server(0).Listen
  AddServerLogText "Server Now Running on Port " & ThePort
End Sub

Sub CloseCon(Index As Integer)
  On Error Resume Next
  If Index = 0 Then Exit Sub
  LogOutProcedure Index
  WriteSub "Winsock-closecon"
  Main.Server(Index).Close
  Unload Main.EngageTimer(Index)
  AddServerLogText Index & ": Closed"
  PacketCheck(Index) = 0
End Sub

Sub ConnectionRequestCon(ByVal requestID As Long)
  On Error Resume Next
  Dim check As Integer
  Dim LoggedOn As Integer
  Dim NewIndex As Integer
  Dim RandomCheck As Integer
  NewIndex = GetFreeIndex
  LogOutProcedure NewIndex
  RandomizeConLandLaunch NewIndex
  Load Main.Server(NewIndex)
  Load Main.EngageTimer(NewIndex)
  Main.Server(NewIndex).Accept requestID
  AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
  RandomCheck = RandomNumber(1000, 30000)
  SetConAuthNumber NewIndex, RandomCheck
  Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
  DoEvents
  Do
    check = check + 1
    If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
  Loop Until check = Main.Server.Count
  If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
  WriteSub "Winsock-getfreeindex"
  On Error Resume Next
  Dim check As Long

  For check = 1 To Main.Server.Count
    If Main.Server(check).State <> 9 Then
      Main.Server(check).Close
      GetFreeIndex = check
      Exit Function
    End If
    If check > Main.Server.Count Then
      GetFreeIndex = Main.Server.Count + 1
      Exit Function
    End If
  Next

  intWCount = intWCount + 1
  GetFreeIndex = intWCount
End Function

Sub GetDataCon(Index As Integer)
  WriteSub "Winsock-getdatacon"
  Dim themax As Integer
  Dim ndata As String
  Dim check As Integer
  Dim curloc As Integer
  Main.Server(Index).GetData ndata
  Dim num As Integer
  num = FreeFile
  Open "lastpack.txt" For Output As num
  Print #num, Date & " " & Time & " " & ndata
  Close num
  themax = MaxPack(ndata)
  Do
    check = check + 1
    PacketCheck(Index) = PacketCheck(Index) + 1
    If PacketCheck(Index) = 50 Then
      CloseCon Index
      Exit Sub
    End If
    If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata, curloc)
  Loop Until check >= themax
  If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
  WriteSub "Winsock-privmsg"
  On Error GoTo FuCK
  If ToCon = 0 Then Exit Sub
  If Main.Server(ToCon).State = 7 Then
    If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " &    Message 'Only During Problems
    If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " & Message ' If you have problems
    'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
    Main.Server(ToCon).SendData Message & Chr(13)
    DoEvents
  End If
Exit Sub
FuCK:
  AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
  LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
  Dim check As Integer
  Do
    check = check + 1
    If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
    If PacketCheck(check) < 0 Then PacketCheck(check) = 0
  Loop Until check >= Main.Server.Count
End Sub

Сервер Winsock 

Option Explicit

Dim intWCount As Integer    'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
  'WriteSub "Winsock-addserverlogtext" & Message
  If Len(Main.ServerLogText.Text) > 15000 Then
    Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf &     Mid(Main.ServerLogText.Text, 1, 14000)
  Else
    Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf &         Main.ServerLogText.Text
  End If
End Sub
Sub StartServer()
  Dim ThePort As String
  ReadInfoText ThePort
  Main.Server(0).LocalPort = ThePort
  Main.Server(0).Listen
  AddServerLogText "Server Now Running on Port " & ThePort
End Sub

Sub CloseCon(Index As Integer)
  On Error Resume Next
  If Index = 0 Then Exit Sub
  LogOutProcedure Index
  WriteSub "Winsock-closecon"
  Main.Server(Index).Close
  Unload Main.EngageTimer(Index)
  AddServerLogText Index & ": Closed"
  PacketCheck(Index) = 0
End Sub

Sub ConnectionRequestCon(ByVal requestID As Long)
  On Error Resume Next
  Dim check As Integer
  Dim LoggedOn As Integer
  Dim NewIndex As Integer
  Dim RandomCheck As Integer
  NewIndex = GetFreeIndex
  LogOutProcedure NewIndex
  RandomizeConLandLaunch NewIndex
  Load Main.Server(NewIndex)
  Load Main.EngageTimer(NewIndex)
  Main.Server(NewIndex).Accept requestID
  AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
  RandomCheck = RandomNumber(1000, 30000)
  SetConAuthNumber NewIndex, RandomCheck
  Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " &             TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck &     Chr(13)
  DoEvents
  Do
    check = check + 1
    If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP =     Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
  Loop Until check = Main.Server.Count
  If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
  WriteSub "Winsock-getfreeindex"
  On Error Resume Next
  Dim check As Long

  For check = 1 To Main.Server.Count
    If Main.Server(check).State <> 9 Then
      Main.Server(check).Close
      GetFreeIndex = check
      Exit Function
    End If
    If check > Main.Server.Count Then
      GetFreeIndex = Main.Server.Count + 1
      Exit Function
    End If
  Next
  intWCount = intWCount + 1
  GetFreeIndex = intWCount
End Function

Sub GetDataCon(Index As Integer)
  WriteSub "Winsock-getdatacon"
  Dim themax As Integer
  Dim ndata As String
  Dim check As Integer
  Dim curloc As Integer
  Main.Server(Index).GetData ndata
  Dim num As Integer
  num = FreeFile
  Open "lastpack.txt" For Output As num
  Print #num, Date & " " & Time & " " & ndata
  Close num
  themax = MaxPack(ndata)
  Do
    check = check + 1
    PacketCheck(Index) = PacketCheck(Index) + 1
    If PacketCheck(Index) = 50 Then
      CloseCon Index
      Exit Sub
    End If
    If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata,     curloc)
  Loop Until check >= themax
  If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
  WriteSub "Winsock-privmsg"
  On Error GoTo FuCK
  If ToCon = 0 Then Exit Sub
  If Main.Server(ToCon).State = 7 Then
    If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " &         Message 'Only During Problems
    If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " &     Message ' If you have problems
    'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
    Main.Server(ToCon).SendData Message & Chr(13)
    DoEvents
  End If
  Exit Sub
FuCK:
  AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
  LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
  Dim check As Integer
  Do
    check = check + 1
    If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
    If PacketCheck(check) < 0 Then PacketCheck(check) = 0
  Loop Until check >= Main.Server.Count
End Sub
...