|
这是整个邮件列表程序服务端，由管理者运行：
文件名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("没有设置正确参数。")
submsginfo(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>
<TDBGCOLOR="CCE6FF">
<B>请选择一个邮件列表文件</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%= fileselect %>
</TD>
</TR>
<TR>
<TDBGCOLOR="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>
<TDBGCOLOR="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>
<TDBGCOLOR="CCE6FF">
<B>请选择要发送的邮件列表</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%= fileselect %>
</TD>
</TR>
<TR>
<TDBGCOLOR="CCE6FF">
<B>请选择要发送的信件</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%=ltrselect%>
</TD>
</TR>
<TR>
<TDBGCOLOR="CCE6FF">
<B>从</B>
</TD>
<TD BGCOLOR="CCE6FF">
<INPUT TYPE="TEXT" NAME="from" SIZE=25 MAXLENGTH=100 VALUE="<%=DEFAULT_EMAIL%>">
</TD>
</TR>
<TR>
<TDBGCOLOR="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>
<TDBGCOLOR="99FF99" ALIGN=CENTER><B>检查<BR>删除</B></TD>
<TD BGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>电子邮件地址</B></TD>
<TDBGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>IP 地址</B></TD>
<TDBGCOLOR="99FF99" ALIGN=CENTERVALIGN=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
functionSendMail (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
%>
|
