phr33k
03-15-2001, 08:31 PM
Ok im making a multi client chat server and clients. This is how it work , the client sends a message to the server , and the server relays it back to everyclient connected to it. This works fine if i connect to myself when i run the server, i can load up how many clients i want and connect with all of them , the server relays the info and everything. This also works on computers on my lan. Buts lets say i send the client to someone , They connect fine, their name appears in the server list, But the problem is , The server Doesnt Send them any data and i cant understand why it works with comps on my lan and not external computers. Anyways heres the code for the server.
<PRE>
' We'll limit it to 101 users at a time! ;)
Dim Users(0 To 100) As String
----------------------------------------------------------
Private Sub cmdCaption_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(User).SendData "c" & Chr(1) & InputBox("What do you want to have their caption set to?", "Alter Caption", "Hi!")
End Sub
----------------------------------------------------------
Private Sub cmdMsgBox_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(RetrieveUser(lstUsers.Text)).SendData "m" & Chr(1) & InputBox("What do you want to have displayed on their machine?", "Popup MsgBox", "Hi!")
End Sub
----------------------------------------------------------
Private Sub Command1_Click()
If lstUsers.ListCount = 0 Then
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
Exit Sub
End If
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
Exit Sub
End If
wsArray(User).SendData "k" & Chr(1) & txtSendMessage.Text
txtSendMessage.Text = ""
End Sub
----------------------------------------------------------
Private Sub Form_Load()
wsListen.Listen ' make it listen
End Sub
----------------------------------------------------------
Private Sub txtSendMessage_KeyDown(KeyCode As Integer, Shift As Integer)
Dim User As Integer
'First, check to make sure someone's logged in
If lstUsers.ListCount = 0 And KeyCode = 13 Then
'Display popup
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
'Clear input
txtSendMessage.Text = ""
Exit Sub
End If
' If it was enter and shift wasn't pressed, then...
If KeyCode = 13 And Shift = 0 Then
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
' RetrieveUser returns -1 if the user wasn't found
If User = -1 Then
Exit Sub
End If
' format the message
wsArray(User).SendData "t" & Chr(1) & txtSendMessage.Text
' Blank the input
txtSendMessage.Text = ""
ElseIf KeyCode = 13 And Shift = 1 Then
' Loop through the users.
' There's better ways of doing this
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & txtSendMessage.Text
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
txtSendMessage.Text = ""
End If
End Sub
----------------------------------------------------------
Private Function RetrieveUser(UserName As String) As Integer
Dim X As Integer
'Check to see if nothing was selected
If UserName = "" Then
'OK, nothing selected, let's see how full
' the list is!
If lstUsers.ListCount = 0 Then
'Nothing in the list, so return -1
RetrieveUser = -1
Exit Function
End If
'If there is something in the list, send it to
' the first one =)
UserName = lstUsers.List(0)
End If
' Count through the users
For X = 0 To 100
'Check username to see if it is the right one
If Users(X) = UserName Then
'Ok, this is our man, so let's return his
' winsock index
RetrieveUser = X
Exit Function
End If
Next X
RetrieveUser = -1
End Function
----------------------------------------------------------
Private Sub txtSendMessage_KeyPress(KeyAscii As Integer)
'Let's get rid of the annoying beep =)
If KeyAscii = 13 Then KeyAscii = 0
End Sub
----------------------------------------------------------
Private Sub wsArray_Close(Index As Integer)
' Let's cycle through the list, looking for their
' name
For X = 0 To lstUsers.ListCount - 1
' Check to see if it matches
If lstUsers.List(X) = Users(Index) Then
' It matches, so let's remove it form the
' list and the array
Users(Index) = ""
For sex = 0 To 100
' If there's a username listed for them
If Users(sex) <> "" Then
'Send the message
wsArray(sex).SendData "r" & Chr(1) & lstUsers.List(X)
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next sex
lstUsers.RemoveItem X
Exit For
End If
Next X
End Sub
----------------------------------------------------------
Private Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Data As String, CtrlChar As String
wsArray(Index).GetData Data
' Our format for our messages is this:
' CtrlChar & chr(1) & <info>
If InStr(1, Data, Chr(1)) <> 2 Then
' If the 2nd char isn't chr(1), we know we have a prob
MsgBox "Unknown Data Format: " & vbCrLf & _
Data, vbCritical, "Error receiving"
' Make sure to leave the sub so it doesn't
' try to process the invalid info!
Exit Sub
End If
'Retrieve First Character
CtrlChar = Left(Data, 1)
'Make sure to trim it, and chr(1), off
Data = Mid(Data, 3)
' Check what it is, without regard to case
Select Case LCase(CtrlChar)
'This is to display a msgbox.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "m"
MsgBox Data, vbInformation, "Msg from client"
'This is to change the caption.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "c"
Me.Caption = "Server - " & Data
'This is their "login" key
Case "u"
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "u" & Chr(1) & Data
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
If lstUsers.List(0) <> "" Then wsArray(Index).SendData "z" & Chr(1) & lstUsers.List(0) & "ß"
If lstUsers.List(1) <> "" Then wsArray(Index).SendData lstUsers.List(1) & "ß"
If lstUsers.List(2) <> "" Then wsArray(Index).SendData lstUsers.List(2) & "ß"
If lstUsers.List(3) <> "" Then wsArray(Index).SendData lstUsers.List(3) & "ß"
If lstUsers.List(4) <> "" Then wsArray(Index).SendData lstUsers.List(4) & "ß"
If lstUsers.List(5) <> "" Then wsArray(Index).SendData lstUsers.List(5) & "ß"
If lstUsers.List(6) <> "" Then wsArray(Index).SendData lstUsers.List(6) & "ß"
If lstUsers.List(7) <> "" Then wsArray(Index).SendData lstUsers.List(7) & "ß"
If lstUsers.List(8) <> "" Then wsArray(Index).SendData lstUsers.List(8) & "ß"
If lstUsers.List(9) <> "" Then wsArray(Index).SendData lstUsers.List(9) & "ß"
If lstUsers.List(10) <> "" Then wsArray(Index).SendData lstUsers.List(10) & "ß"
If lstUsers.List(11) <> "" Then wsArray(Index).SendData lstUsers.List(11) & "ß"
If lstUsers.List(12) <> "" Then wsArray(Index).SendData lstUsers.List(12) & "ß"
If lstUsers.List(13) <> "" Then wsArray(Index).SendData lstUsers.List(13) & "ß"
If lstUsers.List(14) <> "" Then wsArray(Index).SendData lstUsers.List(14) & "ß"
If lstUsers.List(15) <> "" Then wsArray(Index).SendData lstUsers.List(15) & "ß"
'Add their name to the list
lstUsers.AddItem Data
'Add their name to the array
Users(Index) = Data
' We need to remember that both
' the winsock index and the user array
' index correspond. So you can find a
' users name by going "Users(<winsock index>)"
' or you can find the winsock index with
' a text name by cycling through the array.
' That's what the function "RetrieveUser"
' does - gets their winsock index from their
' username
' If all else fails, print it to output =)
Case Else
txtReceived.SelStart = Len(txtReceived.Text)
txtReceived.SelText = Data & vbCrLf
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & Data
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
End Select
End Sub
----------------------------------------------------------
Private Sub wsArray_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsArray(" & Index & ") - " & Number & " - " & Description & vbCrLf
' Close it =)
wsArray(Index).Close
End Sub
----------------------------------------------------------
Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
Index = FindOpenWinsock
' Accept the request using the created winsock
wsArray(Index).Accept requestID
End Sub
----------------------------------------------------------
Private Sub wsListen_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsListen - " & Number & " - " & Description & vbCrLf
End Sub
----------------------------------------------------------
Private Function FindOpenWinsock()
Static LocalPorts As Integer ' Static keeps the
' variable's state
For X = 0 To wsArray.UBound
If wsArray(X).State = 0 Then
' We found one that's state is 0, which
' means "closed", so let's use it
FindOpenWinsock = X
' make sure to leave function
Exit Function
End If
Next X
' OK, none are open so let's make one
Load wsArray(wsArray.UBound + 1)
' Let's make sure we don't get conflicting local ports
LocalPorts = LocalPorts + 1
wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts
' and then let's return it's index value
FindOpenWinsock = wsArray.UBound
End Function
----------------------------------------------------------
</PRE>
I know this is alot of code but its easy to see where the connection is involved, on data arrival etc etc , Alright so anyone plz help me. The whole SOURCE code is attached thanks..
<PRE>
' We'll limit it to 101 users at a time! ;)
Dim Users(0 To 100) As String
----------------------------------------------------------
Private Sub cmdCaption_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(User).SendData "c" & Chr(1) & InputBox("What do you want to have their caption set to?", "Alter Caption", "Hi!")
End Sub
----------------------------------------------------------
Private Sub cmdMsgBox_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(RetrieveUser(lstUsers.Text)).SendData "m" & Chr(1) & InputBox("What do you want to have displayed on their machine?", "Popup MsgBox", "Hi!")
End Sub
----------------------------------------------------------
Private Sub Command1_Click()
If lstUsers.ListCount = 0 Then
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
Exit Sub
End If
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
Exit Sub
End If
wsArray(User).SendData "k" & Chr(1) & txtSendMessage.Text
txtSendMessage.Text = ""
End Sub
----------------------------------------------------------
Private Sub Form_Load()
wsListen.Listen ' make it listen
End Sub
----------------------------------------------------------
Private Sub txtSendMessage_KeyDown(KeyCode As Integer, Shift As Integer)
Dim User As Integer
'First, check to make sure someone's logged in
If lstUsers.ListCount = 0 And KeyCode = 13 Then
'Display popup
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
'Clear input
txtSendMessage.Text = ""
Exit Sub
End If
' If it was enter and shift wasn't pressed, then...
If KeyCode = 13 And Shift = 0 Then
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
' RetrieveUser returns -1 if the user wasn't found
If User = -1 Then
Exit Sub
End If
' format the message
wsArray(User).SendData "t" & Chr(1) & txtSendMessage.Text
' Blank the input
txtSendMessage.Text = ""
ElseIf KeyCode = 13 And Shift = 1 Then
' Loop through the users.
' There's better ways of doing this
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & txtSendMessage.Text
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
txtSendMessage.Text = ""
End If
End Sub
----------------------------------------------------------
Private Function RetrieveUser(UserName As String) As Integer
Dim X As Integer
'Check to see if nothing was selected
If UserName = "" Then
'OK, nothing selected, let's see how full
' the list is!
If lstUsers.ListCount = 0 Then
'Nothing in the list, so return -1
RetrieveUser = -1
Exit Function
End If
'If there is something in the list, send it to
' the first one =)
UserName = lstUsers.List(0)
End If
' Count through the users
For X = 0 To 100
'Check username to see if it is the right one
If Users(X) = UserName Then
'Ok, this is our man, so let's return his
' winsock index
RetrieveUser = X
Exit Function
End If
Next X
RetrieveUser = -1
End Function
----------------------------------------------------------
Private Sub txtSendMessage_KeyPress(KeyAscii As Integer)
'Let's get rid of the annoying beep =)
If KeyAscii = 13 Then KeyAscii = 0
End Sub
----------------------------------------------------------
Private Sub wsArray_Close(Index As Integer)
' Let's cycle through the list, looking for their
' name
For X = 0 To lstUsers.ListCount - 1
' Check to see if it matches
If lstUsers.List(X) = Users(Index) Then
' It matches, so let's remove it form the
' list and the array
Users(Index) = ""
For sex = 0 To 100
' If there's a username listed for them
If Users(sex) <> "" Then
'Send the message
wsArray(sex).SendData "r" & Chr(1) & lstUsers.List(X)
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next sex
lstUsers.RemoveItem X
Exit For
End If
Next X
End Sub
----------------------------------------------------------
Private Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Data As String, CtrlChar As String
wsArray(Index).GetData Data
' Our format for our messages is this:
' CtrlChar & chr(1) & <info>
If InStr(1, Data, Chr(1)) <> 2 Then
' If the 2nd char isn't chr(1), we know we have a prob
MsgBox "Unknown Data Format: " & vbCrLf & _
Data, vbCritical, "Error receiving"
' Make sure to leave the sub so it doesn't
' try to process the invalid info!
Exit Sub
End If
'Retrieve First Character
CtrlChar = Left(Data, 1)
'Make sure to trim it, and chr(1), off
Data = Mid(Data, 3)
' Check what it is, without regard to case
Select Case LCase(CtrlChar)
'This is to display a msgbox.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "m"
MsgBox Data, vbInformation, "Msg from client"
'This is to change the caption.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "c"
Me.Caption = "Server - " & Data
'This is their "login" key
Case "u"
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "u" & Chr(1) & Data
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
If lstUsers.List(0) <> "" Then wsArray(Index).SendData "z" & Chr(1) & lstUsers.List(0) & "ß"
If lstUsers.List(1) <> "" Then wsArray(Index).SendData lstUsers.List(1) & "ß"
If lstUsers.List(2) <> "" Then wsArray(Index).SendData lstUsers.List(2) & "ß"
If lstUsers.List(3) <> "" Then wsArray(Index).SendData lstUsers.List(3) & "ß"
If lstUsers.List(4) <> "" Then wsArray(Index).SendData lstUsers.List(4) & "ß"
If lstUsers.List(5) <> "" Then wsArray(Index).SendData lstUsers.List(5) & "ß"
If lstUsers.List(6) <> "" Then wsArray(Index).SendData lstUsers.List(6) & "ß"
If lstUsers.List(7) <> "" Then wsArray(Index).SendData lstUsers.List(7) & "ß"
If lstUsers.List(8) <> "" Then wsArray(Index).SendData lstUsers.List(8) & "ß"
If lstUsers.List(9) <> "" Then wsArray(Index).SendData lstUsers.List(9) & "ß"
If lstUsers.List(10) <> "" Then wsArray(Index).SendData lstUsers.List(10) & "ß"
If lstUsers.List(11) <> "" Then wsArray(Index).SendData lstUsers.List(11) & "ß"
If lstUsers.List(12) <> "" Then wsArray(Index).SendData lstUsers.List(12) & "ß"
If lstUsers.List(13) <> "" Then wsArray(Index).SendData lstUsers.List(13) & "ß"
If lstUsers.List(14) <> "" Then wsArray(Index).SendData lstUsers.List(14) & "ß"
If lstUsers.List(15) <> "" Then wsArray(Index).SendData lstUsers.List(15) & "ß"
'Add their name to the list
lstUsers.AddItem Data
'Add their name to the array
Users(Index) = Data
' We need to remember that both
' the winsock index and the user array
' index correspond. So you can find a
' users name by going "Users(<winsock index>)"
' or you can find the winsock index with
' a text name by cycling through the array.
' That's what the function "RetrieveUser"
' does - gets their winsock index from their
' username
' If all else fails, print it to output =)
Case Else
txtReceived.SelStart = Len(txtReceived.Text)
txtReceived.SelText = Data & vbCrLf
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & Data
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
End Select
End Sub
----------------------------------------------------------
Private Sub wsArray_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsArray(" & Index & ") - " & Number & " - " & Description & vbCrLf
' Close it =)
wsArray(Index).Close
End Sub
----------------------------------------------------------
Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
Index = FindOpenWinsock
' Accept the request using the created winsock
wsArray(Index).Accept requestID
End Sub
----------------------------------------------------------
Private Sub wsListen_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsListen - " & Number & " - " & Description & vbCrLf
End Sub
----------------------------------------------------------
Private Function FindOpenWinsock()
Static LocalPorts As Integer ' Static keeps the
' variable's state
For X = 0 To wsArray.UBound
If wsArray(X).State = 0 Then
' We found one that's state is 0, which
' means "closed", so let's use it
FindOpenWinsock = X
' make sure to leave function
Exit Function
End If
Next X
' OK, none are open so let's make one
Load wsArray(wsArray.UBound + 1)
' Let's make sure we don't get conflicting local ports
LocalPorts = LocalPorts + 1
wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts
' and then let's return it's index value
FindOpenWinsock = wsArray.UBound
End Function
----------------------------------------------------------
</PRE>
I know this is alot of code but its easy to see where the connection is involved, on data arrival etc etc , Alright so anyone plz help me. The whole SOURCE code is attached thanks..