这是整个邮件列表程序服务端，由管理者运行：
文件名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 & "
" & vbCrlf
end if
end sub

sub query_form ()

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

%>

<%
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 "

邮件正在发送给下列成员" & 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 "操作完成！"
    on error goto 0
end sub

'''''''''''''''''''''''''''''''''
sub get_list ()
%>
  












<%
    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)
                %>






            <% end if
        next
    end if
    %>



  

    
EDIT MAILING LIST: <%= Request.Form("filename") %>

    回管理界面
    

  
  
检查
删除
  
电子邮件地址
  
IP 地址
  

    同意
日期
  
  
   
<%= singlemail(0) %>
   
<%= singlemail(1) %>
   
<%= singlemail(2) %>
   
  

     
    ">
     按 
     
    将删除所有选中地址
    

    <%= cpr %>
  



<%
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 = "" & vbCrlf
    for each f in fc
        if instr(1, f.name, exten, vbtextcompare) > 0 then
            fs = fs & "" & f.name & vbCrlf
        end if
    next
    fs = fs & ""
    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 = ""
        header="
EDIT LETTER file: " & Request.Form("lfilename") & "
"
    else
        header = "
CREATE LETTER file: " & vbCrlf & _
        " 
" & vbCrlf & _
        "" & vbCrlf
    end if


%>











  

    <%= header %>
    回管理页面
    

  

<%= lettext%>

  

     
     <%=namehide%>
     按 
     
    将保存信件
    

    <%= cpr %>
  



<%
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)
%>


发生以下错误：

<%=errormsg%>


<%
    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
%>