VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1
Caption = "WinSock"
ClientHeight = 3555
ClientLeft = 60
ClientTop = 345
ClientWidth = 6015
Icon = "Form1.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 3555
ScaleWidth = 6015
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton Command1
Caption = "?"
Height = 375
Left = 1920
TabIndex = 4
Top = 120
Width = 255
End
Begin VB.Timer Timer1
Interval = 100
Left = 4320
Top = 600
End
Begin VB.CommandButton Command3
Caption = "Start Server"
Height = 375
Left = 120
TabIndex = 0
Top = 120
Width = 1695
End
Begin VB.CommandButton Command2
Caption = "Connect to Server"
Height = 375
Left = 2280
TabIndex = 1
Top = 120
Width = 1695
End
Begin VB.TextBox Text4
BackColor = &H00000000&
BeginProperty Font
Name = "Courier New"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 2205
Left = 120
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 3
TabStop = 0 'False
Top = 960
Width = 3735
End
Begin VB.TextBox Text3
BackColor = &H00000000&
BeginProperty Font
Name = "Courier New"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 285
Left = 120
TabIndex = 2
Text = "Enter message-text here and press return."
Top = 600
Width = 3615
End
Begin MSWinsockLib.Winsock Winsock1
Index = 0
Left = 4320
Top = 1440
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const CLIENT = 0
Const ROOTSOCKET = 0
Public winSockPort As Long
Public nickName As String
Public maxClients As Long
Public rHostIP As String
Private rHostName As String
Private iAmServer As Boolean
Private serverIsFull As Boolean
Private clientCount As Long
Private timer1oldState() As Long
Private serverStartNow As Variant
Private exitMutex As Boolean
Private doExit As Boolean
Private timeOut As Long
Private Sub Command1_Click()
' print about this exe
Dim clcnt As Long
addLine ""
addLine "------------------------------------------------"
addLine "WinSock - Version " & App.Major & "." & App.Minor & "." & App.Revision
addLine "------------------------------------------------"
addLine "Multi client chat via TCP/IP"
addLine "------------------------------------------------"
addLine "Quick test:"
addLine "1. Run WinSock.exe and start a Server"
addLine "2. Run WinSock.exe and start a Client"
addLine "3. Enter 127.0.0.1 in the Popup-Dialog"
addLine "4. Chat with yourself"
addLine "------------------------------------------------"
If (iAmServer) Then
addLine "Server Info:"
addLine "Running port = " & winSockPort
addLine "Online since = " & serverStartNow
addLine "Maximum clients = " & maxClients
clcnt = getOnlineClientCount
addLine "Connected clients = " & clcnt
If (clcnt = 0) Then
addLine "(none)"
Else
addLine createClientNameList
End If
addLine "------------------------------------------------"
addLine "Enter 'kickName=nnn' /where nnn is the "
addLine "Client-Nick-Name to kick from this Server."
addLine "------------------------------------------------"
Else
addLine "List of Commands:"
addLine "1. nickName=nnn /where nnn is your new nick name"
addLine "2. listNames /list all online clients"
addLine "------------------------------------------------"
End If
End Sub
Private Function getOnlineClientCount() As Long
Dim res As Long
Dim i As Long
For i = 1 To clientCount
If (Winsock1(i).Tag <> "__FREE__") Then
res = res + 1
End If
Next i
getOnlineClientCount = res
End Function
Private Sub Command2_Click()
' connect to server
On Error GoTo Hell
Dim t1 As Single
Dim oldState As Long
Dim t1Dot As Long
Dim i As Long
If (Winsock1(CLIENT).state <> sckClosed) Then
If (iAmServer) Then
MsgBox "Cannot connect. Server is running."
Exit Sub
End If
Dim res As VbMsgBoxResult
res = MsgBox("You are already connected to Server:" _
& vbNewLine _
& rHostName _
& vbNewLine & vbNewLine _
& "Close current connection?", _
vbYesNo, "WinSock")
If (res = vbYes) Then
Winsock1(CLIENT).Close
addLine "Connection closed."
DoEvents
Else
Exit Sub
End If
End If
oldState = Winsock1(CLIENT).state
serverIsFull = False
rHostIP = ""
Winsock1(CLIENT).LocalPort = 0
frmLogin.Show vbModal, Me
If Not (frmLogin.settingsValid) Then Exit Sub
If (Len(rHostIP) > 0) Then
addLine "searching Server..."
DoEvents
rHostName = getHostName(rHostIP)
DoEvents
addLine ">>> WinSock Server is: " & rHostName & " <<<"
Winsock1(CLIENT).Connect rHostIP, winSockPort
t1 = Timer
exitMutex = True
Do
If (oldState <> Winsock1(CLIENT).state) Then
oldState = Winsock1(CLIENT).state
addLine ""
addText stateToString(oldState)
End If
If (Winsock1(CLIENT).state = sckConnected) Then Exit Do
If (Timer > t1 + timeOut) Then Exit Do
If (Timer > t1 + t1Dot) Then
t1Dot = t1Dot + 1
addText "."
End If
For i = 1 To 500
DoEvents
If (Winsock1(CLIENT).state = sckClosed) Then Exit Do
Next i
Loop
exitMutex = False
addLine ""
If (doExit) Then
Unload Me
Exit Sub
End If
If (Winsock1(CLIENT).state <> sckConnected) Then
If (Winsock1(CLIENT).state <> sckClosed) Then
addLine "ERROR: Connect timeout (" & timeOut & " sec)."
Winsock1(CLIENT).Close
addLine "Connection closed."
End If
Else
DoEvents
If Not (serverIsFull) Then
addLine "Connect OK to server " & Winsock1(CLIENT).RemoteHostIP
DoEvents
Winsock1(CLIENT).SendData "nickName=" & nickName
DoEvents
Winsock1(CLIENT).Tag = nickName
Text3.SetFocus
Text3.SelStart = 0
Text3.SelLength = Len(Text3.text)
End If
End If
End If
Exit Sub
Hell:
errorHandler "Error while connecting to server " & _
Winsock1(CLIENT).RemoteHostIP
End Sub
Private Sub Command3_Click()
' start server
On Error GoTo Hell
If (Winsock1(ROOTSOCKET).state <> sckClosed) Then
If Not (iAmServer) Then
MsgBox "Cannot start Server. You are connected as Client."
Exit Sub
End If
Dim res As VbMsgBoxResult
Dim cl As Long
cl = getOnlineClientCount
res = MsgBox("Server is already running." _
& vbNewLine _
& "Info: " & cl & " Clients are connected right now." _
& vbNewLine & vbNewLine _
& "Close running Server and start a new one?", _
vbYesNo, "WinSock")
If (res = vbYes) Then
closeAllConnections
Winsock1(ROOTSOCKET).Close
addLine "Server stop OK."
Else
Exit Sub
End If
End If
Dialog.Show vbModal, Me
If Not (Dialog.settingsValid) Then Exit Sub
ReDim timer1oldState(maxClients)
Winsock1(ROOTSOCKET).Bind winSockPort
Winsock1(ROOTSOCKET).Listen
addLine "Server start OK on port " & winSockPort & "."
Text3.SetFocus
Text3.SelStart = 0
Text3.SelLength = Len(Text3.text)
iAmServer = True
serverStartNow = Now
Exit Sub
Hell:
errorHandler "Error while starting server at port " & _
Winsock1(ROOTSOCKET).LocalPort
End Sub
Private Function getFreeSocketIndex() As Integer
Dim i As Integer
Dim res As Integer
For i = 1 To clientCount
If (Winsock1(i).Tag = "__FREE__") Then
If (Winsock1(i).state <> sckClosed) Then
Winsock1(i).Close
End If
getFreeSocketIndex = i
Exit Function
End If
Next i
If (clientCount < maxClients) Then
clientCount = clientCount + 1
Load Winsock1(clientCount)
getFreeSocketIndex = clientCount
Else
getFreeSocketIndex = maxClients + 1
End If
End Function
Private Sub Winsock1_ConnectionRequest(index As Integer, _
ByVal requestID As Long)
On Error GoTo Hell
Dim socketIndex As Integer
If (iAmServer) Then
' only accept requests to ROOTSOCKET
If (index = ROOTSOCKET) Then
' delegate request to next instance
socketIndex = getFreeSocketIndex
If (socketIndex <= maxClients) Then
Winsock1(socketIndex).Accept requestID
addLine "Connection accepted with:"
addLine " IP=" & Winsock1(socketIndex).RemoteHostIP
addLine " Name=" & getHostName(Winsock1(socketIndex).RemoteHostIP)
addLine " Port=" & Winsock1(socketIndex).RemotePort
Exit Sub
Else
' make temp-instance and say goodbye
Load Winsock1(clientCount + 1)
Winsock1(clientCount + 1).Accept requestID
Winsock1(clientCount + 1).SendData vbNewLine & _
">>> No more Clients allowed. Goodbey <<<"
DoEvents
Winsock1(clientCount + 1).Close
DoEvents
Unload Winsock1(clientCount + 1)
End If
End If
End If
DoEvents
Exit Sub
Hell:
errorHandler "Error while establishing connection to " & _
Winsock1(clientCount).RemoteHostIP
End Sub
Private Sub kickByName(name As String)
Dim i As Long
Dim ok As Boolean
For i = 1 To clientCount
If (name = Winsock1(i).Tag) Then
Winsock1(i).SendData ">>> You are kicked by SERVER <<<"
sendToAll ">>> " & name & " was kicked by SERVER <<<", i
DoEvents
Winsock1_Close CInt(i)
ok = True
End If
Next i
If (ok) Then
addLine name & " was kicked."
Else
addLine "Cannot kick " & name & ". Name unknown. Press ?-button."
End If
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
' send message
On Error GoTo Hell
Dim i As Long
Dim myText As String
myText = Text3.text
If (KeyCode = vbKeyReturn And _
myText <> "Enter message-text here and press return.") Then
If (iAmServer) Then
If (clientCount > 0) Then
addLine "SERVER: " & myText
Text3.text = ""
If (Left$(myText, 9) = "kickName=") Then
kickByName Right$(myText, Len(myText) - 9)
Else
sendToAll "SERVER: " & myText, 0
End If
Else
addLine "ERROR: Cannot send message, no clients connected."
End If
Else
If (Winsock1(CLIENT).state <> sckConnected) Then
If (Winsock1(CLIENT).state <> sckConnecting) Then
addLine "ERROR: Cannot send message, no connection."
End If
Else
addLine nickName & ": " & myText
Winsock1(CLIENT).SendData myText
Text3.text = ""
End If
End If
End If
Exit Sub
Hell:
errorHandler "Error while sending message to " & Winsock1(i).RemoteHostIP
End Sub
Private Sub Form_Load()
On Error GoTo SafeSettings
If (configFileFound) Then
loadConfigFile
Else
SafeSettings:
addLine "File 'WinSockConfig.dat' not found."
addLine "Loading safe settings."
winSockPort = 9843
maxClients = 10
timeOut = 20
frmLogin.lastIP_Byte1 = 127
frmLogin.lastIP_Byte2 = 0
frmLogin.lastIP_Byte3 = 0
frmLogin.lastIP_Byte4 = 1
End If
ReDim timer1oldState(maxClients)
End Sub
Private Function configFileFound() As Boolean
On Error Resume Next
Dim s As String
s = Dir(App.Path & "\WinSockConfig.dat")
configFileFound = (s <> "")
End Function
Private Sub loadConfigFile()
On Error GoTo Hell
Dim fileNr As Long
Dim fileName As String
Dim temp1 As Byte
Dim temp2 As Byte
Dim temp3 As Byte
Dim temp4 As Byte
fileNr = FreeFile
fileName = App.Path & "\WinSockConfig.dat"
Open fileName For Input As #fileNr
Input #fileNr, winSockPort
Input #fileNr, maxClients
Input #fileNr, temp1
Input #fileNr, temp2
Input #fileNr, temp3
Input #fileNr, temp4
Input #fileNr, nickName
Input #fileNr, timeOut
Close #fileNr
frmLogin.lastIP_Byte1 = temp1
frmLogin.lastIP_Byte2 = temp2
frmLogin.lastIP_Byte3 = temp3
frmLogin.lastIP_Byte4 = temp4
Exit Sub
Hell:
Close #fileNr
Err.Raise Number:=1001, Description:="Error while loading 'WinSockConfig.dat"
End Sub
Private Sub safeConfigFile()
On Error Resume Next
Dim fileNr As Long
Dim fileName As String
fileNr = FreeFile
fileName = App.Path & "\WinSockConfig.dat"
Open fileName For Output As #fileNr
Write #fileNr, winSockPort
Write #fileNr, maxClients
Write #fileNr, frmLogin.lastIP_Byte1
Write #fileNr, frmLogin.lastIP_Byte2
Write #fileNr, frmLogin.lastIP_Byte3
Write #fileNr, frmLogin.lastIP_Byte4
Write #fileNr, nickName
Write #fileNr, timeOut
Close #fileNr
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If (Winsock1(ROOTSOCKET).state <> sckClosed) Then
Winsock1(ROOTSOCKET).Close
DoEvents
End If
If (exitMutex) Then
Cancel = 1
addLine ""
addLine "------------------------------------------"
addLine "Cannot exit while connecting. Please wait."
addLine "------------------------------------------"
doExit = True
Else
closeAllConnections
safeConfigFile
End If
End Sub
Private Sub closeAllConnections()
Dim i As Long
For i = 1 To clientCount
If (Winsock1(i).state <> sckClosed) Then
Winsock1(i).Close
DoEvents
End If
Unload Winsock1(i)
Next i
clientCount = 0
End Sub
Private Sub Form_Resize()
If (Form1.WindowState <> vbMinimized) Then
If (Form1.ScaleWidth > 220) Then
Text4.Width = Form1.ScaleWidth - 220
Text3.Width = Form1.ScaleWidth - 220
End If
If (Form1.ScaleHeight > Text4.Top + 150) Then
Text4.Height = Form1.ScaleHeight - Text4.Top - 150
End If
End If
End Sub
Private Sub Timer1_Timer()
Static i As Long
Static s As String
Static n As String
For i = 0 To clientCount
If (timer1oldState(i) <> Winsock1(i).state) Then
timer1oldState(i) = Winsock1(i).state
s = stateToString(timer1oldState(i))
If (iAmServer) Then
n = " [" & getHostName(Winsock1(i).RemoteHostIP) & "]"
Form1.Caption = "WinSock SERVER - " & s & n
Else
n = " [" & rHostName & "]"
Form1.Caption = "WinSock - " & s & n
End If
End If
Next i
End Sub
Private Function stateToString(state As Long) As String
Dim s As String
Select Case state
Case 0: s = "Connection closed"
Case 1: s = "Connection open"
Case 2: s = "Listening"
Case 3: s = "Connection pending"
Case 4: s = "Resolving host"
Case 5: s = "Host resolved"
Case 6: s = "Connecting"
Case 7: s = "Connected"
Case 8: s = "Closing"
Case 9: s = "Error"
Case Else: s = "ERROR: Socket-state unknown"
End Select
stateToString = s
End Function
Private Sub Winsock1_Close(index As Integer)
On Error GoTo Hell
Dim i As Long
If (iAmServer) Then
If (index = ROOTSOCKET) Then
addLine "ERROR: Someone accessed Server-ROOTSOCKET: " & _
Winsock1(index).RemoteHostIP
Else
addLine "Connection closed by client " & Winsock1(index).RemoteHostIP
i = index
If (Len(Winsock1(index).Tag) > 0) Then
sendToAll ">>> " & Winsock1(index).Tag & " has left <<<", i
End If
DoEvents
If (index = clientCount) Then
Winsock1(index).Close
Unload Winsock1(index)
clientCount = clientCount - 1
Else
' closing the client will leave a gap
' -> move last client to this gap
' --> clientCount is consistent
Winsock1(index).Close
Winsock1(index).Tag = "__FREE__"
End If
End If
Else
Winsock1(index).Close
addLine "Connection closed by remote host."
End If
Exit Sub
Hell:
errorHandler "Error while closing connection to " & _
Winsock1(index).RemoteHostIP
End Sub
Private Sub Winsock1_DataArrival(index As Integer, ByVal bytesTotal As Long)
On Error GoTo Hell
Dim s As String
Dim i As Long
i = index
Winsock1(index).GetData s, vbString
If (iAmServer) Then
If (index > maxClients) Then Exit Sub
addLine Winsock1(index).Tag & ": " & s
If (Left$(s, 9) = "nickName=") Then
Dim oldNickName As String
Dim newNickName As String
oldNickName = Winsock1(index).Tag
If (oldNickName = "__FREE__") Then
oldNickName = ""
End If
newNickName = Right$(s, Len(s) - 9)
If (Len(newNickName) > 2) Then
If (nickIsValid(newNickName)) Then
Winsock1(index).Tag = newNickName
If (oldNickName = "") Then
s = ">>> " & newNickName & " has joined <<<"
Dim welcomeText As String
welcomeText = ">>> Wellcome to WinSock V.0.2 <<<" _
& vbNewLine _
& createClientNameList
Winsock1(index).SendData welcomeText
DoEvents
Else
s = ">>> " & oldNickName & " has renamed to " _
& newNickName & " <<<"
Winsock1(index).SendData ">>> Your new nickName is " _
& newNickName & " <<<"
DoEvents
End If
Else
Winsock1(index).SendData ">>> Bad nickName. " & _
"Name is allready in use. <<<" & vbNewLine _
& ">>> Connect again with different nickName. <<<"
DoEvents
Winsock1_Close index
Exit Sub
End If
Else
Winsock1(index).SendData ">>> Bad nickName. " & _
"At last 3 characters required. <<<"
DoEvents
Exit Sub
End If
ElseIf (Left$(s, 9) = "listNames") Then
Dim names As String
names = createClientNameList
Winsock1(index).SendData names
DoEvents
Exit Sub
Else
s = Winsock1(index).Tag & ": " & s
End If
sendToAll s, i
Else
If (InStr(s, "No more Clients allowed. Goodbey") > 0) Then
serverIsFull = True
End If
addLine s
End If
DoEvents
Exit Sub
Hell:
errorHandler "Error while receiving data from " & _
Winsock1(index).RemoteHostIP
End Sub
Private Function nickIsValid(nick As String) As Boolean
Dim i As Long
For i = 1 To clientCount
If (nick = Winsock1(i).Tag) Then
nickIsValid = False
Exit Function
End If
Next i
nickIsValid = True
End Function
Private Sub sendToAll(text As String, sender As Long)
Dim i As Long
For i = 1 To clientCount
If (i <> sender) Then
If (Winsock1(i).Tag <> "__FREE__") Then
If (Winsock1(i).state = sckConnected) Then
Winsock1(i).SendData text
DoEvents
Else
addLine "ERROR: Cannot send message to" & _
"client " & Winsock1(i).RemoteHostIP
End If
End If
End If
Next i
End Sub
Private Function createClientNameList() As String
Dim i As Long
Dim res As String
Dim counter As Long
res = "List of online Clients:" & vbNewLine
For i = 1 To clientCount
If (Winsock1(i).Tag <> "__FREE__") Then
counter = counter + 1
res = res & Format(counter, "00") & _
". " & Winsock1(i).Tag & vbNewLine
End If
Next i
createClientNameList = res
End Function
Private Sub Winsock1_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)
Err.Number = Number
Err.Description = Description
errorHandler "Socket Error"
End Sub
Private Sub addLine(s As String)
addText s & vbNewLine
End Sub
Private Sub addText(s As String)
If (Len(Text4.text) > 25000) Then
Text4.text = ">>> Reset output-text. Too much text. <<<" & vbNewLine
End If
Text4.text = Text4.text & s
Text4.SelStart = Len(Text4.text)
End Sub
Public Sub errorHandler(errText As String)
Dim displayText As String
displayText = errText & vbNewLine & _
"Error Nr.: " & Err.Number & vbNewLine & _
"Last Dll Error: " & Err.LastDllError & vbNewLine & vbNewLine & _
Err.Description & vbNewLine & vbNewLine & _
"Help:" & vbNewLine & _
WinSockErrorCodes.getTextFromErrorNr(Err.Number)
MsgBox displayText, vbExclamation, "WinSock"
If Not (iAmServer) Then
Winsock1(CLIENT).Close
End If
addLine Err.Description
Err.Clear
End Sub