frmserver.frm

这是一个用vb 写的聊天室

Else
    MsgBox "No user to kill", vbOKOnly, "Kill User"
End If
End Sub


Private Sub cmdOffline_Click()
frmServer.Caption = "Server [Offline]"
'** Turn controls on and off ****************************
lstUsers.Enabled = False
lstUsers.Clear
cmdOffline.Enabled = False
cmdOnline.Enabled = True
'********************************************************
Call CloseAllConn                       'Close the socket (nobody can connect)
txtHistory = txtHistory & vbCrLf & "### " & " Server closed"
End Sub


Private Sub cmdOnline_Click()
frmServer.Caption = "Server [Online]"   'Change the caption
'** Turn controls on and off ****************************
lstUsers.Enabled = True
lstUsers.Clear
cmdOnline.Enabled = False
cmdOffline.Enabled = True
'********************************************************
intMax = 1
sockServer(0).Listen                       'Have the socket listen for connections
txtHistory = txtHistory & vbCrLf & "### " & " Server turned online"
End Sub

Private Sub cmdRemUsr_Click()
    frmOptions.Show
End Sub

Private Sub Form_Load()
intMax = 1                              'Sets the sock number
sockServer(0).LocalPort = 9456           'Sets the local port for the first sock
sockServer(0).Listen                     'Turns the server online
lstUsers.Clear                          'Clear the users online box
frmServer.Caption = "Server [Online]"   'Change the caption
'** Set the info box ************************************
lblHost.Caption = "Host: " & sockServer(0).LocalHostName
lblIP.Caption = "IP Address: " & sockServer(0).LocalIP
lblPort.Caption = "Server Port: " & sockServer(0).LocalPort
'********************************************************
EncCode = "AcKhTTaSBtCC"                'Sets the encryption code VERY VERY IMPORTANT
Load frmUsrNFO
txtHistory = txtHistory & vbCrLf & "### " & " Server loaded"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload frmUsrNFO
    Unload frmServer
End Sub

Private Sub sockServer_Close(Index As Integer)
    Unload sockServer(Index)
     Dim DelUsr
        For DelUsr = 0 To frmServer.lstUsers.ListCount - 1
          Dim DIndex As Integer, lstDelUsr, DWho As String
            lstDelUsr = frmServer.lstUsers.List(DelUsr)
            lstDelUsr = Split(lstDelUsr, "/")
            DWho = lstDelUsr(0)
            DIndex = lstDelUsr(1)
            If LCase(Index) = LCase(DIndex) Then
                txtHistory = txtHistory & vbCrLf & "*** " & DWho & " just signed off"
                frmServer.lstUsers.RemoveItem DelUsr
                Exit Sub
            End If
        Next DelUsr
End Sub

Private Sub sockServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
   If Index = 0 Then
        intMax = intMax + 1                                     'Increases the user count
        Load sockServer(intMax)                                 'Loads a new socket
        sockServer(intMax).LocalPort = 0                        'Sets a random port to listen to
        sockServer(intMax).Accept requestID                     'Accept the user
        sockServer(intMax).SendData "welcome" & Chr(10)         'Tell the user that they are connected
   End If
End Sub

Private Sub sockServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim GetRecv As String, RecvCmd, GetCmd As String, GetStuff As String
sockServer(Index).GetData GetRecv, vbString
txtDebug.Text = GetRecv
If InStr(1, GetRecv, ":", vbTextCompare) Then
    RecvCmd = Split(GetRecv, ":", , vbTextCompare)      'Split the data thats recieved
    GetCmd = RecvCmd(0)                                 'Set the command for faster reference
    GetStuff = RecvCmd(1)                               'Set the data for faster reference
End If
    If GetCmd = "Login" Then                        'Check to see if they are logging in
     Dim LoginName As String, LoginPass As String
     Dim GetResults As Integer
        LoginName = GetStuff                        'Set the login name
        LoginPass = RecvCmd(2)                      'Set the password
        Call UserLogin(LoginName, LoginPass, Index)
    End If
    
    If GetCmd = "Cryption" Then
     Dim EncCode, CryptUsr As Variant, CryptUsr1
        EncCode = Date & Hour(Time) * 4 & Minute(Time) * 6
        For CryptUsr = 0 To frmServer.lstUsers.ListCount - 1
          Dim lstcryptusr, TIndex3 As Integer, Who3 As String
            CryptUsr1 = frmServer.lstUsers.List(CryptUsr)
            CryptUsr1 = Split(CryptUsr1, "/")
            TIndex3 = CryptUsr1(1)
            Who3 = CryptUsr1(0)
            If LCase(GetStuff) = LCase(Who3) Then
                Call Pause(300)
                frmServer.sockServer(TIndex3).SendData "Cryption:" & RecvCmd(2) & ":" & EncCode & Chr(10)
                Call Pause(300)
                frmServer.sockServer(Index).SendData "Cryption:" & RecvCmd(1) & ":" & EncCode & Chr(10)
                Exit For
            End If
        Next CryptUsr
    End If
    
    If GetCmd = "NoCrypt" Then
     Dim NoCryptUsr As Variant, NoCryptUsr1
        For NoCryptUsr = 0 To frmServer.lstUsers.ListCount - 1
          Dim lstnocryptusr, TIndex4 As Integer, Who4 As String
            NoCryptUsr1 = frmServer.lstUsers.List(NoCryptUsr)
            NoCryptUsr1 = Split(NoCryptUsr1, "/")
            TIndex4 = NoCryptUsr1(1)
            Who4 = NoCryptUsr1(0)
            If LCase(GetStuff) = LCase(Who4) Then
                Call Pause(300)
                frmServer.sockServer(TIndex4).SendData "NoCrypt:" & RecvCmd(2) & ":Off" & Chr(10)
                Call Pause(300)
                frmServer.sockServer(Index).SendData "NoCrypt:" & RecvCmd(1) & ":Off" & Chr(10)
                Exit For
            End If
        Next NoCryptUsr
    End If
    
    If GetCmd = "CloseWin" Then
     Dim CloseUsr
        For CloseUsr = 0 To frmServer.lstUsers.ListCount - 1
          Dim lstCloseUsr, TIndex2 As Integer, Who2 As String
            lstCloseUsr = frmServer.lstUsers.List(CloseUsr)
            lstCloseUsr = Split(lstCloseUsr, "/")
            TIndex2 = lstCloseUsr(1)
            Who2 = lstCloseUsr(0)
            If LCase(GetStuff) = LCase(Who2) Then
                Call Pause(900)
                frmServer.sockServer(TIndex2).SendData "CloseWin:" & RecvCmd(2) & Chr(10)
            End If
        Next CloseUsr
    End If
    
    If GetCmd = "GetUsers" Then
        Call Sendusers(Index, GetStuff)
    End If
    
    If GetCmd = "SignOff" Then
      Dim users As Integer, lstPerson As Variant
      Dim Who As String, TIndex As Integer
        For users = 0 To frmServer.lstUsers.ListCount - 1
            lstPerson = frmServer.lstUsers.List(users)
            lstPerson = Split(lstPerson, "/")
            TIndex = lstPerson(1)
            Who = lstPerson(0)
            If LCase(GetStuff) = LCase(Who) Then
            Else
                Call Pause(900)
                frmServer.sockServer(TIndex).SendData "UserRemv:" & GetStuff & Chr(10)
            End If
        Next users
        
        For users = 0 To frmServer.lstUsers.ListCount - 1
            lstPerson = frmServer.lstUsers.List(users)
            lstPerson = Split(lstPerson, "/")
            TIndex = lstPerson(1)
            Who = lstPerson(0)
            If LCase(GetStuff) = LCase(Who) Then
                frmServer.lstUsers.RemoveItem (users)
                txtHistory = txtHistory & vbCrLf & "*** " & Who & " just signed off"
                Exit For
            End If
        Next users
    End If
    
    If GetCmd = "UsersDone" Then
        Call UpdateAllUsers(GetStuff)
    End If
    
    If Mid(GetRecv, 1, 7) = "Message" Then
      Dim RecvCmd2
      RecvCmd2 = Split(GetRecv, "~~")
        For users = 0 To frmServer.lstUsers.ListCount - 1
            lstPerson = frmServer.lstUsers.List(users)
            lstPerson = Split(lstPerson, "/")
            If LCase(lstPerson(0)) = LCase(RecvCmd2(1)) Then
                sockServer(lstPerson(1)).SendData "Message~~" & RecvCmd2(1) & "~~" & RecvCmd2(2) & "~~" & RecvCmd2(3) & Chr(10)
                txtHistory = txtHistory & vbCrLf & "--- Message from " & RecvCmd2(2) & " to " & lstPerson(0) & ": " & RecvCmd2(3)
            End If
        Next users
    End If
End Sub

Private Sub sockServer_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)
    txtHistory = txtHistory & vbCrLf & "\\\ Error (" & Number & ") Description: " & Description
    CancelDisplay = True
End Sub

Private Sub Timer1_Timer()
If lstUsers.ListCount >= 1 Then
    cmdKick.Enabled = True
Else
    cmdKick.Enabled = False
End If
End Sub

Private Sub txtHistory_Change()
  If Mid(txtHistory, 1, 2) = vbCrLf Then
    txtHistory = Mid(txtHistory, 3)
  End If
    txtHistory.SelStart = Len(txtHistory)
End Sub

Private Sub txtHistory_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
      Dim YesorNo As Variant
        YesorNo = MsgBox("Would you like to clear the log window?", vbYesNo, "Clear Log Window")
        If YesorNo = vbYes Then
            txtHistory = ""
        End If
    End If
End Sub