usermod.bas

这是一个用vb 写的聊天室

Attribute VB_Name = "UserMod"
Global OldText
Global SignOff As Integer
Global LastSend


Public Sub ParseRecv(Getrecv As Variant)
' There is a lot to comment, im going to keep it short and simple
On Error GoTo skipit ' if there isnt a ":" in the txt forget the error, go on
  Dim RecvCmd As Variant
    RecvCmd = Split(Getrecv, ":", , vbTextCompare)  ' Split the recived text so its easier to work with
skipit:
    '.: Send the server login information :.
    If Getrecv = "welcome" Then ' Server oks the connection
            frmLogin.sockUser.SendData "Login:" & frmLogin.txtName.Text & ":" & frmLogin.txtPass.Text   ' Send the server my pass and login
            Exit Sub
    End If
    
    If RecvCmd(0) = "NoCrypt" Then  ' Turn the encryption off
       Dim frmNoCrypt As Form
        For Each frmNoCrypt In Forms                                ' find the right form
            If LCase(frmNoCrypt.Tag) = LCase(RecvCmd(1)) Then       ' found it
                frmNoCrypt.txtEncCode.Text = ""                     ' turn it off
                frmNoCrypt.rtxtRecv.SelStart = Len(frmNoCrypt.rtxtRecv.Text)
                frmNoCrypt.rtxtRecv.SelColor = QBColor(2)
                frmNoCrypt.rtxtRecv.SelBold = True
                If frmNoCrypt.rtxtRecv.Text = "" Then
                    frmNoCrypt.rtxtRecv.SelText = "*** Encryption Turned Off" ' let em know its now off
                Else
                    frmNoCrypt.rtxtRecv.SelText = vbCrLf & "*** Encryption Turned Off"  ' same
                End If
                frmNoCrypt.rtxtRecv.SelStart = Len(frmNoCrypt.rtxtRecv.Text)    ' Set the start back to the end of the txt
                Exit For
            End If
        Next frmNoCrypt
    End If
    
    If RecvCmd(0) = "Cryption" Then     ' Same as above except turn encryption on
       Dim frmCrypt As Form
        For Each frmCrypt In Forms
            If LCase(frmCrypt.Tag) = LCase(RecvCmd(1)) Then
                frmCrypt.txtEncCode.Text = RecvCmd(2)
                frmCrypt.rtxtRecv.SelStart = Len(frmCrypt.rtxtRecv.Text)
                frmCrypt.rtxtRecv.SelColor = QBColor(2)
                frmCrypt.rtxtRecv.SelBold = True
                If frmCrypt.rtxtRecv.Text = "" Then
                    frmCrypt.rtxtRecv.SelText = "*** Encryption Turned On"
                Else
                    frmCrypt.rtxtRecv.SelText = vbCrLf & "*** Encryption Turned On"
                End If
                frmCrypt.rtxtRecv.SelStart = Len(frmCrypt.rtxtRecv.Text)
                Exit For
            End If
        Next frmCrypt
    End If
        
    If RecvCmd(0) = "CloseWin" Then     ' A user closed their chat window with you
      Dim frmChat As Form
        For Each frmChat In Forms
            If LCase(frmChat.Tag) = LCase(RecvCmd(1)) Then      ' find the right form
                frmChat.rtxtRecv.SelStart = Len(frmChat.rtxtRecv.Text)
                frmChat.rtxtRecv.SelColor = QBColor(2)
                frmChat.rtxtRecv.SelBold = True
                If frmChat.rtxtRecv.Text = "" Then
                    frmChat.rtxtRecv.SelText = "*** " & RecvCmd(1) & " has closed his chat window with you!"    ' let the user know
                Else
                    frmChat.rtxtRecv.SelText = vbCrLf & "*** " & RecvCmd(1) & " has closed his chat window with you!" ' same
                End If
                frmChat.rtxtRecv.SelStart = Len(frmChat.rtxtRecv.Text)
                Exit For
            End If
        Next frmChat
    End If
    
    If Mid(Getrecv, 1, 7) = "Message" Then      ' User sends you a message
      Dim frm As Form
      Dim FoundChat, RecvCmd2
        FoundChat = 0
        RecvCmd2 = Split(Getrecv, "~~")         ' Split it, used "~~" to make less chance for error
        For Each frm In Forms                   ' check each form for right user
            If LCase(frm.Tag) = LCase(RecvCmd2(2)) Then
              If frm.txtEncCode.Text = "" Then
                Call AddMessage(frm, RecvCmd2(2), RecvCmd2(3))  ' Sends the message to the window
              Else
                Call AddMessage(frm, RecvCmd2(2), Decrypt(RecvCmd2(3), frm.txtEncCode.Text)) ' Decrypts then send the msg to the window
              End If
                FoundChat = 1
            End If
        Next frm
        
        If FoundChat = 0 Then                   ' A new user sends you a message, load a new window
            Dim myForm As New Chat
            Load myForm
            myForm.fraText.Top = myForm.fraText.Top + 1450
            myForm.rtxtSend.Top = myForm.rtxtSend.Top + 1450
            myForm.fraCommand.Top = myForm.fraCommand.Top + 1450
            myForm.rtxtRecv.Top = 125
            myForm.rtxtRecv.Left = 0
            myForm.Height = 5025
            myForm.lblTo.Visible = False
            myForm.cboUsers.Visible = False
            myForm.rtxtRecv.Visible = True
            myForm.Caption = "Amojeba Message from: " & RecvCmd2(2)
            myForm.Tag = RecvCmd2(2)
            myForm.Visible = True
            Call AddMessage(myForm, RecvCmd2(2), RecvCmd2(3))   ' Then add the message (first time chat can never be encrypted)
        End If
        Exit Sub
    End If
    
    If Getrecv = "CloseConn" Then                   ' Server closed the connection
      Dim CloseFrm As Form
        For Each CloseFrm In Forms
            If CloseFrm.Name = "frmLogin" Then
                frmLogin.Show
            Else
                Unload CloseFrm
            End If
        Next CloseFrm
    End If
    
    If Getrecv = "GoodLogin" Then                   ' Login and pass were correct
        frmLogin.sockUser.SendData "GetUsers:" & frmLogin.txtName.Text  ' Get the online user list
        frmLogin.Hide
        frmFriends.Show
        Exit Sub
    End If
    
    If Mid(Getrecv, 1, 7) = "AddUser" Then          ' New user connected, make sure he gets on your list too
     Dim frmAdd As Form
        frmFriends.lstUsers.AddItem Mid(Getrecv, 9)
        Call DelLstDup(frmFriends.lstUsers)
        For Each frmAdd In Forms
            If LCase(frmAdd.Tag) = LCase(Getrecv) Then
                frmAdd.rtxtRecv.SelStart = Len(frmAdd.rtxtRecv.Text)
                frmAdd.rtxtRecv.SelColor = QBColor(2)
                frmAdd.rtxtRecv.SelBold = True
                If frmAdd.rtxtRecv.Text = "" Then
                    frmAdd.rtxtRecv.SelText = "*** " & Getrecv & " has connected."
                Else
                    frmAdd.rtxtRecv.SelText = vbCrLf & "*** " & Getrecv & " has connected."
                End If
                frmAdd.rtxtRecv.SelStart = Len(frmAdd.rtxtRecv.Text)
                frmAdd.rtxtSend.Enabled = True
            End If
        Next frmAdd
    End If
    
    If Mid(Getrecv, 1, 8) = "UserList" Then         ' Got the online user list, add it to the users window
        Dim OtherUsrs As Variant, Person As Variant
        OtherUsrs = Mid(Getrecv, 10)
        If InStr(1, Getrecv, " ", vbTextCompare) Then
            OtherUsrs = Split(OtherUsrs, " ")
            frmFriends.lstUsers.Clear
            For Each Person In OtherUsrs
                frmFriends.lstUsers.AddItem Person
            Next Person
            frmLogin.sockUser.SendData "UsersDone:" & frmLogin.txtName.Text
            Call DelLstDup(frmFriends.lstUsers)
        Else
            frmFriends.lstUsers.AddItem Mid(Getrecv, 10)
            Call DelLstDup(frmFriends.lstUsers)
        End If
    End If
    
    If Mid(Getrecv, 1, 8) = "UserRemv" Then         ' Somebody signed off, take em out of your list
        Dim Who As String, Users As Integer, frms As Form
        Who = Mid(Getrecv, 10)
        For Users = 0 To frmFriends.lstUsers.ListCount - 1
          Dim lstPerson As String
            lstPerson = frmFriends.lstUsers.List(Users)
            If lstPerson = Who Then
                frmFriends.lstUsers.RemoveItem (Users)
                Exit For
            End If
        Next Users
        
        For Each frms In Forms
            If LCase(frms.Tag) = LCase(Who) Then
                frms.rtxtRecv.SelStart = Len(frms.rtxtRecv.Text)
                frms.rtxtRecv.SelColor = QBColor(2)
                frms.rtxtRecv.SelBold = True
                If frms.rtxtRecv.Text = "" Then
                    frms.rtxtRecv.SelText = "*** " & Who & " has disconnected."
                Else
                    frms.rtxtRecv.SelText = vbCrLf & "*** " & Who & " has disconnected."
                End If
                frms.rtxtRecv.SelStart = Len(frms.rtxtRecv.Text)
                frms.rtxtSend.Enabled = False
            End If
        Next frms
        Exit Sub
    End If
    
    If Getrecv = "BadLogin" Then                ' Something was incorrect with your login, fix it
        MsgBox "Sorry, your login was incorrect please contact your admin!"
        frmLogin.txtName.Text = ""
        frmLogin.txtPass.Text = ""
        frmLogin.txtName.SetFocus
        Exit Sub
    End If
End Sub

Public Sub AddMessage(frmName As Variant, FromWho As Variant, Message As Variant)
    ' *** Makes it so i dont have to type this every single time i get a message, easier to call and less typing(code)
    frmName.rtxtRecv.SelStart = Len(frmName.rtxtRecv.Text)
    If LCase(FromWho) = LCase(frmLogin.txtName.Text) Then
        frmName.rtxtRecv.SelColor = QBColor(2)
    Else
        frmName.rtxtRecv.SelColor = QBColor(1)
    End If
    frmName.rtxtRecv.SelBold = True
    If frmName.rtxtRecv.Text = "" Then
        frmName.rtxtRecv.SelText = FromWho & ":"
    Else
        frmName.rtxtRecv.SelText = vbCrLf & FromWho & ":"
    End If
    
    frmName.rtxtRecv.SelStart = Len(frmName.rtxtRecv.Text)
    frmName.rtxtRecv.SelColor = QBColor(0)
    frmName.rtxtRecv.SelBold = False
    frmName.rtxtRecv.SelText = vbTab & Message
    frmName.rtxtRecv.SelStart = Len(frmName.rtxtRecv.Text)
End Sub

Public Sub DelLstDup(listBox As listBox)
' *** Removes any dupes incase server makes a mistake
    Dim A%, B%
    For A% = 0 To listBox.ListCount - 1
        For B% = 0 To listBox.ListCount - 1
            If B% <> A% Then
                If listBox.List(A%) = listBox.List(B%) Then
                    listBox.RemoveItem B%
                    B% = B% - 1
                End If
            End If
        Next B%
    Next A%
End Sub