admin_message.asp

个人网站比较简短

    GroupID = Trim(Request("GroupID"))
    Title = Trim(Request("Title"))
    Content = Trim(Request("Content"))

    Select Case InceptUserType
    Case 1
        If IsValidID(GroupID) = False Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请指定会员组！</li>"
        End If
    Case 2
        If inceptUser = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请指定接收会员！</li>"
        End If
    End Select
    If Title = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息主题不能为空！</li>"
    End If
    If Content = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息内容不能为空！</li>"
    End If
    If Sender = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息发送人不能为空！</li>"
    End If
    If FoundErr = True Then
        Exit Sub
    End If
    Sender = ReplaceBadChar(Sender)
    Title = ReplaceBadChar(Title)
    Set rsMessage = Server.CreateObject("adodb.recordset")
    sqlMessage = "select top 1 * from PE_Message"
    rsMessage.Open sqlMessage, Conn, 1, 3

    Select Case InceptUserType
    Case 0  '所有会员
        sql = "select UserName from PE_User order by UserID desc"
    Case 1  '指定会员组
        sql = "select UserName from PE_User where GroupID in (" & GroupID & ") order by UserID desc"
    Case 2  '指定会员
        inceptUser = Replace(inceptUser, ",", "','")
        sql = "select UserName from PE_User where UserName in ('" & inceptUser & "') order by UserID desc"
    End Select
    Set rs = Conn.Execute(sql)
    If rs.BOF And rs.EOF Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>未找到任何会员！</li>"
    Else
        Do While Not rs.EOF
            rsMessage.addnew
            rsMessage("Incept") = rs(0)
            rsMessage("Sender") = Sender
            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='" & rs(0) & "'")
            rs.MoveNext
        Loop
    End If
    rs.Close
    Set rs = Nothing
    rsMessage.Close
    Set rsMessage = Nothing

    If FoundErr = True Then
        Exit Sub
    Else
        Call WriteSuccessMsg("<li><b>恭喜您，发送短信息成功。</b>", ComeUrl)
    End If
End Sub

Sub BatchDel()
    Response.Write "<br><table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' class='border'>"
    Response.Write "  <form method='POST' name='myform' action='Admin_Message.asp' target='_self'>"
    Response.Write "    <input name='Action' type='hidden' id='Action' value='DelUserMessage'>"
    Response.Write "    <tr class='topbg'>"
    Response.Write "      <td height='22' colspan='2' align='center'><strong>批 量 删 除 操 作</strong></td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td width='350' height='40'><strong>批量删除会员短消息：</strong><br>可以用英文状态下的逗号将用户名隔开实现多会员同时删除</td>"
    Response.Write "      <td>"
    Response.Write "        <input type='text' name='Sender' size='32' id='Sender' value=''>&nbsp;&nbsp;"
    Response.Write "        <input name='DelUserMessage' type='submit'  id='DelUserMessage' value=' 提 交 ' onClick=""document.myform.Action.value='DelUserMessage';document.myform.target='_self';"" style='cursor:hand;'>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td width='350' height='40'><strong>批量删除指定日期范围内的短消息：</strong><br>默认为删除已读信息</td>"
    Response.Write "      <td>"
    Response.Write "        <select name='DelDate' size=1>"
    Response.Write "          <option value=1>一天前</option>"
    Response.Write "          <option value=3>三天前</option>"
    Response.Write "          <option value=7 selected>一个星期前</option>"
    Response.Write "          <option value=30>一个月前</option>"
    Response.Write "          <option value=60>两个月前</option>"
    Response.Write "          <option value=180>半年前</option>"
    Response.Write "          <option value=''>所有信息</option>"
    Response.Write "        </select>&nbsp;&nbsp;"
    Response.Write "        <input type='checkbox' name='Flag' value='0'> 包括未读信息&nbsp;&nbsp;"
    Response.Write "        <input name='DelChkMessage' type='submit'  id='DelChkMessage' value=' 提 交 ' onClick=""document.myform.Action.value='DelChkMessage';document.myform.target='_self';"" style='cursor:hand;'>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "  </form>"
    Response.Write "</table>"
End Sub

Sub DelUserMessage()
    Dim Sender, i, trs, tsql, Num
    Sender = Trim(Request("Sender"))
    If Sender = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请输入要批量删除的用户名！</li>"
        Exit Sub
    End If
    Sender = ReplaceBadChar(Sender)
    Sender = Split(Sender, ",")
    For i = 0 To UBound(Sender)
        tsql = "select incept from PE_Message where Sender='" & Sender(i) & "' and flag=0 and IsSend=1"
        Set trs = Server.CreateObject("adodb.recordset")
        trs.Open tsql, Conn, 1, 1
        Num = trs.RecordCount
        If Not trs.EOF Then
            Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg-" & Num & " where UserName='" & trs(0) & "'")
        End If
        Set trs = Nothing
        Conn.Execute ("delete from PE_Message where Sender='" & Sender(i) & "'")
    Next
    Call WriteSuccessMsg("<li><b>批量删除短信息成功。</b>", ComeUrl)
End Sub

Sub DelChkMessage()
    Dim PE_DatePart_D, strFlag, DelDate, trs, tsql
    If SystemDatabaseType = "SQL" Then
        PE_DatePart_D = "d"
    Else
        PE_DatePart_D = "'d'"
    End If
    If Trim(Request("Flag")) = "0" Then
        strFlag = ""
    Else
        strFlag = " and flag=1"
    End If
    DelDate = Trim(Request("DelDate"))
    If DelDate = "" Or Not IsNumeric(DelDate) Then
        If Trim(Request("Flag")) = "0" Then
            tsql = "select incept from PE_Message where id>0 " & strFlag & "and flag=0 and IsSend=1"
            Set trs = Server.CreateObject("adodb.recordset")
            trs.Open tsql, Conn, 1, 1
            Do While Not trs.EOF
                Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg-1 where UserName= '" & trs("incept") & "'")
                trs.MoveNext
            Loop
            Set trs = Nothing
        End If
        Conn.Execute ("delete from PE_Message where id>0 " & strFlag)
    Else
        If Trim(Request("Flag")) = "0" Then
            tsql = "select incept from PE_Message where datediff(" & PE_DatePart_D & ",sendtime," & PE_Now & ")>" & CLng(DelDate) & strFlag & " and flag=0 and IsSend=1"
            Set trs = Server.CreateObject("adodb.recordset")
            trs.Open tsql, Conn, 1, 1
            Do While Not trs.EOF
                Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg-1 where UserName= '" & trs("incept") & "'")
                trs.MoveNext
            Loop
            Set trs = Nothing
        End If
    Conn.Execute ("delete from PE_Message where datediff(" & PE_DatePart_D & ",sendtime," & PE_Now & ")>" & CLng(DelDate) & strFlag)
    End If
    Call WriteSuccessMsg("<li><b>批量删除短信息成功。</b>", ComeUrl)
End Sub

Sub Read()
    Dim rs
    If IsValidID(MessageID) = False Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>指定的短消息ID错误！</li>"
        Exit Sub
    End If
    MessageID = PE_CLng(MessageID)
    Set rs = Conn.Execute("select * from PE_Message where ID=" & MessageID)
    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'>" & GetManagePath() & "</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'><td><b>发 件 人：</b>" & rs("Sender") & "</td></tr>"
    Response.Write "  <tr class='tdbg'><td><b>收 件 人：</b>" & rs("Incept") & "</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><b>消息内容：</b></tr>"
    Response.Write "  <tr class='tdbg'><td>" & FilterBadTag(rs("Content"), rs("Sender")) & "</td></tr>"
    Response.Write "</table>"
    rs.Close
    Set rs = Nothing
End Sub

Sub Del()
    Dim sqlDel, rsDel, tsql, trs
    If IsValidID(MessageID) = False Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>指定的短消息ID错误！</li>"
        Exit Sub
    End If
    tsql = "select incept from PE_Message where ID in (" & MessageID & ") and flag=0 and IsSend=1"
    Set trs = Server.CreateObject("adodb.recordset")
    trs.Open tsql, Conn, 1, 1

    Do While Not trs.EOF
        Conn.Execute ("update PE_User set UnreadMsg=UnreadMsg-1 where UserName= '" & trs("incept") & "'")
        trs.MoveNext
    Loop
    Set trs = Nothing

    Conn.Execute ("delete from PE_Message where ID in (" & MessageID & ")")
    Call CloseConn
    Response.Redirect ComeUrl
End Sub

Function GetManagePath()
    Dim strPath
    strPath = "您现在的位置：短消息管理&nbsp;&gt;&gt;&nbsp;"
    If Action = "Add" Then
        strPath = strPath & "发布网站消息"
    ElseIf Action = "BatchDel" Then
        strPath = strPath & "批量删除操作"
    Else
        If Keyword = "" Then
            If Action = "Read" Then
                strPath = strPath & "阅读短消息"
            ElseIf Action = "Send" 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 "Incept"
                    strPath = strPath & "收件人为 <font color=red>" & Keyword & "</font> "
                Case "Sender"
                    strPath = strPath & "发件人为 <font color=red>" & Keyword & "</font> "
                Case Else
                    strPath = strPath & "主题中含有 <font color=red>" & Keyword & "</font> "
            End Select
            strPath = strPath & "的短消息"
        End If
    End If
    GetManagePath = strPath
End Function

Function GetMessageSearch()
    Dim strForm
    strForm = "<table border='0' cellpadding='0' cellspacing='0'>"
    strForm = strForm & "<form method='Get' name='SearchForm' action='Admin_Message.asp'>"
    strForm = strForm & "<tr><td height='28' align='center'>"
    strForm = strForm & "<select name='Field' size='1'>"
    strForm = strForm & "<option value='Title' selected>短消息主题</option>"
    strForm = strForm & "<option value='Content'>短消息内容</option>"
    strForm = strForm & "<option value='Incept'>收件人</option>"
    strForm = strForm & "<option value='Sender'>发件人</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>"
    GetMessageSearch = strForm
End Function
%>