admin_maillist.asp

来自「本程序系统完全实现了医院网站程序的全部功能的前台和后台程序」· ASP 代码 · 共 395 行 · 第 1/2 页

        Else
            sql = sql & " where GroupID=" & GroupID
        End If
    ElseIf InceptType = 2 Then
        inceptUser = Replace(ReplaceBadChar(Request("InceptUser")), ",", "','")
        If inceptUser = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请指定收信人的用户名！</li>"
            Exit Sub
        End If
        sql = sql & " where UserName in ('" & inceptUser & "')"
    ElseIf InceptType = 3 Then
        InceptEmail = Replace(ReplaceBadChar(Request("InceptEmail")), ",", "','")
        If InceptEmail = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请指定收信人的邮箱！</li>"
            Exit Sub
        End If
        sql = sql & " where Email in ('" & InceptEmail & "')"
    End If
    
    Dim PE_Mail
    Set PE_Mail = New SendMail
    Set rs = Server.CreateObject("adodb.recordset")
    rs.Open sql, Conn, 1, 1
    If rs.BOF And rs.EOF Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>暂时没有会员注册！</li>"
    Else
        Response.Write "<li>正在发送中，请等待</li>"
        Do While Not rs.EOF
            If IsValidEmail(rs("Email")) = True Then
                ErrMsg = PE_Mail.Send(rs("Email"), rs("UserName"), Subject, Content, Sendername, Senderemail, Priority)
                If ErrMsg = "" Then
                    i = i + 1
                    Response.Write "<li>成功向 " & rs("UserName") & " 发送邮件！</li>"
                Else
                    j = j + 1
                    Response.Write "<li><font color='red'>向 " & rs("UserName") & " 发送邮件失败！失败原因：" & ErrMsg & "</font></li>"
                End If
                Response.Flush
            Else
                k = k + 1
            End If
            rs.MoveNext
        Loop
        Response.Write "<li>成功发送邮件：" & i & "封</li>"
        If j > 0 Then Response.Write "<li>发送邮件失败：" & j & "封<li>"
        If k > 0 Then Response.Write "<li>未发送邮件：" & j & "封（邮件地址错误）<li>"
    End If
    rs.Close
    Set rs = Nothing
    Set PE_Mail = Nothing
End Sub
Sub ShowJS_SendMail()
    Response.Write "<script language = 'JavaScript'>" & vbCrLf
    Response.Write "function CheckForm(){" & vbCrLf
    Response.Write "  document.myform.Content.value=editor.HtmlEdit.document.body.innerHTML; " & vbCrLf
    Response.Write "  if (document.myform.Content.value==''){" & vbCrLf
    Response.Write "     alert('邮件内容不能为空！');" & vbCrLf
    Response.Write "     editor.HtmlEdit.focus();" & vbCrLf
    Response.Write "     return false;" & vbCrLf
    Response.Write "  }" & vbCrLf
    Response.Write "  return true;  " & vbCrLf
    Response.Write "}" & vbCrLf
    Response.Write "</script>" & vbCrLf
End Sub

Sub ExportMail()
    Response.Write "<br><table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' Class='border'>"
    Response.Write "<form method='post' action='Admin_Maillist.asp?Action=DoExport'>"
    Response.Write "  <tr class='title'>"
    Response.Write "    <td height='22' class='title' colspan=2 align=center><b> 邮件列表批量导出到数据库</b></td>"
    Response.Write "  </tr>"
    Response.Write "  <tr class='tdbg'>"
    Response.Write "    <td width='24%' height='80' align='right'>导出邮件列表到数据库：</td>"
    Response.Write "    <td width='76%' height='80'>"
    Response.Write "      <input name='ExportType' type='hidden' id='ExportType' value='1'>"
    Response.Write "      &nbsp;&nbsp;<font color=blue>导出</font>&nbsp;&nbsp;"
    Response.Write "      <select name='GroupID' id='GroupID'>" & GetUserGroup_Option & "</select>"
    Response.Write "      &nbsp;<font color=blue>到</font>&nbsp;"
    Response.Write "      <input name='ExportFileName' type='text' id='ExportFileName' value='maillist.mdb' size='30' maxlength='200'>"
    Response.Write "      <input type='submit' name='Submit' value='开始'>"
    Response.Write "    </td>"
    Response.Write "  </tr>"
    Response.Write "</form>"
    Response.Write "</table>"
    Response.Write "<br><table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' Class='border'>"
    Response.Write "<form method='post' action='Admin_Maillist.asp?Action=DoExport'>"
    Response.Write "  <tr class='title'>"
    Response.Write "    <td height='22' class='title' colspan=2 align=center><b>邮件列表批量导出到文本</b></td>"
    Response.Write "  </tr>"
    Response.Write "  <tr class='tdbg'>"
    Response.Write "    <td width='24%' height='80' align='right'>导出邮件列表到文本：</td>"
    Response.Write "    <td width='76%' height='80'>"
    Response.Write "      <input name='ExportType' type='hidden' id='ExportType' value='2'>"
    Response.Write "      &nbsp;&nbsp;<font color=blue>导出</font>&nbsp;&nbsp;"
    Response.Write "      <select name='GroupID' id='GroupID'>" & GetUserGroup_Option & "</select>"
    Response.Write "      </select>"
    Response.Write "      &nbsp;<font color=blue>到</font>&nbsp;"
    Response.Write "      <input name='ExportFileName' type='text' id='ExportFileName' value='maillist.txt' size='30' maxlength='200'>"
    Response.Write "      <input type='submit' name='Submit2' value='开始' "
    If ObjInstalled_FSO = False Then Response.Write " disabled"
    Response.Write ">"
    If ObjInstalled_FSO = False Then
        Response.Write "      <font color=red>你的服务器不支持 FSO! 不能使用此功能。</font>"
    End If
    Response.Write "    </td>"
    Response.Write "  </tr>"
    Response.Write "</form>"
    Response.Write "</table>"
End Sub

Sub DoExportMail()
    Dim sql, rs
    Dim ExportType, GroupID, ExportFileName, strResult, i
    ExportType = PE_CLng(Trim(Request("ExportType")))
    GroupID = PE_CLng(Trim(Request("GroupID")))
    ExportFileName = Trim(Request("ExportFileName"))
    If ExportFileName = "" Then
        FoundErr = True
        If ExportType = 1 Then
            ErrMsg = ErrMsg & "<li>请输入要导出的数据库文件名！</li>"
        Else
            ErrMsg = ErrMsg & "<li>请输入要导出的文本文件名！</li>"
        End If
    Else
        ExportFileName = Replace(Replace(ExportFileName, "'", ""), Chr(34), "")
    End If
    
    Set rs = Server.CreateObject("adodb.recordset")
    If GroupID = 0 Then
        sql = "select Email from PE_User where Email like '%@%'"
    Else
        sql = "select Email from PE_User where Email like '%@%' and GroupID=" & GroupID & ""
    End If
    rs.Open sql, Conn, 1, 1

    i = 0
    Select Case ExportType
    Case 1
        Dim tconn, tconnstr
        Set tconn = Server.CreateObject("ADODB.Connection")
        tconnstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(ExportFileName)
        tconn.Open tconnstr
        Do While Not rs.EOF
            tconn.Execute ("insert into [user] (useremail) values ('" & rs(0) & "')")
            rs.MoveNext
            i = i + 1
        Loop
        tconn.Close
        Set tconn = Nothing
        strResult = "操作成功：共导出 " & i & " 个会员Email地址到数据库 " & ExportFileName & "。<a href=" & ExportFileName & ">点击这里将数据库下载回本地</a>"
    Case 2
        Dim filepath, writefile
    
        Application.Lock
        filepath = Server.MapPath("" & ExportFileName & "")
        Set writefile = fso.CreateTextFile(filepath, True)
        Do While Not rs.EOF
            writefile.WriteLine rs(0)
            rs.MoveNext
            i = i + 1
        Loop
        writefile.Close
        Application.UnLock
        strResult = "操作成功：共导出 " & i & " 个会员Email地址到" & ExportFileName & "文件。<a href=" & ExportFileName & ">点击这里将文件下载回本地</a>"
    End Select
    rs.Close
    Set rs = Nothing

    Response.Write "<br><table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' class='border'>"
    Response.Write "  <tr class='title'>"
    Response.Write "    <td height='22' class='title' align=center><b>邮件列表批量导出反馈信息</b></td>"
    Response.Write "  </tr>"
    Response.Write "  <tr class='tdbg'>"
    Response.Write "    <td height='100' align='center'>" & strResult & "</td>"
    Response.Write "  </tr>"
    Response.Write "</table>"
End Sub



Function GetUserGroup_Option()
    Dim strGroup, rsGroup
    strGroup = "<option value='0'>全部会员</option>"
    Set rsGroup = Conn.Execute("select GroupID,GroupName from PE_UserGroup order by GroupType asc,GroupID asc")
    Do While Not rsGroup.EOF
        strGroup = strGroup & "<option value='" & rsGroup(0) & "'>" & rsGroup(1) & "</option>"
        rsGroup.MoveNext
    Loop
    rsGroup.Close
    Set rsGroup = Nothing
    GetUserGroup_Option = strGroup
End Function
%>