mailadmin.asp

一套简单的ASP邮件列表

	Response.Write "using letter " & 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) & ": SENT" & vbCrlf
			else
				Response.Write singlemail(0) & ": MAIL NOT SENT"
			end if
		end if
	next
	
	Response.Write "<b>Processing completed!</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 %>">Return to Management Page</A>
    <P>
  </TD>
</TR>
<TR>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER><B>Check to<BR>Delete</B></TD>
  <TD BGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>E-Mail Address</B></TD>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>IP Address</B></TD>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER  VALIGN=MIDDLE COLSPAN=2>
    <B>Subscribed<BR>Date &amp Time</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>Pressing 
    <INPUT TYPE="submit" VALUE="DO IT!"> 
    will delete all checked addresses!</B>
    <P>
    <%= cpr %>
  </TD>
 </TR>
</TABLE>
 </FORM>
</CENTER>

<%

end sub

sub setup ()

cpr = "<CENTER><FONT SIZE=1>Another FREE Script from<BR>" & vbCrlf & _
	"<A HREF=""http://www.FreeASP.com/"">FreeASP.Com</A></FONT></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("The last index is " & last)
	Application.Lock
	Set f = fso.OpenTextFile(BASEDIR & "\" & Request.Form("filename"), ForWriting, true)
	for i = 0 to last
		msginfo("The subscriber " & i & " is " & maillist(i))
		singlemail = split(maillist(i), delimiter, -1, vbtextcompare)
		for j = 1 to Request.Form("thisname").Count
			msginfo("Request this name is " & Request.Form("thisname")(j))
			if strcomp(singlemail(0), Request.Form("thisname")(j), vbBinaryCompare) = 0 then
				msginfo("Delete " & 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 %>">Return to Management Page</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>Pressing 
    <INPUT TYPE="submit" VALUE="DO IT!"> 
    will save your letter file</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>The following error has occurred:</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)
		' if char is not in [.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)
		' if char is not in [.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

' This function uses the CDO for NTS object to send an eMail message.
'
'  Parameters:
' 	sFrom - address of sender (string)
'	sTo - address of recipient (string)
' 	sSubject - subject for message (string)
'	sBody - message text (string)
' 	sCc - address of carbon copy recipient
' 	sBCc - address of blind carbon copy recipient
' 	iPriority - priority of message (integer; 0 = low; 1 = normal; 2 = high)
'  Note: To specify multiple recipients in the sTo, sCc or sBcc parameters, 
'  seperate the recipients addresses with a semicolon.

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

%>