user_message_code.asp

本程序系统完全实现了医院网站程序的全部功能的前台和后台程序

                strTemp = incept(i)
            Else
                If FoundInArr(strTemp, incept(i), ",") = False And incept(i) <> UserName Then
                    strTemp = strTemp & "," & incept(i)
                End If
            End If
        Next
        incept = Split(strTemp, ",")
        Set rsMessage = Server.CreateObject("adodb.recordset")
        sqlMessage = "select top 1 * from PE_Message"
        rsMessage.Open sqlMessage, Conn, 1, 3
        For i = 0 To UBound(incept)
            If i >= MaxSendNum Then
                FoundErr = True
                ErrMsg = ErrMsg & "<li>最多只能发送给" & MaxSendNum & "个用户，您的名单" & MaxSendNum & "位以后的请重新发送！</li>"
                Exit For
            End If
            Set rs = Conn.Execute("select UserName from PE_User where UserName='" & Replace(incept(i), "'", "") & "'")
            If rs.BOF And rs.EOF Then
                FoundErr = True
                ErrMsg = ErrMsg & "<li>无此用户--" & incept(i) & "，请检查收件人是否填写正确！</li>"
                Set rs = Nothing
                rsMessage.Close
                Set rsMessage = Nothing
                Exit Sub
            End If
            Set rs = Nothing
            rsMessage.addnew
            rsMessage("Incept") = incept(i)
            rsMessage("Sender") = UserName
            rsMessage("Title") = Title
            rsMessage("Content") = Content
            rsMessage("SendTime") = Now()
            rsMessage("Flag") = 0
            rsMessage("IsSend") = 1
            rsMessage.Update
            '更新用户短消息数据
            Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg+1 where UserName='" & incept(i) & "'")
        Next
        rsMessage.Close
        Set rsMessage = Nothing
        Call WriteSuccessMsg("<li><b>恭喜您，发送短信息成功。</b><br>发送短消息同时保存在您的已发送信息中。", ComeUrl)
    End If
End Sub

Sub Read()
    Dim NextID, NextSender
    
    If IsValidID(MessageID) = False Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>指定的短消息ID错误！</li>"
        Exit Sub
    End If
    MessageID = PE_CLng(MessageID)
    
    Set rs = Server.CreateObject("adodb.recordset")
    sql = "select * from PE_Message where (Incept='" & UserName & "' or Sender='" & UserName & "') and ID=" & MessageID
    rs.Open sql, Conn, 1, 3
    If rs.BOF And rs.EOF Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>找不到指定的短消息</li>"
        Set rs = Nothing
        Exit Sub
    End If

    Response.Write "<br><table width='100%' border='0' align='center' cellpadding='0' cellspacing='0'>"
    Response.Write "  <tr>"
    Response.Write "    <td height='22'>" & GetPath() & "</td>"
    Response.Write "  </tr>"
    Response.Write "</table><br>"
    Response.Write "<table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' class='border'>"
    Response.Write "  <tr class='title'>"
    Response.Write "    <td height='22' align='center'><strong>阅 读 短 消 息</strong></td>"
    Response.Write "  </tr>"
    Response.Write "  <tr class='tdbg'>"
    Response.Write "    <td align='center'>"
    Response.Write "      <a href='User_Message.asp?Action=Delete&MessageID=" & rs("ID") & "'><img src='images/m_delete.gif' border=0 alt='删除消息'></a> &nbsp; "
    Response.Write "      <a href='User_Message.asp?Action=New'><img src='images/m_to.gif' border=0 alt='发送消息'></a> &nbsp;"
    Response.Write "      <a href='User_Message.asp?Action=Re&touser={$sender}&MessageID=" & rs("ID") & "'><img src='images/m_re.gif' border=0 alt='回复消息'></a>&nbsp;"
    Response.Write "      <a href='User_Message.asp?Action=Fw&MessageID=" & rs("ID") & "'><img src='images/m_fw.gif' border=0 alt='转发消息'></a>"
    Response.Write "    </td>"
    Response.Write "  </tr>"
    Response.Write "  <tr class='tdbg'><td><b>发 送 人：</b>" & rs("Sender") & "</td></tr>"
    Response.Write "  <tr class='tdbg'><td><b>发送时间：</b>" & rs("SendTime") & "</td></tr>"
    Response.Write "  <tr class='tdbg'><td><b>消息主题：</b>" & PE_HTMLEncode(rs("Title")) & "</td></tr>"
    Response.Write "  <tr class='tdbg'><td>" & FilterBadTag(rs("Content"), rs("Sender")) & "</td></tr>"

    If UserName <> rs("Sender") Then
        If rs("Flag") = 0 Then
            rs("Flag") = 1
            rs.Update
            Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg-1 where UserName='" & UserName & "'")
        End If
    End If
    rs.Close
    Set rs = Nothing

    Set rs = Conn.Execute("select ID,Sender from PE_Message where Incept='" & UserName & "' and Flag=0 and IsSend=1 order by SendTime")
    If Not (rs.BOF And rs.EOF) Then
        NextID = rs(0)
        NextSender = rs(1)
    End If
    Set rs = Nothing

    If Action = "ReadInbox" And NextID <> "" Then
        Response.Write "  <tr class='tdbg'><td align='right'>"
        Response.Write "   <a href=User_Message.asp?Action=ReadInbox&MessageID=" & NextID & ">[读取下一条信息]</a>"
        Response.Write "  </td></tr>"
    End If
    Response.Write "</table>"
End Sub

Sub Del()
    If IsValidID(MessageID) = False Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>指定的短消息ID错误！</li>"
        Exit Sub
    End If
    If Action = "Delete" Then
        Conn.Execute ("delete from PE_Message where Incept='" & UserName & "' and DelR=1 and ID in (" & MessageID & ")")
        Conn.Execute ("delete from PE_Message where Sender='" & UserName & "' and DelS=1 and IsSend=0 and ID in (" & MessageID & ")")
        Conn.Execute ("update PE_Message set DelS=2 where Sender='" & UserName & "' and DelS=1 and IsSend=1 and ID in (" & MessageID & ")")
        Conn.Execute ("update PE_Message set DelR=1 where Incept='" & UserName & "' and ID in (" & MessageID & ")")
        Conn.Execute ("update PE_Message set DelS=1 where Sender='" & UserName & "' and ID in (" & MessageID & ")")
    Else
        Select Case ManageType
        Case "Inbox"
            Conn.Execute ("update PE_Message set DelR=1 where Incept='" & UserName & "' and ID in (" & MessageID & ")")
        Case "Outbox"
            Conn.Execute ("update PE_Message set DelS=1 where Sender='" & UserName & "' and IsSend=0 and ID in (" & MessageID & ")")
        Case "IsSend"
            Conn.Execute ("update PE_Message set DelS=1 where Sender='" & UserName & "' and IsSend=1 and ID in (" & MessageID & ")")
        Case "Recycle"
            Conn.Execute ("delete from PE_Message where Incept='" & UserName & "' and DelR=1 and ID in (" & MessageID & ")")
            Conn.Execute ("delete from PE_Message where Sender='" & UserName & "' and DelS=1 and IsSend=0 and ID in (" & MessageID & ")")
            Conn.Execute ("update PE_Message set DelS=2 where Sender='" & UserName & "' and DelS=1 and IsSend=1 and ID in (" & MessageID & ")")
        End Select
    End If
    Update_User_Message (UserName)
    If Action = "Delete" Or ManageType = "Recycle" Then
        Call WriteSuccessMsg("<li>删除短信息成功。</li>", ComeUrl)
    Else
        Call WriteSuccessMsg("<li>删除短消息成功。删除的消息将转移到您的回收站。</li>", ComeUrl)
    End If
End Sub

Sub Clear()
    Select Case ManageType
    Case "Inbox"
        Conn.Execute ("update PE_Message set DelR=1 where Incept='" & UserName & "' and DelR=0")
    Case "Outbox"
        Conn.Execute ("update PE_Message Set DelS=1 where Sender='" & UserName & "' and DelS=0 and IsSend=0")
    Case "IsSend"
        Conn.Execute ("update PE_Message Set DelS=1 where Sender='" & UserName & "' and DelS=0 and IsSend=1")
    Case "Recycle"
        Conn.Execute ("delete from PE_Message where Incept='" & UserName & "' and DelR=1")
        Conn.Execute ("delete from PE_Message where Sender='" & UserName & "' and DelS=1 and IsSend=0")
        Conn.Execute ("update PE_Message set DelS=2 where Sender='" & UserName & "' and DelS=1 and IsSend=1")
    Case Else
        FoundErr = True
        ErrMsg = ErrMsg & "<li>参数设置错误！</li>"
        Exit Sub
    End Select
    Update_User_Message (UserName)
    If ManageType = "Recycle" Then
        Call WriteSuccessMsg("<li>删除短信息成功。</li>", ComeUrl)
    Else
        Call WriteSuccessMsg("<li>删除短消息成功。删除的消息将转移到您的回收站。</li>", ComeUrl)
    End If
End Sub

Sub Update_User_Message(incept)
    Dim trs
    Set trs = Conn.Execute("select Count(Id) from PE_Message where incept='" & incept & "'and flag=0 and DelR=0")
    If trs(0) = 0 Then
        Conn.Execute ("update PE_User set UnReadMsg=0 where UserName='" & incept & "'")
    Else
        Conn.Execute ("update PE_User set UnReadMsg=" & trs(0) & " where UserName='" & incept & "'")
    End If
End Sub
Sub DelOutMessage()
    Dim OutNum
    MessageCount = 0
    Set rs = Conn.Execute("select count(ID) From PE_Message where Incept='" & UserName & "'")
    MessageCount = rs(0)
    If MessageCount > MaxMessageNum Then
        OutNum = MessageCount - MaxMessageNum
        Set rs = Conn.Execute("select top " & OutNum & " ID From PE_Message where Incept='" & UserName & "' order by ID Asc,DelR Desc")
        While Not rs.EOF
            Conn.Execute ("delete from PE_Message where ID=" & rs(0))
            rs.MoveNext
        Wend
        MessageCount = MaxMessageNum
    End If
    rs.Close
    Set rs = Nothing
End Sub

Function GetSpace()
    Dim tmpSpace, SpacePercent, strSpace
    If MaxMessageNum > 0 Then
        strSpace = strSpace & "空间使用： "
        If FormatNumber(MessageCount / MaxMessageNum * 100, 0, -1) < 50 Then
            strSpace = strSpace & "<font color='green'>" & FormatPercent(MessageCount / MaxMessageNum, 0, -1) & "</font>"
        ElseIf FormatNumber(MessageCount / MaxMessageNum * 100, 0, -1) < 80 Then
            strSpace = strSpace & "<font color='blue'>" & FormatPercent(MessageCount / MaxMessageNum, 0, -1) & "</font>"
        Else
            strSpace = strSpace & "<font color='red'>" & FormatPercent(MessageCount / MaxMessageNum, 0, -1) & "</font>"
        End If
    End If
    GetSpace = strSpace
End Function

Function GetPath()
    Dim strPath
    strPath = "短消息管理"
    If Action = "Manage" Then
        strPath = strPath & "&nbsp;&gt;&gt;&nbsp;" & BoxName & "&nbsp;&gt;&gt;&nbsp;"
        If Keyword = "" Then
            If ManageType = "Inbox" And Action = "Manage" And Passed = "False" Then
                strPath = strPath & "未阅读的短消息"
            ElseIf ManageType = "Inbox" And Action = "Manage" And Passed = "True" Then
                strPath = strPath & "已阅读的短消息"
            Else
                strPath = strPath & "所有短消息"
            End If
        Else
            Select Case strField
                Case "Title"
                    strPath = strPath & "主题中含有 <font color=red>" & Keyword & "</font> 的短消息"
                Case "Content"
                    strPath = strPath & "内容中含有 <font color=red>" & Keyword & "</font> 的短消息"
                Case Else
                    strPath = strPath & "主题中含有 <font color=red>" & Keyword & "</font> 的短消息"
            End Select
        End If
    Else
        strPath = strPath & "&nbsp;&gt;&gt;&nbsp;" & ActionName
    End If
    GetPath = strPath
End Function

Function GetFriendListOption()
    Dim FriendListOption, arraytemp, strTemp, i
    strTemp = ""
    Set FriendListOption = Conn.Execute("select top 20 FriendName from PE_Friend where UserName='" & UserName & "' and GroupID<>0 order by AddTime desc")
    If Not FriendListOption.EOF Then
        arraytemp = FriendListOption.GetRows(-1)
        FriendListOption.Close
    End If
    Set FriendListOption = Nothing
    If IsArray(arraytemp) Then
        For i = 0 To UBound(arraytemp, 2)
            strTemp = strTemp & "<option value='" & arraytemp(0, i) & "'>" & arraytemp(0, i) & ""
        Next
    End If
    GetFriendListOption = strTemp
End Function
Function GetSearchForm()
    Dim strForm
    strForm = "<table border='0' cellpadding='0' cellspacing='0'>"
    strForm = strForm & "<form method='Get' name='SearchForm' action='" & FileName & "'>"
    strForm = strForm & "<tr><td height='28' align='center'>"
    strForm = strForm & " <select name='ManageType'>"
    strForm = strForm & "<option value='Inbox' "
    If ManageType = "Inbox" Then strForm = strForm & "selected"
    strForm = strForm & ">收件箱</option>"
    strForm = strForm & "<option value='Outbox' "
    If ManageType = "Outbox" Then strForm = strForm & "selected"
    strForm = strForm & ">草稿箱</option>"
    strForm = strForm & "<option value='IsSend' "
    If ManageType = "IsSend" Then strForm = strForm & "selected"
    strForm = strForm & ">已发送</option>"
    strForm = strForm & "<option value='Recycle' "
    If ManageType = "Recycle" Then strForm = strForm & "selected"
    strForm = strForm & ">废件箱</option>"
    strForm = strForm & "</select>"
    strForm = strForm & " <select name='Field' size='1'>"
    strForm = strForm & "<option value='Title' selected>短消息主题</option>"
    strForm = strForm & "<option value='Content'>短消息内容</option>"
    strForm = strForm & "</select>"
    strForm = strForm & " <input type='text' name='keyword'  size='20' value='关键字' maxlength='50' onFocus='this.select();'>"
    strForm = strForm & "<input type='submit' name='Submit'  value='搜索'>"
    strForm = strForm & "</td></tr></form></table>"
    GetSearchForm = strForm
End Function

Function CheckBlackFriend(inceputName)
    Dim strFriend, strBlack
    CheckBlackFriend = False
    Set strFriend = Conn.Execute("select FriendName from PE_Friend where (UserName='" & UserName & "' or UserName='" & inceputName & "') and GroupID=0")
    If Not strFriend.EOF Then
        strBlack = strFriend.GetString(, , ",", "", "")
        If InStr(strBlack, inceputName) Or InStr(strBlack, UserName) Then CheckBlackFriend = True
    End If
    strFriend.Close
    Set strFriend = Nothing
End Function
%>