以前收集的一些资料---一个使用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">
        <BR>
      <FONT FACE="ARIAL">
      欢迎来到邮件列表示例，使用它可以给你的列表用户发送信件。
      <BR> 
       </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, sBclearcase/" target="_blank" >cc, 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

%>

原文转自：http://www.ltesting.net