modserver.bas

这是一个用vb 写的聊天室

Attribute VB_Name = "modServer"
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Public intMax As Long
Public EncCode  As String


Public Sub CloseAllConn()
Dim OnCount As Long
On Error Resume Next                                                'If an error occurs try the next one
    For OnCount = 0 To intMax                                       'Tells the comp how many sockets to check
        If frmServer.sockServer(OnCount).State <> sckClosed Then    'If the socket is open close it
            frmServer.sockServer(OnCount).Close                     '""
        End If
    Next OnCount                                                    'Try the next socket
    intMax = 0                                                      'Sets everything back to start
End Sub

Public Sub UserLogin(Who As String, Passwd As String, Index As Integer)
Dim FindLogin As Integer, Goodpwd As Integer, EncPasswd As String
FindLogin = 0                                                       'Sets a var to see if the person is found
Goodpwd = 0                                                         'Sets a var to see if the pass is correct
      frmUsrNFO.dtaUsrNfo.Recordset.MoveFirst                       'Sets the database to the start
        Do: DoEvents                                                '*** Start Checking
            RC4ini ("AcKhTTaSBtCC")                                 '  The en/decrypt password
            EncPasswd = EnDeCrypt(frmUsrNFO.txtPass)                '  Decrypt the password in the DB
            If LCase(Who) = LCase(frmUsrNFO.txtLogin) Then          '  Check to see if they match
                FindLogin = 1                                       '  They do.. set the var to let the comp remember
                If EncPasswd = Passwd Then                          '  Check to see if the passwords match
                    Goodpwd = 1                                     '  Yup, they do
                        With frmUsrNFO.dtaUsrNfo.Recordset          '  Update the users status to online
                            .Edit                                   '     Tell the db to go into edit mode
                            !Status = "Online"                      '     Actually edit the db
                            .Update                                 '     Save it
                        End With
                    Exit Do
                End If
            End If
            frmUsrNFO.dtaUsrNfo.Recordset.MoveNext                  '  If there arnt any matches try the next person
        Loop Until frmUsrNFO.dtaUsrNfo.Recordset.EOF                '***  All done with the list
    If Goodpwd = 1 And FindLogin = 1 Then                           'Checks to see if the user was found and if the password was correct
        frmServer.sockServer(Index).SendData "GoodLogin" & Chr(10)  'Everything good, tell the client that
        frmServer.lstUsers.AddItem Who & "/" & Index                'Add that person to the listbox of online users
        frmServer.txtHistory = frmServer.txtHistory & vbCrLf & "*** " & Who & " just signed on"
    Else
        frmServer.sockServer(Index).SendData "BadLogin" & Chr(10)   'User messed up loggin in or was not found, tell them that
    End If
End Sub

Public Sub UpdateAllUsers(Skip As String)
Dim users As Integer, lstPerson As Variant
    For users = 0 To frmServer.lstUsers.ListCount - 1
        Dim Who As String, TIndex As Integer
        lstPerson = frmServer.lstUsers.List(users)
        lstPerson = Split(lstPerson, "/")
        TIndex = lstPerson(1)
        Who = lstPerson(0)
        Call Pause(900)
        frmServer.sockServer(TIndex).SendData "AddUser:" & Skip & Chr(10)
    Next users
End Sub

Public Sub Pause(lngInterval As Long)
 Dim lngEnd As Long, lngNow As Long
    lngEnd = GetTickCount()
    lngEnd = Count1 + lngInterval
    Do: DoEvents
        lngNow = GetTickCount()
    Loop Until lngNow >= lngEnd
End Sub

Public Sub FindUsrStatus(OnList As String, Index As Integer)
Dim TempOnline As String, TmpOnlist As Variant, Person As Variant, RealOnline As String
TempOnline = ""                                                             'A var to store all the usrs online
RealOnline = ""                                                             'Stores all the users online the user wants
    frmUsrNFO.dtaUsrNfo.Recordset.MoveFirst                                 'Goes to the first record to start its search
        Do: DoEvents
            If LCase(frmUsrNFO.txtStatus) = "online" Then                   'Checks to see if the user is online
                TempOnline = TempOnline & " " & frmUsrNFO.txtLogin          'User is online, add him to the list
            End If
            frmUsrNFO.dtaUsrNfo.Recordset.MoveNext                          'Check the rest of the users to see who is online
        Loop Until frmUsrNFO.dtaUsrNfo.Recordset.EOF                        '""
    TmpOnlist = Split(OnList, ":")                                          'User wants us to check to see if their friends are online, split their list
    For Each Person In TmpOnlist                                            'Start checking
        If InStr(1, LCase(TempOnline), LCase(Person), vbTextCompare) Then   'If the user checking is in the list
            If RealOnline = "" Then                                         '
                RealOnline = Person                                         '
            Else                                                            '   Add'em
                RealOnline = RealOnline & ":" & Person                      '
            End If                                                          '
        End If
    Next Person                                                             'Check the next person for the user
    MsgBox RealOnline
End Sub

Public Sub Sendusers(Index As Integer, Who As String)
Dim users As Integer
Dim UsrList As String
UsrList = ""
    For users = 0 To frmServer.lstUsers.ListCount - 1
      Dim lstPerson As Variant
        lstPerson = frmServer.lstUsers.List(users)
        lstPerson = Split(lstPerson, "/")
        lstPerson = lstPerson(0)
          If UsrList = "" Then
              UsrList = lstPerson
          Else
              UsrList = UsrList & " " & lstPerson
          End If
    Next users
    frmServer.sockServer(Index).SendData "UserList:" & UsrList & Chr(10)
End Sub