以前收集的一些资料—一个使用CDO的邮件列表ASP程序(管理端)

这是整个邮件列表程序服务端，由管理者运行：
文件名mailadmin.asp:
<%
使用这段代码时，请将所有的邮件列表（后缀为lst）文件和
信件文件(后缀为ltr)都放到根目录basedir中，并保证对给目录有写的权限

dim debug
debug = false

basedir = server.mappath("/tmp/maillist")

forreading = 1
forwriting = 2
forappending = 8
分隔字符
delimiter = "|"

本代码的url注意不是路径
script_url="mailadmin.asp"

代码中使用了cdo nts来发送邮件
$default_email是来保存默认的寄信人地址的变量（可根据自己情况进行修改）

default_email="yourname@yourmailserver"

cpr = ""

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) <> 0 and _
    strcomp(request.servervariables("query_string"), "", vbtextcompare) = 0 then
    query_form
    response.end
end if

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) = 0 and _
    request.form("action") = "list" then
    get_list
    response.end
end if

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) = 0 and _
    request.form("action") = "sendmail" then
    send_mail
    response.end
end if

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) = 0 and _
    request.form("action") = "postletter" then
    post_letter
    response.end
end if

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) = 0 and _
    request.form("action") = "edit" then
    ltr_editor
    response.end
end if

if strcomp(request.servervariables("request_method"), "post", vbtextcompare) = 0 and _
    request.form("action") = "purge" then
    purge_names
    response.end
end if

error_report("没有设置正确参数。")

sub    msginfo(str)
    if debug then
        response.write str & "<br>" & vbcrlf
    end if
end sub

sub query_form ()

fileselect = get_files("filename","lst")
ltrselect = get_files("lfilename","ltr")

%>

<center>
<table width=550 cellpadding=2 border=1 bgcolor="ffff00">
  <tr>
   <td align=center>
     <h2>邮件列表管理界面</h2>
     <table width=500 border=1 cellpadding=5 cellspacing=0>
      <tr>
      <td bgcolor="99ff99">
       &nbsp<br>
      <font face="arial">
      欢迎来到邮件列表示例，使用它可以给你的列表用户发送信件。
      <br>&nbsp
       </font>
      </td>
      </tr>

      <tr>
      <td>

     <form action="<%= script_url %>" method="post">
     <table width=500 bgcolor="cccccc" border=1 cellpadding=5 cellspacing=0>
      <tr>
       <td colspan=2 bgcolor="cccccc">
        <center><font size=+1><b>维护邮件列表</b></font></center>
      <font size=-1 face="arial">
    这个form是用来维护你的邮件列表的       
    </font>
       </td>
      <tr>
      <td  bgcolor="cce6ff">
        <b>请选择一个邮件列表文件</b>
      </td>
      <td bgcolor="cce6ff">
     <%= fileselect %>
      </td>
     </tr>
      <tr>
      <td  bgcolor="cce6ff">
        <b>根据邮件地址查找</b>
      </td>
      <td bgcolor="cce6ff">
       <input type="text" name="search" size=30 maxlength=100 value="">
      </td>
     </tr>
     <tr>
      <td bgcolor="cce6ff"><b>确定</b>
      </td>
      <td bgcolor="cce6ff">
        <input type="submit" value="go getem!">
        <input name="action" type="hidden" value="list">
      </td>
      </tr>
      </table>
     </form>

     <form action="<%=script_url%>" method="post">
     <table width=500 bgcolor="cccccc" border=1 cellpadding=5 cellspacing=0>
      <tr>
       <td colspan=2 bgcolor="cccccc">
        <center><font size=+1><b>维护信件</b></font></center>
      <font size=-1 face="arial">
      如果要新建一个信件，请选择“是”。
      <i>是</i>. 如果是选择一个已经存在的信件请从下拉框中选择
       </font>
       </td>
      <tr>
      <td  bgcolor="cce6ff">
        <b>请选择信件</b>
      </td>
      <td bgcolor="cce6ff">
     <%= ltrselect %>
      </td>
     </tr>
     <tr>
      <td bgcolor="cce6ff"><b>新建一封信？</b>
      </td>
      <td bgcolor="cce6ff">
        <input type="radio" name="newfile" value="no" checked>否
        <input type="radio" name="newfile" value="yes">是
      </td>
      </tr>

     <tr>
      <td bgcolor="cce6ff"><b>确定</b>
      </td>
      <td bgcolor="cce6ff">
        <input type="submit" value="do it!">
        <input name="action" type="hidden" value="edit">
      </td>
      </tr>
      </table>
     </form>

     <form action="<%=script_url%>" method="post">
     <table width=500 bgcolor="cccccc" border=1 cellpadding=5 cellspacing=0>
      <tr>
       <td colspan=2 bgcolor="cccccc">
        <center><font size=+1><b>发送邮件</b></font></center>
      <font size=-1 face="arial">
      千万小心，在选择了正确的信件后再发送哦。
       </font>
       </td>
      <tr>
      <td  bgcolor="cce6ff">
        <b>请选择要发送的邮件列表</b>
      </td>
      <td bgcolor="cce6ff">
     <%= fileselect %>
      </td>
     </tr>
      <tr>
      <td  bgcolor="cce6ff">
        <b>请选择要发送的信件</b>
      </td>
      <td bgcolor="cce6ff">
     <%=ltrselect%>
      </td>
     </tr>

      <tr>
      <td  bgcolor="cce6ff">
        <b>从</b>
      </td>
      <td bgcolor="cce6ff">
       <input type="text" name="from" size=25 maxlength=100 value="<%=default_email%>">
      </td>
     </tr>

      <tr>
      <td  bgcolor="cce6ff">
        <b>标题</b>
      </td>
      <td bgcolor="cce6ff">
       <input type="text" name="subject" size=25 maxlength=100 value="">
      </td>
     </tr>

     <tr>
      <td bgcolor="cce6ff"><b>确定</b>
      </td>
      <td bgcolor="cce6ff">
        <input type="submit" value="mailem!">
        <input name="action" type="hidden" value="sendmail">
      </td>
      </tr>
      </table>
     </form>

     </td>
     </tr>
     </table>
     <%= cpr %>
   </td>
  </tr>
</table>
</center>

<%
end sub

sub send_mail ()
    on error resume next
    dim i, j, maillist, tolist, start, finish, last, total, mailresult
    dim f, fso, lettext
    
    if request.form("filename") = "" or request.form("lfilename") = "" then
        error_report("没有选择邮件或则邮件列表文件。")
    end if
    if request.form("from") = "" or request.form("from") = "" then
        error_report("发信人地址错误。")
    end if
        
    lettext=""
    set fso = server.createobject("scripting.filesystemobject")
    set f = fso.opentextfile(basedir & "\" & request.form("lfilename"), forreading, false)
    lettext = f.readall
    打开邮件列表
    f.close
    set f = fso.opentextfile(basedir & "\" & request.form("filename"), forreading, false)
    maillist = split(f.readall, vbcrlf, -1, vbtextcompare)
    set f = nothing
    set fso = nothing
    on error goto 0
    if not isarray(maillist) then
        exit sub
    end if
    
    last = ubound(maillist) – 1
    response.write "<pre>邮件正在发送给下列成员" & request.form("filename") & vbcrlf
    response.write "使用的邮件是 " & request.form("lfilename") & vbcrlf & vbcrlf
    for i = 0 to last
        singlemail = split(maillist(i), delimiter, -1, vbtextcompare)
        if mailpattern(singlemail(0)) then
            mailresult = sendmail(request.form("from"), singlemail(0), _
                request.form("subject"), lettext, "", "", 1)
            if mailresult then
                response.write singlemail(0) & ": 已经发送成功" & vbcrlf
            else
                response.write singlemail(0) & ": 发送失败"
            end if
        end if
    next
    
    response.write "<b>操作完成！</b>"
    on error goto 0
end sub

sub get_list ()

%>
  

<form action="<%=script_url%>" method="post">
<center>
<table cellpadding=2 border=1 bgcolor="cce6ff">
<tr>
  <td colspan=5 align=center bgcolor="ffff00">
    <h2>edit mailing list: <%= request.form("filename") %></h2>
    <a href="<%= script_url %>">回管理界面</a>
    <p>
  </td>
</tr>
<tr>
  <td  bgcolor="99ff99" align=center><b>检查<br>删除</b></td>
  <td bgcolor="99ff99" align=center valign=middle><b>电子邮件地址</b></td>
  <td  bgcolor="99ff99" align=center valign=middle><b>ip 地址</b></td>
  <td  bgcolor="99ff99" align=center  valign=middle colspan=2>
    <b>同意<br>日期</b></td>
</tr>
<%
    dim f, fso, fc, maillist, singlemail, i, start, finish, last
    set fso = server.createobject("scripting.filesystemobject")
    set f = fso.opentextfile(basedir & "\" & request.form("filename"), forreading, true)
    on error resume next
    maillist = split(f.readall, vbcrlf, -1, vbtextcompare)
    on error goto 0
    f.close
    set f = nothing
    set fso = nothing
    if isarray(maillist) then
        last = ubound(maillist) – 1
        for i = 0 to last
            if instr(1, maillist(i), request.form("search"), vbbinarycompare) > 0 or _
                request.form("search") = "" then
                singlemail = split(maillist(i), delimiter, -1, vbtextcompare)
                %>
  <tr>
  <td align=center><input type="checkbox" name="thisname" value="<%= singlemail(0) %>"></td>
   <td><%= singlemail(0) %></td>
   <td><%= singlemail(1) %></td>
   <td><%= singlemail(2) %></td>
   </tr>
            <% end if
        next
    end if
    %>

<tr>
  <td colspan=5 bgcolor="99ff99" align=center>
     <input name="action" type="hidden" value="purge">
    <input type="hidden" name="filename" value="<%= request.form("filename") %>">
     <b>按
    <input type="submit" value="do it!">
    将删除所有选中地址</b>
    <p>
    <%= cpr %>
  </td>
</tr>
</table>
</form>
</center>

<%

end sub

sub purge_names ()
    dim f, fso, i, start, last, finish, maillist, singlemail, killlist
    dim deleteok
    deleteok = false
    last = request.form("thisname").count
    if last < 1 then
        response.redirect request.servervariables("http_referer")
    end if
    set fso = server.createobject("scripting.filesystemobject")
    set f = fso.opentextfile(basedir & "\" & request.form("filename"), forreading, true)
    maillist = split(f.readall, vbcrlf, -1, vbtextcompare)
    f.close
    last = ubound(maillist) – 1
    msginfo("最后的索引为" & last)
    application.lock
    set f = fso.opentextfile(basedir & "\" & request.form("filename"), forwriting, true)
    for i = 0 to last
        msginfo("订户" & i & " is " & maillist(i))
        singlemail = split(maillist(i), delimiter, -1, vbtextcompare)
        for j = 1 to request.form("thisname").count
            msginfo("请求的这个名字" & request.form("thisname")(j))
            if strcomp(singlemail(0), request.form("thisname")(j), vbbinarycompare) = 0 then
                msginfo("删除" & singlemail(0))
                deleteok = true
            end if
        next
        if not deleteok then
            f.writeline maillist(i)
        end if
    next
    f.close
    set f = nothing
    application.unlock
    set fso = nothing
    response.redirect script_url
end sub

function get_files (filename, exten)
    dim f, fso, fc, fs
    set fso = server.createobject("scripting.filesystemobject")
    set f = fso.getfolder(basedir)
    set fc = f.files
    fs = "<select name=""" & filename & """>" & vbcrlf
    for each f in fc
        if instr(1, f.name, exten, vbtextcompare) > 0 then
            fs = fs & "<option value=""" & f.name & """>" & f.name & vbcrlf
        end if
    next
    fs = fs & "</select>"
    get_files = fs

end function

sub ltr_editor ()
    dim f, fso, i, start, last, finish, letttext, alllines
    
    if request.form("newfile") = "no" then
        lettext = ""
        on error resume next
        set fso = server.createobject("scripting.filesystemobject")
        set f = fso.opentextfile(basedir & "\" & request.form("lfilename"), forreading, true)
        lettext = f.readall
        f.close
        on error goto 0
        namehide = "<input type=""hidden"" name=""lfilename"" value=""" & request.form("lfilename") & """>"
        header="<h2>edit letter file: " & request.form("lfilename") & "</h2>"
    else
        header = "<h2>create letter file: " & vbcrlf & _
        "<input type=""text"" name=""lfilename"" size=15 maxlength=15> </h2>" & vbcrlf & _
        "<input name=""newfile"" type=""hidden"" value=""yes"">" & vbcrlf
    end if

%>

<form action="<%= script_url %>" method="post">
<center>
<table cellpadding=2 border=1 bgcolor="cce6ff">
<tr>
  <td colspan=5 align=center bgcolor="ffff00">
    <%= header %>
    <a href="<%= script_url %>">回管理页面</a>
    <p>
  </td>
</tr>
<tr>
<td>
<textarea name="lettext" wrap=off rows=10 cols=70><%= lettext%></textarea>
</td>
</tr>

<tr>
  <td colspan=5 bgcolor="99ff99" align=center>
     <input name="action" type="hidden" value="postletter">
     <%=namehide%>
     <b>按
    <input type="submit" value="do it!">
    将保存信件</b>
    <p>
    <%= cpr %>
  </td>
</tr>
</table>
</form>
</center>

<%
end sub

sub post_letter ()
    dim f, fso, fn
    set fso = server.createobject("scripting.filesystemobject")
    if request.form("newfile") = "yes" then
        fn = request.form("lfilename") & ".ltr"
    else
        fn = request.form("lfilename")
    end if
    set f = fso.opentextfile(basedir & "\" & fn, forwriting, true)
    f.write request.form("lettext")
    f.close
    set f = nothing
    set fso = nothing
    response.redirect script_url
    
end sub    

sub error_report (errormsg)
%>

<center>
<h2>
<b>发生以下错误：</b>
<p>
<%=errormsg%>
</h2>
</center>

<%
    response.end
end sub

function mailpattern(email)
    dim i,j, first, last, char
    
    i = instr(1, email, "@", vbtextcompare)
    if i > 0 and i < len(email) then
        first = left(email, i – 1)
        last = mid(email, i+1, len(email))
    else
        mailpattern = false
        exit function
    end if
    i = 0
    do until i = len(first)
        i = i + 1
        char = mid(first, i, 1)
         如果字符不在 [.z-aa-z0-9_-]中
        if asc(char) <> 46 and (asc(46) < 48 or asc(char) > 57) and _
        (asc(char) < 65 or asc(char) > 90) and (asc(char) < 97 or asc(char) > 122) then
            mailpattern = false
            exit function
        end if
    loop
    i = 0
    do until i = len(last)
        i = i + 1
        char = mid(last, i, 1)
         如果字符不在 [.z-aa-z0-9_-]中
        if asc(char) <> 46 and (asc(46) < 48 or asc(char) > 57) and _
        (asc(char) < 65 or asc(char) > 90) and (asc(char) < 97 or asc(char) > 122) then
            mailpattern = false
            exit function
        end if
    loop
    mailpattern = true

end function

function  sendmail (sfrom, sto, ssubject, sbody, scc, sbcc, ipriority)
    on error resume next
    dim mycdo
    set mycdo = server.createobject("cdonts.newmail")

    if isobject(mycdo) then
        mycdo.from = sfrom
        mycdo.to = sto
        mycdo.subject = ssubject
        mycdo.body = sbody
        mycdo.importance = ipriority
        mycdo.cc = scc
        mycdo.bcc = sbcc
        mycdo.send
        set mycdo = nothing

        sendmail = true
    else
        sendmail = false
    end if
    on error goto 0
end function

%>