form1.frm

Com串口即时通讯工具.有服务端和客启端..是学习的好程度!

    '接收文件
    Case ".RecieveFile"
        RecieveFile UserCommand, Index
    '取得实时聊天的IP地址
    Case ".GetIPForRTChat"
        GetIPForRTChat UserCommand, Index
    '开始实时聊天
    Case ".BeginRTChat"
        BeginRTChat UserCommand, Index
    '中断实时聊天
    Case ".CancelRTChat"
        CancelRTChat UserCommand, Index
    '保存用户信息
    Case ".SaveInfo"
        SaveInfo UserCommand, Index
    '取得好友信息
    Case ".GetBuddyInfo"
        GetBuddyInfo UserCommand, Index
    '报告
    Case ".Report"
        Report UserCommand, Index
    '修改密码
    Case ".ChangePassword"
        Password UserCommand, Index
    '添加黑名单
    Case ".AddIgnore"
        AddIgnore UserCommand, Index
    '删除黑名单
    Case ".RemoveIgnore"
        RemoveIgnore UserCommand, Index
    '取得黑名单列表
    Case ".GetIgnoreList"
        GetIgnoreList UserCommand, Index
    '其它
    Case Else
        ServiceSocket(Index).SendData ".ServerMessage Err: Command not recognized."
End Select
End Sub

'=============
'SOCKET错误处理
'==============
Private Sub ServiceSocket_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)

   RichTextBox1.SelColor = vbRed
   RichTextBox1.SelText = Now & ": 错误 #" & Number & ", " & Description & ", from " & ServiceSocket(intMax).RemoteHostIP & vbCrLf
   RichTextBox1.SelColor = vbBlack
   
   TotalUsersOnline = TotalUsersOnline - 1
   UserInfo(Index).InUse = False
   UserInfo(Index).InRoom = ""
   UserInfo(Index).NickColor = ""
   UserInfo(Index).Nickname = ""
   UserInfo(Index).Password = ""
   UserInfo(Index).Status = ""
   UserInfo(Index).UserID = "N/A"
   UserInfo(Index).UserName = ""
   UserInfo(Index).UserIP = ""

   ServiceSocket_Close Index

End Sub

'====================
'取得空闲的SOCKET序号
'====================
Sub GetFreeWinsockIndex()
    For LastConnection = ServiceSocket.LBound To ServiceSocket.UBound
        If ServiceSocket(LastConnection).State = sckClosed Then Exit Sub
    Next
    Load ServiceSocket(LastConnection)
End Sub

'==================
'启动
'==================
Public Function LogIn(UserCommand As String, Index As Integer)
    If InStr(1, Word(UserCommand, 4), "Yes") Then
        If InStr(1, Word(UserCommand, 2), "N/A") Then
            ServiceSocket(Index).SendData ".LoginBad 6"
            Exit Function
        End If
        Dim UserCount As Integer
        
        '读用户数
        UserCount = Val(LoadINI("Count", "UserCount", "TotalUsers"))
        '读用户信息
        Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
        For a = 1 To UserCount
            Get #gFileNum, a, SavedUserInfo
            If UCase(Trim(SavedUserInfo.UserID)) = UCase(Word(UserCommand, 2)) Then
                RichTextBox1.SelText = Now & ": User " & Word(UserCommand, 2) & " failed to create account: " & "This account already exists." & vbCrLf
                ServiceSocket(Index).SendData ".LoginBad 6"
                Close #gFileNum
                Exit Function
            End If
        Next a
        Close #gFileNum
        UserCount = UserCount + 1
        '保存用户数
        SaveINI "Count", "UserCount", "TotalUsers", Str(UserCount)
        '保存用户信息
        SavedUserInfo.UserID = Word(UserCommand, 2)
        SavedUserInfo.Password = Word(UserCommand, 3)
        SavedUserInfo.Nickname = Word(UserCommand, 2)
        SavedUserInfo.LastUserIP = ServiceSocket(Index).RemoteHostIP
        Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
            Put #gFileNum, UserCount, SavedUserInfo
        Close #gFileNum
        UserPersonalInfo.Sex = "N/A"
        UserPersonalInfo.Country = "N/A"
        UserPersonalInfo.BirthDay = "N/A"
        UserPersonalInfo.Age = "N/A"
        UserPersonalInfo.Webpage = "N/A"
        UserPersonalInfo.About = "N/A"
        Open Word(UserCommand, 2) & ".dat" For Random As gFileNum Len = Len(UserPersonalInfo)
            Put #gFileNum, 1, UserPersonalInfo
        Close #gFileNum
        RichTextBox1.SelText = Now & ": New User " & Word(UserCommand, 2) & vbCrLf
    End If
    UserCount = Val(LoadINI("Count", "UserCount", "TotalUsers"))
    Dim LogName As String
    Dim LogCount As Integer
    Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
        For a = 1 To UserCount
            Get #gFileNum, a, SavedUserInfo
            If Trim(SavedUserInfo.UserID) = Word(UserCommand, 2) Then
                LogName = "Good"
                LogCount = a
                Exit For
            End If
        Next a
    Close #gFileNum
    If Not LogName = "Good" Then
        RichTextBox1.SelText = Now & ": User " & Word(UserCommand, 2) & " failed to login: " & "account couldn't be found." & vbCrLf
        ServiceSocket(Index).SendData ".LoginBad 0"
        Exit Function
    End If
    Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
        Get #gFileNum, LogCount, SavedUserInfo
        If Trim(SavedUserInfo.Password) = Word(UserCommand, 3) Then
            ServiceSocket(Index).SendData ".LoginGood"
            RichTextBox1.SelColor = &H80FF&
            RichTextBox1.SelText = Now & ": User " & Word(UserCommand, 2) & " logged in from " & ServiceSocket(intMax).RemoteHostIP & vbCrLf
            RichTextBox1.SelColor = vbBlack
            For a = 0 To List1.ListCount - 1
                If List1.ItemData(a) = Index Then List1.List(a) = "(" & Index & ")" & Word(UserCommand, 2)
            Next
            UserInfo(Index).Nickname = Word(UserCommand, 2)
            UserInfo(Index).UserID = Word(UserCommand, 2)
            UserInfo(Index).Status = "Online"
            UserInfo(Index).InUse = True
            UserInfo(Index).UserIP = ServiceSocket(Index).RemoteHostIP
            SavedUserInfo.LastUserIP = ServiceSocket(Index).RemoteHostIP
            Put #gFileNum, LogCount, SavedUserInfo
        Else
            RichTextBox1.SelText = Now & ": User " & Word(UserCommand, 2) & " failed to login: " & "wrong password" & vbCrLf
            ServiceSocket(Index).SendData ".LoginBad 1"
        End If
    Close #gFileNum
End Function

'==============
'取得好友表列过程
'===============
Public Function GetBuddys(UserCommand As String, Index As Integer)
    On Error Resume Next
    Dim BuddyCount As Integer
    Dim BuddyUserID As String
    Dim BuddyUserFound As Boolean
    Dim BuddyUserTitle As String
    
    '取得该用户的好友总数
    BuddyCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "BuddyList"))
    Dim g As Integer
    Dim Temp3 As Integer
    If BuddyCount > 0 Then
        '如果好友数大于0，逐个显示好友信息
        For a = 1 To BuddyCount
            If ServiceSocket(Index).State = 7 Then
                Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
                    Get #gFileNum, a, Buddy
                    BuddyUserID = Trim(Buddy)
                    BuddyUserTitle = Trim(Buddy)
                Close #gFileNum
                DoEvents
                '如果好友数超过最大好友数限制，将temp3置为好友数
                If BuddyCount > intMax Then
                    Temp3 = BuddyCount
                Else
                    Temp3 = intMax
                End If
                    For u = 0 To intMax
                        '取得好友信息
                        BuddyUserFound = False
                        Dim Temp4 As String
                        If UserInfo(u).UserID = "" Then
                            Temp4 = "N/A"
                        Else
                            Temp4 = UserInfo(u).UserID
                        End If
                        If BuddyUserID = Temp4 Then
                            If Not Word(UserInfo(u).UserID, 1) = Word(UserInfo(Index).UserID, 1) Then
                                If ServiceSocket(u).State = 7 Then
                                    BuddyUserFound = True
                                    ServiceSocket(Index).SendData ".pushbuddy " & TranslateStatus(UserInfo(u).Status) & " " & BuddyUserID & " " & BuddyUserTitle
                                    DoEvents
                                    Exit For
                                Else
                                    BuddyUserFound = True
                                    ServiceSocket(Index).SendData ".pushbuddy Offline " & BuddyUserID & " " & BuddyUserTitle
                                    DoEvents
                                    Exit For
                                End If
                            End If
                        End If
                    Next
                If BuddyUserFound = False Then
                    ServiceSocket(Index).SendData ".pushbuddy Offline " & BuddyUserID & " " & BuddyUserTitle
                End If
                DoEvents
            End If
            timedPause 1
        Next
    End If
End Function

'================
'添加好友过程
'=================
Public Function AddBuddy(UserCommand As String, Index As Integer)
    Dim UserCount As Integer
    Dim BuddyCount As Integer
    Dim g As Integer
    
    '取得好友数
    BuddyCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "BuddyList"))
    If BuddyCount > 0 Then
        '查找新添加的用户
        Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
        For g = 1 To BuddyCount
            Get #gFileNum, g, Buddy
            If Trim(Buddy) = Word(UserCommand, 3) Then
                '新添加的用户已经在好友列表中，通知客户端
                ServiceSocket(Index).SendData ".AlreadyOnList"
                Exit Function
            End If
        Next g
        Close #gFileNum
    End If
    UserCount = Val(LoadINI("Count", "UserCount", "TotalUsers"))
    Dim TempUser As String
    Dim TempIndex As Integer
    '判断是否添加自己
    If UserInfo(Index).UserID = Word(UserCommand, 3) Then
        '通知客户端，您不能添加自己
        ServiceSocket(Index).SendData ".ServerMessage You can not add yourself!  =P"
        Exit Function
    End If
    '在服务器的用户列表中查找新用户
    For u = 1 To UserCount
        Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
            Get #gFileNum, u, SavedUserInfo
            TempUser = Trim(SavedUserInfo.UserID)
        Close #gFileNum
        DoEvents
        TempIndex = u
        If TempUser = Word(UserCommand, 3) Then GoTo ContAdd
    Next
    '没有找到该新添加的用户，通知客户端，新用户不存在
    ServiceSocket(Index).SendData ".ServerMessage User does not exist!"
    Exit Function
ContAdd:
    '添加新用户到好友列表中
    BuddyCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "BuddyList")) + 1
    SaveINI UserInfo(Index).UserID, "Count", "BuddyList", Str(BuddyCount)
    Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
        Buddy = Word(UserCommand, 3)
        Put #gFileNum, BuddyCount, Buddy
    Close #gFileNum
    ServiceSocket(Index).SendData ".pushbuddy Offline " & TempUser & " " & TempUser
    DoEvents
End Function

'=================
'删除好友
'=================
Public Function RemoveBuddy(UserCommand As String, Index As Integer)
    Dim BuddyCount As Integer
    Dim TempBuddy As String
    Dim TempBuddyID As String
    Dim TempBuddyName As String
    
    '取得好友总数
    BuddyCount = LoadINI(UserInfo(Index).UserID, "Count", "BuddyList")
    If BuddyCount = 0 Then Exit Function
    For a = 1 To BuddyCount
        Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
            Get #gFileNum, a, Buddy
            TempBuddy = Trim(Buddy)
        Close #gFileNum
        If TempBuddy = Word(UserCommand, 2) Then
            For u = a To BuddyCount - 1
                Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
                    Get #gFileNum, u + 1, Buddy
                    Put #gFileNum, u, Buddy
                Close #gFileNum
                DoEvents
            Next
            '保存新用户好友列表
            Open UserInfo(Index).UserID & "2.dat" For Random As gFileNum Len = Len(Buddy)
                Put #gFileNum, BuddyCount, vbNullString
            Close #gFileNum
            DoEvents
            SaveINI UserInfo(Index).UserID, "Count", "BuddyList", BuddyCount - 1
            '通知客户端，删除成功
            ServiceSocket(Index).SendData ".RemoveBuddy " & Word(UserCommand, 2)
            Exit Function
        End If
    Next
End Function

'=============
'取得状态
'=============
Public Function Status(UserCommand As String, Index As Integer)
    UserInfo(Index).Status = Word(UserCommand, 2)
    If UserInfo(Index).Status = "Invisible" Then UserInfo(Index).Status = "Offline"
End Function

'===============
'取得状态
'===============
Public Function GetStatus(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        If WordIndex(" ", Trim(UserInfo(u).UserID)) Then
            UserInfo(u).UserID = "N/A"
        End If
        If InStr(1, Trim(Word(UserCommand, 2)), Trim(UserInfo(u).UserID)) Then
            If Not UserInfo(u).UserID = UserInfo(Index).UserID Then
                If ServiceSocket(u).State = 7 Then
                    If InStr(1, UserInfo(u).Status, "Invisible") Then
                        ServiceSocket(Index).SendData ".pushbuddyupdate " & UserInfo(u).UserID & " Offline"
                        DoEvents
                        Exit Function
                    Else
                        ServiceSocket(Index).SendData ".pushbuddyupdate " & UserInfo(u).UserID & " " & UserInfo(u).Status
                        DoEvents
                        Exit Function
                    End If
                Else
                    ServiceSocket(Index).SendData ".pushbuddyupdate " & UserInfo(u).UserID & " Offline"
                    DoEvents
                    Exit Function
                End If
            End If
        End If
    Next
    ServiceSocket(Index).SendData ".pushbuddyupdate " & Word(UserCommand, 2) & " Offline"
    DoEvents
End Function

'==============
'发送消息
'===============
Public Function Message(UserCommand As String, Index As Integer)