form1.frm

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

    On Error Resume Next
    Dim IMMyName As String
    IMMyName = Replace(UserInfo(Index).Nickname, " ", "_._")
    Dim TempUserID As Variant
    For u = 0 To intMax
        If InStr(1, Word(UserCommand, Words(UserCommand)), UserInfo(u).UserID) Then
            For a = 1 To Val(LoadINI(UserInfo(u).UserID, "Count", "IgnoreList"))
                Open UserInfo(u).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
                    Get #gFileNum, a, Ignore
                Close #gFileNum
                '判断是否在黑名单中
                If Trim(Ignore) = UserInfo(Index).UserID Then Exit Function
            Next
            If ServiceSocket(u).State = 7 Then
                '如果新用户在线，发送消息
                If Not UserInfo(u).Status = "Offline" Then
                    timedPause 1
                    TempUserID = UserInfo(Index).UserID
                    ServiceSocket(u).SendData ".msg " & TempUserID & " " & IMMyName & " ..//.. " & MidWord(UserCommand, 2, Words(UserCommand) - 1)
                    Exit Function
                End If
            End If
        End If
    Next
    '通知客户端，用户不在线
    ServiceSocket(Index).SendData ".ServerMessage User is not online."
End Function

'===========
'取得IP地址
'==========
Public Function GetIPForFileSend(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        If UserInfo(u).UserID = "" Then
            UserInfo(u).UserID = "N/A"
        End If
        For a = 1 To Val(LoadINI(UserInfo(u).UserID, "Count", "IgnoreList"))
            Open UserInfo(u).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
                Get #gFileNum, a, Ignore
            Close #gFileNum
            '判断是否在黑名单中
            If Trim(Ignore) = UserInfo(Index).UserID Then Exit Function
        Next
        If InStr(1, Word(Trim(UserCommand), 2), UserInfo(u).UserID) Then
            '发送发送文件命令
            ServiceSocket(Index).SendData ".SendFile " & UserInfo(u).UserIP
            Exit Function
        End If
    Next
    '通知客户端，用户不在线
    ServiceSocket(Index).SendData ".ServerMessage User not online."
End Function

'============
'接收文件
'============
Public Function RecieveFile(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        If UserInfo(u).UserID = "" Then
            UserInfo(u).UserID = "N/A"
        End If
        If InStr(1, Word(Trim(UserCommand), 2), UserInfo(u).UserID) Then
            ServiceSocket(u).SendData ".RecieveFile " & UserInfo(Index).UserIP
        End If
    Next
End Function

'============
'取得实进聊天IP地址
'=============
Public Function GetIPForRTChat(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        '用户ID不能为空
        If UserInfo(u).UserID = "" Then
            UserInfo(u).UserID = "N/A"
        End If
        If Word(UserCommand, 2) = UserInfo(u).UserID Then
            For a = 1 To Val(LoadINI(UserInfo(u).UserID, "Count", "IgnoreList"))
                Open UserInfo(u).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
                    Get #gFileNum, a, Ignore
                Close #gFileNum
                '判断是否在黑名单中
                If Trim(Ignore) = UserInfo(Index).UserID Then Exit Function
            Next
            '成功，发送消息
            ServiceSocket(u).SendData ".RTChat2 " & UserInfo(Index).UserID
            Exit Function
        End If
    Next
    '用户不在线
    ServiceSocket(Index).SendData ".ServerMessage User not online."
End Function

'================
'开始实时聊天
'================
Public Function BeginRTChat(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        If UserInfo(u).UserID = "" Then
            UserInfo(u).UserID = "N/A"
        End If
        If Word(UserCommand, 2) = UserInfo(u).UserID Then
            ServiceSocket(u).SendData ".RTChat " & UserInfo(Index).UserIP
            Exit Function
        End If
    Next
    '用户不在线
    ServiceSocket(Index).SendData ".ServerMessage User not online."
End Function

'============
'取消实时聊天
'============
Public Function CancelRTChat(UserCommand As String, Index As Integer)
    For u = 0 To intMax
        If UserInfo(u).UserID = "" Then
            UserInfo(u).UserID = "N/A"
        End If
        If Word(UserCommand, 2) = UserInfo(u).UserID Then
            '发送取消实时聊天命令
            ServiceSocket(u).SendData ".ServerMessage User cancelled chat."
            Exit Function
        End If
    Next
    '用户不在线
    ServiceSocket(Index).SendData ".ServerMessage User not online."
End Function

'==========
'保存用户信息
'==========
Public Function SaveInfo(UserCommand As String, Index As Integer)
    UserPersonalInfo.Sex = Word(UserCommand, 3)
    UserPersonalInfo.Country = Word(UserCommand, 4)
    UserPersonalInfo.BirthDay = Word(UserCommand, 5)
    UserPersonalInfo.Age = Word(UserCommand, 6)
    UserPersonalInfo.Webpage = Word(UserCommand, 7)
    UserPersonalInfo.About = MidWord(UserCommand, 8, Val(Words(UserCommand)) - 7)
    Open Word(UserCommand, 2) & ".dat" For Random As gFileNum Len = Len(UserPersonalInfo)
        Put #gFileNum, 1, UserPersonalInfo
    Close #gFileNum
End Function

'==============
'取得好友信息
'==============
Public Function GetBuddyInfo(UserCommand As String, Index As Integer)
    Dim UserCount As Integer
    UserCount = Val(LoadINI("Count", "UserCount", "TotalUsers"))
    Dim TempUser As String
    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
        If InStr(1, Word(UserCommand, 2), TempUser) Then
            Open TempUser & ".dat" For Random As gFileNum Len = Len(UserPersonalInfo)
                Get #gFileNum, 1, UserPersonalInfo
                ServiceSocket(Index).SendData ".UserInfo " & Trim(UserPersonalInfo.Country) & " " & Trim(UserPersonalInfo.BirthDay) & " " & Trim(UserPersonalInfo.Age) & " " & Trim(UserPersonalInfo.Webpage) & " " & Trim(UserPersonalInfo.About) & " " & Trim(UserPersonalInfo.Sex)
            Close #gFileNum
            Exit Function
        End If
    Next
End Function

'===============
'报告
'===============
Public Function Report(UserCommand As String, Index As Integer)
    Select Case Word(UserCommand, 2)
        '建议
        Case "Complaint"
            FileComplaint UserCommand, Index
        '错误
        Case "Bug"
            FileBug UserCommand, Index
        '内容
        Case "Comment"
            FileComment UserCommand, Index
        '其他
        Case Else
            ServiceSocket(Index).SendData ".ServerMessage Err: Was unable to determine what kind of report you were trying to file!"
    End Select
End Function

'================
'接收建议
'================
Public Function FileComplaint(UserCommand As String, Index As Integer)
    Dim ComplaintsCount As Integer
    ComplaintsCount = Val(LoadINI("Reports", "Complaints", "Count"))
    ComplaintsCount = ComplaintsCount + 1
    SaveINI "Reports", "Complaints", "Count", Str(ComplaintsCount)
    SaveINI "Reports", "Complaints", "Complaint" & ComplaintsCount, Now & ":" & UserInfo(Index).UserID & ": " & MidWord(UserCommand, 3, Words(UserCommand) - 2)
    RichTextBox1.SelColor = vbOrange
    RichTextBox1.SelText = Now & ":" & UserInfo(Index).UserID & ":Filed the complaint: " & MidWord(UserCommand, 3, Words(UserCommand) - 2) & vbCrLf
    RichTextBox1.SelColor = vbBlack
    ServiceSocket(Index).SendData ".ServerMessage Your report was filed correctly."
    Text3.Text = ComplaintsCount
End Function

'================
'接收错误报告
'================
Public Function FileBug(UserCommand As String, Index As Integer)
    Dim BugCount As Integer
    BugCount = Val(LoadINI("Reports", "Bugs", "Count"))
    BugCount = BugCount + 1
    SaveINI "Reports", "Bugs", "Count", Str(BugCount)
    SaveINI "Reports", "Bugs", "Bug" & BugCount, Now & ":" & UserInfo(Index).UserID & ": " & MidWord(UserCommand, 3, Words(UserCommand) - 2)
    RichTextBox1.SelColor = vbOrange
    RichTextBox1.SelText = Now & ":" & UserInfo(Index).UserID & ":Filed the bug: " & MidWord(UserCommand, 3, Words(UserCommand) - 2) & vbCrLf
    RichTextBox1.SelColor = vbBlack
    ServiceSocket(Index).SendData ".ServerMessage Your report was filed correctly."
    Text4.Text = BugCount
End Function

'================
'接收内容报告
'================
Public Function FileComment(UserCommand As String, Index As Integer)
    Dim CommentsCount As Integer
    CommentsCount = Val(LoadINI("Reports", "Comments", "Count"))
    CommentsCount = CommentsCount + 1
    SaveINI "Reports", "Comments", "Count", Str(CommentsCount)
    SaveINI "Reports", "Comments", "Comment" & CommentsCount, Now & ":" & UserInfo(Index).UserID & ": " & MidWord(UserCommand, 3, Words(UserCommand) - 2)
    RichTextBox1.SelColor = vbOrange
    RichTextBox1.SelText = Now & ":" & UserInfo(Index).UserID & ":Filed the comment: " & MidWord(UserCommand, 3, Words(UserCommand) - 2) & vbCrLf
    RichTextBox1.SelColor = vbBlack
    ServiceSocket(Index).SendData ".ServerMessage Your report was filed correctly."
    Text5.Text = CommentsCount
End Function

'================
'修改密码
'================
Public Function Password(UserCommand As String, Index As Integer)
    Dim UserCount As Integer
    UserCount = Val(LoadINI("Count", "UserCount", "TotalUsers"))
    For a = 1 To UserCount
        '取得用户密码
        Open "Server.dat" For Random As gFileNum Len = Len(SavedUserInfo)
            Get #gFileNum, a, SavedUserInfo
            If UCase(Trim(SavedUserInfo.UserID)) = UCase(UserInfo(Index).UserID) Then
                SavedUserInfo.Password = Word(UserCommand, 2)
                Put #gFileNum, a, SavedUserInfo
                ServiceSocket(Index).SendData ".ServerMessage Password changed correctly!"
                Close #gFileNum
                Exit Function
            End If
        Close #gFileNum
    Next
    ServiceSocket(Index).SendData ".ServerMessage Password not changed!"
    Beep
    RichTextBox1.SelColor = vbRed
    RichTextBox1.SelText = Now & ":" & UserInfo(Index).UserID & ":POSSIBLE HACKING ATTEMPT: User failed to change password!" & vbCrLf
    RichTextBox1.SelColor = vbBlack
End Function

'==============
'添加黑名单
'==============
Public Function AddIgnore(UserCommand As String, Index As Integer)
    Dim UserCount As Integer
    Dim IgnoreCount As Integer
    Dim g As Integer
    
    '取得黑名单列表数量
    IgnoreCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "IgnoreList"))
    If IgnoreCount > 0 Then
        Open UserInfo(Index).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
        For g = 1 To IgnoreCount
            Get #gFileNum, g, Ignore
            If Trim(Ignore) = Word(UserCommand, 2) 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, 2) 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, 2) Then GoTo ContAdd
    Next
    ServiceSocket(Index).SendData ".ServerMessage User does not exist!"
    Exit Function
ContAdd:
    IgnoreCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "IgnoreList")) + 1
    SaveINI UserInfo(Index).UserID, "Count", "IgnoreList", Str(IgnoreCount)
    Open UserInfo(Index).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
        Ignore = Word(UserCommand, 2)
        Put #gFileNum, IgnoreCount, Ignore
    Close #gFileNum
    ServiceSocket(Index).SendData ".AddIgnore " & TempUser
    DoEvents
End Function

'==============
'删除黑名单
'===============
Public Function RemoveIgnore(UserCommand As String, Index As Integer)
    On Error Resume Next
    Dim IgnoreCount As Integer
    Dim TempIgnore As String
    IgnoreCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "IgnoreList"))
    If IgnoreCount = 0 Then Exit Function
    If Val(Word(UserCommand, 2)) < 0 Then Exit Function
    For a = Val(Word(UserCommand, 2)) + 1 To IgnoreCount - 1
        Open UserInfo(Index).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
            Get #gFileNum, a + 1, Ignore
            Put #gFileNum, a, Ignore
        Close #gFileNum
        DoEvents
    Next
    Open UserInfo(Index).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
         Put #gFileNum, IgnoreCount, vbNullString
    Close #gFileNum
    DoEvents
    IgnoreCount = IgnoreCount - 1
    SaveINI UserInfo(Index).UserID, "Count", "IgnoreList", Str(IgnoreCount)
    GetIgnoreList UserCommand, Index
End Function

'==============
'取得黑名单列表
'==============
Public Function GetIgnoreList(UserCommand As String, Index As Integer)
    On Error Resume Next
    Dim IgnoreCount As Integer
    
    '黑名单列表数量
    IgnoreCount = Val(LoadINI(UserInfo(Index).UserID, "Count", "IgnoreList"))
    DoEvents
    ServiceSocket(Index).SendData ".ClearIgnoreList"
    DoEvents
    If IgnoreCount > 0 Then
        For a = 1 To IgnoreCount
            '打开文件，读取黑名单列表
            Open UserInfo(Index).UserID & "3.dat" For Random As gFileNum Len = Len(Ignore)
                Get #gFileNum, a, Ignore
                DoEvents
                Temp = Ignore
                DoEvents
            Close #gFileNum
            If Not Temp = Ignore Then Temp = Ignore
            DoEvents
            '发送添加黑名单命令
            ServiceSocket(Index).SendData ".AddIgnore " & Temp
            timedPause 1
        Next
    End If
End Function