subscribe.asp

一套简单的ASP邮件列表

<%

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' subscribe.asp: subscription e-mail collector with subscribe
' and unsubscribe features.
' Release 0.99 on 6/20/1999
' (C) 1999 FreeASP.Com, Inc. This program is freeware and may 
' be used at no cost to you (just leave this notice intact). 
' Feel free to modify, hack, and play  with this script. 
' It is provided AS-IS with no warranty of any kind.                
' We also cannot assume responsibility for either any programs      
' provided here, or for any advice that is given since we have no   
' control over what happens after our code or words leave this site.
' Always use prudent judgment in implementing any program- and      
' always make a backup first!                                       
' We also appreciate if you can let us know your site url that uses
' this script (email to [e-mail])
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' When calling the script, you must provide the following INPUTs
'
'   datafile  (name of file that will contain the addresses.)
'   email  (the e-mail address of the person subscribing/unsubscribing
'   action (subscribe or unsubscribe)

'''' USER CONFIGURATION SECTION ''''''''''''''''''''''''''''''''''

' set BASEDIR to the directory that will hold your letter and
' mailling list files. Be certain that the script has permission
' to write to this directory. This must be set to the same value
' you declare in mailadmin.asp

BASEDIR= Server.MapPath("/tmp/maillist")

'VB constants
Forreading = 1
Forwriting = 2
Forappending = 8
' remove the ' mark before okaydomains to restrict subscription
' requests to your web site. This prevents others from calling
' your script from elsewhere. If you encourage others to offer
' your newsletter from their sites, do NOT remove the ' mark.

'   @okaydomains=("http://mydomain.com", "http://www.mydomain.com")     
' okdomains = split("http://www.freeasp.com|http://freeasp.com", -1, vbtextcompare)

' delimiter is the special character that is used to separate the
' items of information about each e-mail address. To use the TAB
' character, uncomment (remove the ' mark) the line that says TAB
' and place a ' mark at the start of the line that says PIPE.

delimiter = "|" ' PIPE
linedelimiter = vbCrlf ' Enter & Linefeed character
'   delimiter= vbTab 'TAB

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

valid_page

return_to = Request.ServerVariables("HTTP_REFERER")
the_date = date()
ip_addr = Request.ServerVariables("REMOTE_ADDR")
datafile = Request.Form("datafile") & ".lst"
email = Request.Form("email")
action = Request.Form("action")

if datafile = "" then
	Response.Write "Configuration Error: No datafile specified.<br>"
	Response.End
end if

if action = "" then
	Response.Write "Configuration Error: No action specified.<br>"
	Response.End
end if

if not mailpattern(email) then
	bad_email
end if
   
write_data

thank_you

%>

<%

sub thank_you ()
	if action = "unsubscribe" then
		whichaction = "removed from"
	else
		whichaction = "added to"
	end if
%>

<CENTER>
&nbsp<P>
&nbsp<P>
<TABLE WIDTH="510" BORDER="1" CELLPADDING="3" BGCOLOR="'0066cc">
 <TR>
 <TD>
  <TABLE WIDTH="500" BORDER="1" CELLPADDING="5" BGCOLOR="'99CCFF">
   <TR>
    <TD>
      <CENTER>
      <FONT FACE="ARIAL">
      &nbsp
      <P>
      <H1>Thank You -)</H1>
      <B>Your e-mail address has been <%= whichaction %> our mailing list.<BR>
      Please click on the link below to return <BR>
      to the page you were last on.
      <P>
      <A HREF="<%= return_to%>"><B><%= return_to %></B></A></B>
      <P>
      <FONT SIZE=1><B>Another FREE script from 
      <A HREF="http://www.freeasp.com/">FreeASP.Com</A></B><BR>
      Will be available for download soon!</FONT>
      <P>
      &nbsp
    </TD>
   </TR>
  </TABLE>
  </TD>
 </TR>
</TABLE>
</CENTER>


<%
end sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub write_data ()
	Dim current, fso, f, maillist, singlemail, found, last, i, j, start
	on error resume next
	Set fso = Server.CreateObject("Scripting.FilesystemObject")
	Set f = fso.OpenTextFile(BASEDIR & "\" & datafile, ForReading, true)
	maillist = split(f.readall, linedelimiter, -1, vbtextcompare)
	f.close
	if not isarray(maillist) then
		if action = "subscribe"  then
			Set f = fso.OpenTextFile(BASEDIR & "\" & datafile, ForAppending, true)
			f.write email & delimiter & ip_addr & delimiter & formatdatetime(date(), 1) & vbCrlf
			f.close
		end if
	else
		Application.Lock
		Set f = fso.OpenTextFile(BASEDIR & "\" & datafile, ForWriting, true)
		last = Ubound(maillist) - 1
		for	i = 0 to last
			singlemail = split(maillist(i), delimiter, -1, vbtextcompare)
			if strcomp(email, singlemail(0), vbBinaryCompare) <> 0 then
				f.write maillist(i) & vbCrlf
			end if
		next
		if action = "subscribe" then
			f.write email & delimiter & ip_addr & delimiter & formatdatetime(date(), 1) & vbCrlf
		end if
		f.close		
		Application.UnLock
	end if
	Set f = nothing
	Set fso = nothing
end sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub bad_email ()
%>
<FONT SIZE="+1">
<B>
SORRY! Your request could not be processed because of an
improperly formatted e-mail address. Please use your browser"s 
back button to return to the form entry page.
</B>
</FONT>

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub valid_page ()
	dim i, j, start, finish
	if not isarray(okdomain) then
		exit sub
	end if
	domain_ok = false
	
	RF = Request.ServerVariables("HTTP_REFERER")
	
	for i = 0 to Ubound(okdomain)
		if instr(1, RF, okdomain(i), vbtextcompare) > 0 then
			domain_ok = true
		end if
	next
	if not domain_ok then
		Response.Write "Sorry....Cant run from here.<br>"
		Response.End
	end if
	
end sub
%>