mdlvar.bas

This article introduces how to construct a Hospital Ward Information System with three-tiered techno

Attribute VB_Name = "mdlVar"
'用户注册详细信息
Public g_strName As String
Public g_strPwd As String
Public g_intImg As Integer
Public g_intAge As Integer
Public g_intSex As Integer
Public g_strEmail As String
Public g_strAddress As String
Public g_strIntroduce As String
Public g_strNickName As String
Public g_strIP As String
Public g_intPort As Long

Public g_ServerPort As Long

Public g_bClose As Boolean

Public Sub RegisterNewUser(Index As Integer)
    Dim msgstr As String
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUserExist g_strName
    If dataE.rscmdUserExist.RecordCount <> 0 Then
        msgstr = "用户已经存在！"
    Else
        dataE.Commands("cmdAdduser").CommandText = "insert into usertable(username,pwd,nickname,img,age,sex,email,address,introduce,registertime,lastlogin,logintime,logins,state,ip,port,conindex,friends,hates) values('" & g_strName & "','" & g_strPwd & "','" & g_strNickName & "','" & g_intImg & "','" & g_intAge & "','" & g_intSex & "','" & g_strEmail & "','" & g_strAddress & "','" & g_strIntroduce & "','" & Now & "','" & Now & "','" & Now & "','" & 1 & "','" & 1 & "','" & g_strIP & "','" & g_intPort & "','" & Index & "','QICQFRD','QICQHAT')"
        dataE.cmdAdduser
        msgstr = "用户注册成功！"
    End If
    frmServer.wskServer(Index).SendData "QICQSTA" + msgstr
End Sub

Public Sub Loginuser(Index As Integer)
    '用户登录
    Dim arrFriends() As String
    
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdFindUser g_strName, g_strPwd
    If dataE.rscmdFindUser.RecordCount <> 0 Then
        msgstr = "你成功登录了！"
        dataE.Commands("cmdUpdate").CommandText = "update usertable set logintime='" & Now & "',state='" & 1 & "',ip='" & g_strIP & "',port='" & g_intPort & "',conindex='" & Index & "' where username='" & g_strName & "'and pwd='" & g_strPwd & "'"
        'MsgBox dataE.Commands("cmdadduser").CommandText
        dataE.cmdUpdate
        '向用户发送“好友”、“坏人”名单和他们的状态
        '发送好友名单
        Dim strFriends As String
        ReDim arrFriends(1) As String
        Dim k As Long
        Dim strSub As String
        Dim count As Integer
        count = 0
        strFriends = dataE.rscmdFindUser!friends
        strFriends = Right(strFriends, Len(strFriends) - 7)
        Do While Len(strFriends) > 7
           k = InStr(1, strFriends, "QICQFRD", vbTextCompare)
            strSub = Left(strFriends, k - 1)
            arrFriends(count) = strSub
            ReDim Preserve arrFriends(UBound(arrFriends) + 1)
            count = count + 1
            strFriends = Right(strFriends, Len(strFriends) - k - 6)
        Loop
        If count > 0 Then
        '有好友
            strSub = "QICQFRD"
            For k = 0 To count - 1
                If dataE.conQICQ.State <> adStateClosed Then
                    dataE.conQICQ.Close
                    dataE.conQICQ.Open
                End If
                dataE.cmdUserExist arrFriends(k)
                strSub = strSub + dataE.rscmdUserExist!username + "," + dataE.rscmdUserExist!nickname + "," + CStr(dataE.rscmdUserExist!img) + "," + CStr(dataE.rscmdUserExist!State) + "," + dataE.rscmdUserExist!ip + "," + "QICQFRD"
                '向所有在线的好友发送自己上线信息
                If dataE.rscmdUserExist!State = 1 Then
                    frmServer.wskServer(dataE.rscmdUserExist!conindex).SendData "QICQUPL" + g_strName + "," + g_strIP
                End If
            Next
            'MsgBox strSub
            frmServer.wskServer(Index).SendData strSub
        End If
        '发送坏人名单,这和上面的一样，程序略
    Else
        msgstr = "没有这个用户！"
    End If
    frmServer.wskServer(Index).SendData "QICQSTA" + msgstr
   ' If msgstr = "用户已经存在！" Then
    '    frmServer.wskServer(0).Close
      '  frmServer.wskServer(0).LocalPort = 716
     '   frmServer.wskServer(0).Listen
   ' End If
End Sub

Public Sub Logoutuser(Index As Integer)
    '用户退出
    Dim arrFriends() As String
    Dim myname As String
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUser Index
    Dim strFriends As String
    ReDim arrFriends(1) As String
    Dim k As Long
    Dim strSub As String
    Dim count As Integer
    count = 0
    strFriends = dataE.rscmdUser!friends
    myname = dataE.rscmdUser!username
    strFriends = Right(strFriends, Len(strFriends) - 7)
    Do While Len(strFriends) > 7
       k = InStr(1, strFriends, "QICQFRD", vbTextCompare)
        strSub = Left(strFriends, k - 1)
        arrFriends(count) = strSub
        ReDim Preserve arrFriends(UBound(arrFriends) + 1)
        count = count + 1
        strFriends = Right(strFriends, Len(strFriends) - k - 6)
    Loop
    If count > 0 Then
    '有好友
        For k = 0 To count - 1
            If dataE.conQICQ.State <> adStateClosed Then
                dataE.conQICQ.Close
                dataE.conQICQ.Open
            End If
            dataE.cmdUserExist arrFriends(k)
            '向所有在线的好友发送自己离开信息
            If dataE.rscmdUserExist!State = 1 Then
                frmServer.wskServer(dataE.rscmdUserExist!conindex).SendData "QICQOUT" + myname
            End If
        Next
    End If
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
        dataE.Commands("cmdAdduser").CommandText = "update usertable set lastlogin='" & Now & "',state='" & 0 & "',conindex='" & -1 & "' where username='" & myname & "'"
        'MsgBox dataE.Commands("cmdadduser").CommandText
        dataE.cmdAdduser
        '关闭某连接
       ' CloseWinsock Index
End Sub

Public Sub CloseWinsock(Index As Integer)
    '减少关闭的wnsock
    frmServer.wskServer(Index).Close
    Unload frmServer.wskServer(Index)
End Sub

Public Sub Findalluser(Index As Integer)
    '查找所有的用户信息
    Dim str As String
    
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdFindAll
    str = "QICQFND"
    Do While Not dataE.rscmdFindAll.EOF
        str = str + dataE.rscmdFindAll!username + "," + dataE.rscmdFindAll!nickname + "," + CStr(dataE.rscmdFindAll!img) + "," + CStr(dataE.rscmdFindAll!sex) + "," + CStr(dataE.rscmdFindAll!State) + ",QICQFND"
        dataE.rscmdFindAll.MoveNext
    Loop
    'MsgBox str
    frmServer.wskServer(Index).SendData str
End Sub

Public Sub Addfrd(strname As String, Index As Integer)
    '增加好友
    Dim strFriends As String
    Dim strUser As String
    Dim msg As String
    Dim intState As Integer
    Dim intImg As Integer
    Dim strNickname As String
    'Dim intconIndex As Integer
    Dim strIP As String
    Dim strHates As String
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUser Index
    '获得朋友
    strFriends = dataE.rscmdUser!friends
    strUser = dataE.rscmdUser!username
    If InStr(1, strFriends, strname, vbTextCompare) > 1 Then
        msg = "好友已经存在！"
    ElseIf strUser = strname Then
        msg = "不能添加自己为好友！"
    ElseIf InStr(1, strHates, strname, vbTextCompare) > 1 Then
        '如果此人在坏人名单里，则先把他从坏人名单里除掉,程序略。
    Else
        '添加好友
        strFriends = strFriends + strname + "QICQFRD"
        dataE.Commands("cmdUpdate").CommandText = "update usertable set friends='" & strFriends & "' where username='" & strUser & "'"
        dataE.cmdUpdate
        dataE.cmdUserExist strname
        intState = dataE.rscmdUserExist!State
        intImg = dataE.rscmdUserExist!img
        strNickname = dataE.rscmdUserExist!nickname
        'intconIndex = dataE.rscmdUserExist!conindex
        strIP = dataE.rscmdUserExist!ip
        
        msg = "QICQFAD" + strname + "," + strNickname + "," + CStr(intImg) + "," + CStr(intState) + "," + strIP + "," + "QICQFAD"
    End If
    '返回信息
    frmServer.wskServer(Index).SendData msg
        
End Sub
Public Sub AddHate(strname As String, Index As Integer)
    '增加坏人，此程序和添加好友思路一样。
End Sub

Public Sub SendTwoRequest(Index As Integer, strusername As String, port As Long, quest As String)
'请求二人世界处理
    Dim strNameQuery As String
    Dim strIP As String
    Dim strNickname As String
    Dim intImg As Integer
    Dim intState As Integer
    '查找申请用户
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUser Index
    strNameQuery = dataE.rscmdUser!username
    strIP = dataE.rscmdUser!ip
    strNickname = dataE.rscmdUser!nickname
    intImg = dataE.rscmdUser!img
    intState = dataE.rscmdUser!State
    '查找被申请用户
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUserExist strusername
    If dataE.rscmdUserExist!State = 1 Then
        '在线上
        frmServer.wskServer(dataE.rscmdUserExist!conindex).SendData "QICQRTC" + strNameQuery + "," + strIP + "," + CStr(port) + "," + strNickname + "," + CStr(intImg) + "," + CStr(intState) + "," + quest
    Else
        frmServer.wskServer(Index).SendData "QICQSTA" + "用户不在线上！"
    End If
End Sub
Public Sub SendTwoResponse(Index As Integer, port As Long, strname As String)
'二人世界连接应答
    Dim intState As Integer
    Dim conindex As Integer
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUserExist strname
    intState = dataE.rscmdUserExist!State
    conindex = dataE.rscmdUserExist!conindex
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdUser Index

    If intState = 1 Then
        '在线上
        frmServer.wskServer(conindex).SendData "QICQATC" + dataE.rscmdUser!username + "," + CStr(port)
    Else
        frmServer.wskServer(Index).SendData "QICQATC" + "用户不在线上！"
    End If
End Sub

Public Sub CloseAll()
    '关闭所有的连接
    Dim con() As Integer
    ReDim con(1) As Integer
    Dim count As Integer
    Dim k As Integer
    
    count = 0
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
    dataE.cmdFindAll
    Do While Not dataE.rscmdFindAll.EOF
        If dataE.rscmdFindAll!State = 1 Then
        'MsgBox dataE.rscmdFindAll!nickname & dataE.rscmdFindAll!conindex
        con(count) = dataE.rscmdFindAll!conindex
        count = count + 1
        ReDim Preserve con(UBound(con) + 1)
        End If
        dataE.rscmdFindAll.MoveNext
    Loop
    For k = 0 To count - 1
        frmServer.wskServer(con(k)).SendData "QICQSTA" + "系统关闭！"
        MsgBox "关闭连接" + CStr(con(k)) + "……", vbInformation, "关闭连接"
        'CloseWinsock con(k)
        'MsgBox con(k)
    Next
    'frmServer.wskServer(0).Close
    If dataE.conQICQ.State <> adStateClosed Then
        dataE.conQICQ.Close
        dataE.conQICQ.Open
    End If
        dataE.Commands("cmdAdduser").CommandText = "update usertable set lastlogin='" & Now & "',state='" & 0 & "',conindex='" & -1 & "'"
        dataE.cmdAdduser
   g_bClose = True

   'Unload frmServer
End Sub