user_message_code.asp

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

    Response.Write "<script language = 'JavaScript'>" & vbCrLf
    Response.Write "function SelectFromFriend(){" & vbCrLf
    Response.Write "var str1=document.myform.InceptUser.value;" & vbCrLf
    Response.Write "var str2=document.myform.FriendList.value;" & vbCrLf
    Response.Write "if (document.myform.FriendList.value!=''){" & vbCrLf
    Response.Write "   if (str1==''){" & vbCrLf
    Response.Write "       document.myform.InceptUser.value=str2;" & vbCrLf
    Response.Write "   }" & vbCrLf
    Response.Write "   else{" & vbCrLf
    Response.Write "       if (checkFriend(str1,str2))" & vbCrLf
    Response.Write "       {" & vbCrLf
    Response.Write "       document.myform.InceptUser.value=str1+','+str2;" & vbCrLf
    Response.Write "       }" & vbCrLf
    Response.Write "   }" & vbCrLf
    Response.Write "   }" & vbCrLf
    Response.Write "}" & vbCrLf
    Response.Write "function checkFriend(friendlist,thisfriend){" & vbCrLf
    Response.Write "   if(friendlist==thisfriend)" & vbCrLf
    Response.Write "       {" & vbCrLf
    Response.Write "       return false;" & vbCrLf
    Response.Write "       }" & vbCrLf
    Response.Write "   else" & vbCrLf
    Response.Write "       {" & vbCrLf
    Response.Write "       var str=friendlist.split("","");" & vbCrLf
    Response.Write "       for(i=0;i<str.length;i++)" & vbCrLf
    Response.Write "           {" & vbCrLf
    Response.Write "           if(str[i]==thisfriend)" & vbCrLf
    Response.Write "               return false;   " & vbCrLf
    Response.Write "           }" & vbCrLf
    Response.Write "       return true;" & vbCrLf
    Response.Write "       }" & vbCrLf
    Response.Write "}" & vbCrLf
    'Response.Write "function SelectUser(){" & vbCrLf
    'Response.Write "    var arr=showModalDialog('User_SourceList.asp?TypeSelect=UserList&DefaultValue='+document.myform.InceptUser.value,'','dialogWidth:600px; dialogHeight:450px; help: no; scroll: yes; status: no');" & vbCrLf
    'Response.Write "    if (arr != null){" & vbCrLf
    'Response.Write "        document.myform.InceptUser.value=arr;" & vbCrLf
    'Response.Write "    }" & vbCrLf
    'Response.Write "}" & vbCrLf
    Response.Write "function CheckForm(){" & vbCrLf
    Response.Write "  if (document.myform.InceptUser.value==''){" & vbCrLf
    Response.Write "     alert('收件人不能为空！');" & vbCrLf
    Response.Write "     document.myform.InceptUser.focus();" & vbCrLf
    Response.Write "     return false;" & vbCrLf
    Response.Write "  }" & vbCrLf
    Response.Write "  if (document.myform.Title.value==''){" & vbCrLf
    Response.Write "     alert('短消息主题不能为空！');" & vbCrLf
    Response.Write "     document.myform.Title.focus();" & vbCrLf
    Response.Write "     return false;" & vbCrLf
    Response.Write "  }" & vbCrLf

    Response.Write "  var CurrentMode=editor.CurrentMode;" & vbCrLf
    Response.Write "  if (CurrentMode==0){" & vbCrLf
    Response.Write "       document.myform.Content.value=editor.HtmlEdit.document.body.innerHTML; " & vbCrLf
    Response.Write "  }" & vbCrLf
    Response.Write "  else if(CurrentMode==1){" & vbCrLf
    Response.Write "       document.myform.Content.value=editor.HtmlEdit.document.body.innerText;" & vbCrLf
    Response.Write "  }" & vbCrLf

    Response.Write "  if (document.myform.Content.value==''){" & vbCrLf
    Response.Write "     alert('短消息内容不能为空！');" & vbCrLf
    Response.Write "     document.myform.Content.focus();" & vbCrLf
    Response.Write "     return false;" & vbCrLf
    Response.Write "  }" & vbCrLf
    Response.Write "  return true;  " & vbCrLf
    Response.Write "}" & vbCrLf
    Response.Write "</script>" & vbCrLf
    Response.Write "<form method='POST' name='myform' onSubmit='return CheckForm();' action='User_Message.asp' target='_self'>"
    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' colspan='2'><strong>撰 写 短 消 息</strong></td>"
    Response.Write "  </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td width='20%' align='right'>收件人：</td>"
    Response.Write "      <td width='80%'>"
    Response.Write "        <input type='text' name='InceptUser' size='52' id='InceptUser' value='" & inceptUser & "'>"
    Response.Write "      <select name='FriendList' onchange=""SelectFromFriend();"">"
    Response.Write "      <option value=''>请选择...</option>"
    Response.Write GetFriendListOption
    Response.Write "      </select>"
    'Response.Write "       【<a href='#' onclick=""SelectUser();"">会员列表</a>】"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td align='right'>主题：</td>"
    Response.Write "      <td>"
    Response.Write "        <input type='text' name='Title' size='66' id='Title' value='" & Title & "'>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td align='right'>内容：</td>"
    Response.Write "      <td>"
    Response.Write "        <textarea name='Content' id='Content' style='display:none'>" & Content & "</textarea>"
    Response.Write "       <iframe ID='editor' src='../editor.asp?ChannelID=1&ShowType=2&tContentid=Content' frameborder='1' scrolling='no' width='485' height='280' ></iframe>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td height='40' colspan='2' align='center'>"
    Response.Write "        <input name='Action' type='hidden' id='Action' value='Send'>"
    If Action = "Edit" Then
        Response.Write "        <input name='Send' type='submit'  id='Send' value=' 发 送 ' onClick=""document.myform.Action.value='SendEdit';document.myform.target='_self';"" style='cursor:hand;'>&nbsp; "
        Response.Write "        <input name='Save' type='submit'  id='Save' value=' 保 存 ' onClick=""document.myform.Action.value='SaveEdit';document.myform.target='_self';"" style='cursor:hand;'>"
        Response.Write "   <input name='MessageID' type='hidden' id='MessageID' value='" & MessageID & "'>"
    Else
        Response.Write "        <input name='Send' type='submit'  id='Send' value=' 发 送 ' onClick=""document.myform.Action.value='SendMessage';document.myform.target='_self';"" style='cursor:hand;'>&nbsp; "
        Response.Write "        <input name='Save' type='submit'  id='Save' value=' 保 存 ' onClick=""document.myform.Action.value='SaveMessage';document.myform.target='_self';"" style='cursor:hand;'>"
    End If
    Response.Write "        <input type='reset' name='Clear' value=' 清 除 '>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "    <tr class='tdbg'>"
    Response.Write "      <td  colspan='2'>1、可以用英文状态下的逗号将用户名隔开实现群发，最多<b>" & MaxSendNum & "</b>个用户。<br>2、 标题最多<b>" & MaxTitleLength & "</b>个字符，内容最多<b>" & MaxContentLength & "</b>个字符</td>"
    Response.Write "      </td>"
    Response.Write "    </tr>"
    Response.Write "  </table>"
    Response.Write "</form>"
End Sub

Sub SaveMessage()
    If MaxSendNum <= 0 Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>对不起，你没有发送短消息的权限！"
        Exit Sub
    End If
    
    Dim rsMessage, sqlMessage, incept, Title, Content
    incept = Trim(Request("InceptUser"))
    Title = Trim(Request("Title"))
    
    For i = 1 To Request.Form("Content").Count
        Content = Content & FilterJS(Request.Form("Content")(i))
    Next
    
    'Content = Trim(Request("Content"))
    If Request.Cookies("SendMessage") = "Yes" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请不要连续发送相同的短消息！</li>"
        Exit Sub
    End If
    If incept = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>收件人不能为空！</li>"
    End If
    If Title = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息主题不能为空！</li>"
    ElseIf Len(Title) > MaxTitleLength Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息主题过长（应小于" & MaxTitleLength & "）！</li>"
    End If
    If Content = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息内容不能为空！</li>"
    ElseIf Len(Content) > MaxContentLength Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息内容过长（应小于" & MaxContentLength & "）！</li>"
    End If
    If FoundErr = True Then
        Exit Sub
    End If
    incept = ReplaceBadChar(incept)
    Title = ReplaceBadChar(Title)
    
    For i = 1 To Request.Form("Content").Count
        Content = Content & FilterJS(Request.Form("Content")(i))
    Next
    'Content = ReplaceBadUrl(Content)
    Set rsMessage = Server.CreateObject("adodb.recordset")
    sqlMessage = "select top 1 * from PE_Message"
    rsMessage.Open sqlMessage, Conn, 1, 3
    If Action = "SaveMessage" Then
        rsMessage.addnew
        rsMessage("Incept") = incept
        rsMessage("Sender") = UserName
        rsMessage("Title") = Title
        rsMessage("Content") = Content
        rsMessage("SendTime") = Now()
        rsMessage("Flag") = 0
        rsMessage("IsSend") = 0
        rsMessage.Update
        Call WriteSuccessMsg("<li><b>恭喜您，保存短信息成功。</b><br>短消息保存在您的草稿箱中。", ComeUrl)
    Else
        incept = Split(incept, ",")
        Dim strTemp, i
        For i = 0 To UBound(incept)
            If strTemp = "" Then
                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, ",")
        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
            If CheckBlackFriend(incept(i)) Then
                FoundErr = True
                ErrMsg = ErrMsg & "<li>你把<font color='red'>" & incept(i) & "</font>列入了黑名单，或者<font color='red'>" & incept(i) & "</font>把你列入了黑名单，因此短信发送被终止！</li>"
                Exit Sub
            End If
            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
        Call WriteSuccessMsg("<li><b>恭喜您，发送短信息成功。</b><br>发送短消息同时保存在您的已发送信息中。", ComeUrl)
    End If
    rsMessage.Close
    Set rsMessage = Nothing
    Response.Cookies("SendMessage") = "Yes"
End Sub

Sub SaveEdit()
    If IsValidID(MessageID) = False Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>指定的短消息ID错误！</li>"
        Exit Sub
    End If
    If MaxSendNum <= 0 Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>对不起，你没有发送短消息的权限！"
        Exit Sub
    End If

    Dim rsMessage, sqlMessage, incept, Title, Content
    incept = Trim(Request("Incept"))
    Title = Trim(Request("Title"))
    
    'Content = Trim(Request("Content"))
    For i = 1 To Request.Form("Content").Count
        Content = Content & FilterJS(Request.Form("Content")(i))
    Next
    
    If incept = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>收件人不能为空！</li>"
    End If
    If Title = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息主题不能为空！</li>"
    ElseIf Len(Title) > MaxTitleLength Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息主题过长（应小于" & MaxTitleLength & "）！</li>"
    End If
    If Content = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息内容不能为空！</li>"
    ElseIf Len(Content) > MaxContentLength Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>短消息内容过长（应小于" & MaxContentLength & "）！</li>"
    End If
    If FoundErr = True Then
        Exit Sub
    End If
    incept = ReplaceBadChar(incept)
    Title = ReplaceBadChar(Title)
    Content = ReplaceBadUrl(FilterJS(Content))
    If Action = "SaveEdit" Then
        Set rsMessage = Server.CreateObject("adodb.recordset")
        sqlMessage = "select * from PE_Message where ID=" & PE_CLng(MessageID) & " and Sender='" & UserName & "'"
        rsMessage.Open sqlMessage, Conn, 1, 3
        If Not (rsMessage.BOF And rsMessage.EOF) Then
            rsMessage("Incept") = incept
            rsMessage("Title") = Title
            rsMessage("Content") = Content
            rsMessage("SendTime") = Now()
            rsMessage("Flag") = 0
            rsMessage("IsSend") = 0
            rsMessage.Update
        End If
        rsMessage.Close
        Set rsMessage = Nothing
        Call WriteSuccessMsg("<li><b>恭喜您，保存短信息成功。</b><br>短消息保存在您的草稿箱中。", ComeUrl)
    Else
        Conn.Execute ("delete from PE_Message where ID=" & PE_CLng(MessageID) & " and Sender='" & UserName & "'")
        incept = Split(incept, ",")
        Dim strTemp
        For i = 0 To UBound(incept)
            If strTemp = "" Then