form1.frm

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

            MsgBox "您没有输入任何消息"
        Else
            '发送SOCKET消息
            ServiceSocket(TempInt).SendData ".ServerMessage " & Text2.Text
        End If
    End If
    '清空文本框
    Text2.Text = ""
    Exit Sub

'处理错误
PMessageError:
    Select Case Err.Number
        Case 381
            MsgBox "请先选择消息接收人", vbCritical
    End Select
End Sub

'=============
'查看客户端上传的建议
'=============
Private Sub Command4_Click()
    Dim ComplaintsCount As Integer
    '读取INI设置，最大建议条数
    ComplaintsCount = Val(LoadINI("Reports", "Complaints", "Count"))
    If ComplaintsCount = 0 Then
      '没有建议
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何建议报告." & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    '有建议，显示
    If ComplaintsCount > 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "There are " & ComplaintsCount & " complaints to report." & vbCrLf
        RichTextBox1.SelColor = vbBlack
        For a = 1 To ComplaintsCount
            RichTextBox1.SelText = LoadINI("Reports", "Complaints", "Complaint" & a) & vbCrLf
            RichTextBox1.SelText = vbCrLf
        Next
    End If
End Sub

'=================
'查看错误报告
'=================
Private Sub Command5_Click()
    Dim BugCount As Integer
    
    '读INI文件，取得错误报告条数
    BugCount = Val(LoadINI("Reports", "Bugs", "Count"))
    If BugCount = 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何错误报告." & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    If BugCount > 0 Then
      '有错误报告，显示在文本框中
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "有 " & BugCount & " 条错误报告." & vbCrLf
        RichTextBox1.SelColor = vbBlack
        '显示错误报告
        For a = 1 To BugCount
            RichTextBox1.SelText = LoadINI("Reports", "Bugs", "Bug" & a) & vbCrLf
            RichTextBox1.SelText = vbCrLf
        Next
    End If
End Sub

'==============
'查看内容报告
'===============
Private Sub Command6_Click()
    Dim CommentsCount As Integer
    
    '读INI文件，取得内容报告条数
    CommentsCount = Val(LoadINI("Reports", "Comments", "Count"))
    If CommentsCount = 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何内容报告." & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    If CommentsCount > 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "有 " & CommentsCount & " 条内容报告." & vbCrLf
        RichTextBox1.SelColor = vbBlack
        '显示内容报告在文本框中
        For a = 1 To CommentsCount
            RichTextBox1.SelText = LoadINI("Reports", "Comments", "Comment" & a) & vbCrLf
            RichTextBox1.SelText = vbCrLf
        Next
    End If
End Sub

'=============
'删除建议报告
'==============
Private Sub Command7_Click()
    Dim ComplaintsCount As Integer
    '读INI文件，取得建议报告条数
    ComplaintsCount = Val(LoadINI("Reports", "Complaints", "Count"))
    If ComplaintsCount = 0 Then
      '没有建议报告
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何建议报告可以删除!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    '有建议
    If ComplaintsCount > 0 Then
        '用空字符替换所有的建议
        For a = 1 To ComplaintsCount
            SaveINI "Reports", "Complaints", "Complaint" & a, vbNullString
        Next
        '将报告数量设为0
        SaveINI "Reports", "Complaints", "Count", 0
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "删除所有建议报告操作成功!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    Text3.Text = "0"
End Sub

'===============
'删除所有错误报告
'===============
Private Sub Command8_Click()
    Dim BugCount As Integer
    
    '读INI文件，取得报告条数
    BugCount = Val(LoadINI("Reports", "Bugs", "Count"))
    If BugCount = 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何报告可以删除!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    If BugCount > 0 Then
        For a = 1 To BugCount
            SaveINI "Reports", "Bugs", "Bug" & a, vbNullString
        Next
        '将报告数量设为0
        SaveINI "Reports", "Bugs", "Count", 0
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "删除所有报告操作成功!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    Text4.Text = "0"
End Sub

'=============
'删除报告
'==============
Private Sub Command9_Click()
    Dim CommentsCount As Integer
    '读INI文件，取得报告条数
    CommentsCount = Val(LoadINI("Reports", "Comments", "Count"))
    If CommentsCount = 0 Then
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "没有任何报告可以删除!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    If CommentsCount > 0 Then
        For a = 1 To CommentsCount
            SaveINI "Reports", "Comments", "Comment" & a, vbNullString
        Next
        '将报告数量设为0
        SaveINI "Reports", "Comments", "Count", 0
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = "删除所有报告操作成功!" & vbCrLf
        RichTextBox1.SelColor = vbBlack
    End If
    Text5.Text = "0"
End Sub

'=============
'窗体启动过程
'完成相关数据初使化操作
'==============
Private Sub Form_Load()
   
   gFileNum = FreeFile
   
   Label3.Caption = "0 /" & MaxUsers

   sckListen(0).Listen

   FilePath = App.Path & "\"
   
   '在标题中显示版本号
   Me.Caption = "ComX Server Version " & App.Major & "." & App.Minor & App.Revision
   
   '显示报告数量
   Text3.Text = Val(LoadINI("Reports", "Complaints", "Count"))
   Text4.Text = Val(LoadINI("Reports", "Bugs", "Count"))
   Text5.Text = Val(LoadINI("Reports", "Comments", "Count"))

End Sub

Private Sub Form_Unload(Cancel As Integer)
    Command1_Click
End Sub

Private Sub List1_Click()
'
End Sub

Private Sub List1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    '显示右键菜单
    If Button = 2 Then PopupMenu mnuUsers
End Sub

'==============
'黑名单
'==============
Private Sub mnuFileBan_Click()
    Form2.Show
End Sub

'==============
'添加用户黑名单
'==============
Private Sub mnuUsersBan_Click()
    On Error GoTo BanErr
    Form2.Text1.Text = UserInfo(List1.ListIndex).UserID
    Form2.Show
    Exit Sub
BanErr:
    Select Case Err.Number
        Case 9
            MsgBox Err.Description & ", 你没有选择任何操作!"
    End Select
End Sub

'==================
'发送用户消息
'===============
Private Sub mnuUsersKick_Click()
    On Error GoTo KickErr
    '向用户客户端发送消息
    ServiceSocket(List1.ListIndex).SendData ".ServerMessage You have been booted!"
    ServiceSocket(List1.ListIndex).Close
KickErr:
    Select Case Err.Number
        Case 9
            MsgBox Err.Description & ", 你没有选择任何操作!"
    End Select
End Sub

Private Sub RichTextBox1_Change()

   RichTextBox1.SelStart = Len(RichTextBox1)

End Sub


Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  
    RichTextBox1.SelStart = Len(RichTextBox1)

End Sub

'===============
'接受SOCKET请求
'===============
Private Sub sckListen_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    If Command1.Caption = "启动服务" Then Exit Sub
    Call GetFreeWinsockIndex
    ServiceSocket(LastConnection).Close
    ServiceSocket(LastConnection).Accept requestID
    If Index = 0 Then
        If Command1.Caption = "启动服务" Then ServiceSocket(LastConnection).SendData ".LoginBad 7 "
        If intMax < LastConnection Then intMax = LastConnection
        TotalUsersOnline = TotalUsersOnline + 1
        
        '检查是否超过最大用户数限制
        If intMax < MaxUsers + 1 Then
            Label3.Caption = Word(Label3.Caption, 1) + 1 & " /200"
            
            '显示请求连接信息
            RichTextBox1.SelText = Now & ":" & ServiceSocket(intMax).RemoteHostIP & "请求连接服务器" & vbCrLf
            
            List1.AddItem "(" & LastConnection & ") 未知"
            List1.ItemData(List1.NewIndex) = LastConnection
            ServiceSocket(LastConnection).SendData ".Connected"
        Else
            '超过最大用户数限制
            RichTextBox1.SelText = Now & ": 服务器已满，关闭 " & ServiceSocket(intMax).RemoteHostIP & " 的连接请求" & vbCrLf
            '通知客户端服务器已满
            ServiceSocket(LastConnection).SendData ".LoginBad 5"
            intMax = intMax - 1
        End If
    End If
End Sub



'==================
'关闭SOCKET过程
'=================
Private Sub ServiceSocket_Close(Index As Integer)

   RichTextBox1.SelColor = &H80FF&
   '显示用户离线信息
   RichTextBox1.SelText = Now & ": 用户 " & UserInfo(Index).UserID & " 离线." & vbCrLf
   RichTextBox1.SelColor = vbBlack
    
   TotalUsersOnline = TotalUsersOnline - 1
   ServiceSocket(Index).Close
   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 = ""

   RichTextBox1.SelText = Now & ": 中断与 " & ServiceSocket(Index).RemoteHostIP & " 的连接" & vbCrLf

   Label3.Caption = Word(Label3.Caption, 1) - 1 & " /200"
   
   For a = 0 To List1.ListCount - 1
    If List1.ItemData(a) = Index Then
        List1.RemoveItem a
        Exit For
    End If
   Next
   'List1.RemoveItem Index

End Sub

Private Sub ServiceSocket_ConnectionRequest(Index As Integer, ByVal requestID As Long)
'
End Sub

'==============
'接收SOCKET消息
'==============
Private Sub ServiceSocket_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim UserCommand As String
ServiceSocket(Index).GetData UserCommand
Select Case Word(UserCommand, 1)
    '登陆消息
    Case ".login"
        LogIn UserCommand, Index
    '取得好友列表
    Case ".getbuddys"
        GetBuddys UserCommand, Index
    '添加好友
    Case ".AddBuddy"
        AddBuddy UserCommand, Index
    '删除好友
    Case ".RemoveBuddy"
        RemoveBuddy UserCommand, Index
    '取得状态
    Case ".status"
        Status UserCommand, Index
    '取得状态
    Case ".getstatus"
        GetStatus UserCommand, Index
    '发送消息
    Case ".msg"
        Message UserCommand, Index
    '取得发送消息的IP地址
    Case ".GetIPForFileSend"
        GetIPForFileSend UserCommand, Index