module1.bas

一个用vb开发的比较好的聊天系统

Attribute VB_Name = "Module1"
Public Connstring As String
Public Conn As Object
Public Rs As Object
Public Const db_host = "211.90.248.135"
Public Const db_name = "voice_db"
Public Const db_user = "retag"
Public Const db_pass = "qy7ttvj7vg"
Public Const maxnum = 100 '最大人数
Public Const roomnum = 10 '最大房间数
Public Const port = 701 '监听端口
Public Type User        '定义用户信息变量
    Name As String
    RemoteIp As String
    RemotePort As String
    RoomID As String
End Type
Public Type Room
    CanTalk As Boolean
    Name As String
End Type
Public User_info(maxnum) As User    '定义用户信息
Public room_info(roomnum) As Room   '定义房间信息

Public Sub log(i As String)  '日志过程
   log_info.db_log.Text = i + "(" + CStr(Now) + ")" + vbCrLf + log_info.db_log.Text
End Sub

Public Sub start_server()
       Call log("服务已启动")
       main.sckListen.Close
       main.sckListen.LocalPort = port
       main.sckListen.Listen
       main.Toolbar.Buttons(2).Enabled = False
       main.Toolbar.Buttons(3).Enabled = True
       main.Toolbar.Buttons(4).Enabled = True
End Sub

Public Sub pause_server()
    Call log("服务已暂停")
       main.sckListen.Close
       main.Toolbar.Buttons(2).Enabled = True
       main.Toolbar.Buttons(3).Enabled = False
       main.Toolbar.Buttons(4).Enabled = True
End Sub

Public Sub stop_server()
    Call log("服务已关闭")
       main.sckListen.Close
         For i = 0 To main.sckServer.Count - 1
            main.sckServer(i).Close
         Next i
       Conn.execute "delete from active"
       main.Toolbar.Buttons(2).Enabled = True
       main.Toolbar.Buttons(3).Enabled = False
       main.Toolbar.Buttons(4).Enabled = False
End Sub

Function bytes2BSTR(vIn)  '字节转换函数
Dim strReturn
Dim i, ThisCharCode, NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn, i, 1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn, i + 1, 1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function

Public Sub ConnectDataBase(db_host As String, db_name As String, db_user As String, db_pass As String)
    Set Conn = CreateObject("adodb.connection")   '连接数据库
    Conn.open "driver={sql server};server=" + db_host + ";database=" + db_name + ";uid=" + db_user + ";pwd=" + db_pass
    Call log("成功接驳数据库！")
End Sub

Public Sub CloseDataBase()   '关闭数据库
    Conn.Close
    Set Conn = Nothing
End Sub

Public Sub ProcessData(s As Variant, index As Integer)   '分类处理数据
          s = bytes2BSTR(s)
          s_head = Left(s, InStr(2, s, "#"))
          s_main = Right(s, CInt(Len(s) - InStr(2, s, "#")))
          Select Case s_head
            Case "#USERLOGIN#"
               Call UserLogin(s_main, index)
            Case "#USERTALK#"
               Call UserTalk(s_main, index)
            Case "#TALKREQUEST#"
               Call TalkRequest(index)
          End Select
End Sub

Public Sub UserLogin(str As Variant, index As Integer) '用户登陆
          str = Split(str, "#")
          User_info(index).Name = str(0)
          User_info(index).RemoteIp = str(1)
          User_info(index).RemotePort = str(2)
          User_info(index).RoomID = str(3)
          If User_info(index).Name = "" Or User_info(index).RoomID = "" Then
                  main.sckServer(index).Close
                  Exit Sub
          End If
          Set Rs = CreateObject("adodb.recordset")
          Rs.open "select * from active where name='" + User_info(index).Name + "'", Conn, 1, 3
          If Rs.EOF Then Rs.addnew
          Rs("name") = User_info(index).Name
          Rs("remoteip") = User_info(index).RemoteIp
          Rs("remoteport") = User_info(index).RemotePort
          Rs("roomid") = User_info(index).RoomID
          Rs("logintime") = Now()
          Rs("talk") = 0
          Rs.Update
          Rs.Close
          Set Rs = Nothing
          Call log("用户：" + User_info(index).Name + Chr(10) + "IP：" + User_info(index).RemoteIp + ":" + User_info(index).RemotePort + Chr(10) + "房间号：" + User_info(index).RoomID + Chr(10) + "进入聊天室")
End Sub

Public Sub UserLogout(index As Integer) '用户离开
           If room_info(User_info(index).RoomID).Name = User_info(index).Name And room_info(User_info(index).RoomID).CanTalk = False Then room_info(User_info(index).RoomID).CanTalk = True
           Conn.execute "delete from active where name='" + User_info(index).Name + "'"
           Call log("用户：" + User_info(index).Name + Chr(10) + "IP：" + User_info(index).RemoteIp + ":" + User_info(index).RemotePort + Chr(10) + "房间号：" + User_info(index).RoomID + Chr(10) + "退出聊天室")
           main.sckServer(index).Close
End Sub

Public Sub UserTalk(str As Variant, index As Integer)
          str = CInt(Left(str, 1))
          If str = 0 Then room_info(User_info(index).RoomID).CanTalk = True
          Conn.execute "update active set talk=0 where roomid='" + User_info(index).RoomID + "'"
          Conn.execute "update active set talk='" + CStr(str) + "' where name='" + User_info(index).Name + "'"
          
End Sub

Public Sub SendMessage(str As String, index As Integer)
          If str = "" Then Exit Sub
          If main.sckServer(index).State <> 7 Then
              MsgBox "对方并未连接，请重试！", vbOKOnly, "提示"
          Else
              main.sckServer(index).SendData "#MSG#" + str
          End If
End Sub

Public Sub BoardCast(str As String)
          If str = "" Then Exit Sub
          For i = 0 To main.sckServer.Count - 1 Step 1
               If main.sckServer(i).State = 7 Then
                    main.sckServer(i).SendData "#BC#" + str
                    DoEvents
               End If
          Next i
          MsgBox "发送广播信号成功！", vbOKOnly, "提示"
End Sub

Public Sub Kick(str As String, index As Integer)
          Call SendMessage(str, index)
          UserLogout (index)
End Sub

Public Sub InitRoom()
          Set Rs = CreateObject("adodb.recordset")
          Rs.open "select * from room order by room_id", Conn, 1, 1
          If Rs.recordcount > roomnum Then
              MsgBox "房间设定出错！", vbOKOnly, "提示"
              End
              Exit Sub
          End If
          Rs.Close
          Set Rs = Nothing
          For i = 0 To roomnum - 1
             room_info(i).CanTalk = True
             room_info(i).Name = ""
          Next i
          Conn.execute "update active set talk=0"
End Sub

Public Sub TalkRequest(index As Integer)
          If room_info(User_info(index).RoomID).CanTalk = True Then
               room_info(User_info(index).RoomID).CanTalk = False
               room_info(User_info(index).RoomID).Name = User_info(index).Name
               main.sckServer(index).SendData "#TALK#"
          End If
End Sub

Public Sub CloseMic(index As Integer)
          If main.sckServer(index).State = 7 Then
              main.sckServer(index).SendData "#CLOSEMIC#"
          End If
End Sub

Public Sub CloseAllMic()
    Dim i As Integer
    For i = 0 To main.sckServer.Count - 1
        Call CloseMic(i)
        DoEvents
    Next i
    Call InitRoom
End Sub