CDONTS ændres til ASPMail
Hejsa.Det er nok umuligt, men er der en der kan få denne nyhedsliste til at sende med ASPMail i stedet for CDONTS som den gør nu ??
/snoezel
<%
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' mailadmin.asp: subscription e-mail collector with subscribe
' and unsubscribe features.
' Release 0.99 on 06/20/99
' (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 use this
' script.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' SECURITY NOTICE ' SECURITY NOTICE ' SECURITY NOTICE '''''''''''
'
' This script has NO security features built in. Please
' consult the README.TXT file for information on securing
' this script from abuse.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' USER CONFIGURATION SECTION ''''''''''''''''''''''''''''''''''
' BASEDIR is the full directory path to where you will store your
' mail list (lst) files and letter (ltr) files. Be certain that
' the script can write to this directory
Dim debug
debug = false
BASEDIR = Server.MapPath("maillist")
Forreading = 1
Forwriting = 2
Forappending = 8
delimiter = "|" ' Pipe is delimiter
' SCRIPT_URL is the URL (not path) of this script.
SCRIPT_URL="mailadmin.asp"
' MailAdmin use CDO NTS to send out mail
' $DEFAULT_EMAIL is used as the default "from" e-mail address
' for your mailings. You can type over this value when sending
' mail.
DEFAULT_EMAIL="newsletter@freeasp.com"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
cpr = ""
setup
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("Called without proper options set")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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>FreeASP"s MailAdmin </H2>
<TABLE WIDTH=500 BORDER=1 CELLPADDING=5 CELLSPACING=0>
<TR>
<TD BGCOLOR="99FF99">
 <BR>
<FONT FACE="ARIAL">
Welcome to FreeASP's Maillist Subscription Manager Control
Panel! The forms below will allow you to manage your
mailing lists, create and edit your letters, and send
out mailings.
<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>Maintain Mailing Lists</B></FONT></CENTER>
<FONT SIZE=-1 FACE="ARIAL">
This form allows you to edit the mailing lists collected
by your FreeASP Subscription Manager. Please use the selection
bar to pick the mailing list file you wish to review.
You may also enter an e-mail address, or part of one into
the search box and the script will return all all matching
records. If you want to select the entire contents of a file,
just leave the search box empty.
Click on GO-GET-EM! when ready.
</FONT>
</TD>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Please select a list file</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%= fileselect %>
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Partial address to search on</B>
</TD>
<TD BGCOLOR="CCE6FF">
<INPUT TYPE="TEXT" NAME="search" SIZE=30 MAXLENGTH=100 VALUE="">
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF"><B>Fire when ready</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>Maintain Letters</B></FONT></CENTER>
<FONT SIZE=-1 FACE="ARIAL">
To create a new form letter file, select the YES button for
<I>Create new letter</I>. To edit an existing letter, simply
pull down on the selector bar and pick the desired letter file.
Click on DO-IT! when ready.
</FONT>
</TD>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Please select a letter file</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%= ltrselect %>
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF"><B>Create a new letter?</B>
</TD>
<TD BGCOLOR="CCE6FF">
<INPUT TYPE="radio" NAME="newfile" VALUE="NO" checked>NO
<INPUT TYPE="radio" NAME="newfile" VALUE="YES">YES
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF"><B>Fire when ready</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>Send out Mailing</B></FONT></CENTER>
<FONT SIZE=-1 FACE="ARIAL">
This form allows you to send out e-mail to your subscribers.
Use the selector bars to pick your mailing list and form letter
file. You may also enter a subject line and return e-mail address.
Of course- <B>be very careful to pick the correct letter and
list before sending!</B> As the mail is being sent, you will
see each address and it"s status displayed. In the event the
script is interrupted, you will know where it left off.
Click on MAIL-EM! when ready.
</FONT>
</TD>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Please select a LIST file</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%= fileselect %>
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Please select a LETTER file</B>
</TD>
<TD BGCOLOR="CCE6FF">
<%=ltrselect%>
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF">
<B>From</B>
</TD>
<TD BGCOLOR="CCE6FF">
<INPUT TYPE="TEXT" NAME="from" SIZE=25 MAXLENGTH=100 VALUE="<%=DEFAULT_EMAIL%>">
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF">
<B>Subject Line</B>
</TD>
<TD BGCOLOR="CCE6FF">
<INPUT TYPE="TEXT" NAME="subject" SIZE=25 MAXLENGTH=100 VALUE="">
</TD>
</TR>
<TR>
<TD BGCOLOR="CCE6FF"><B>Fire when ready</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("No letter file or mail list file selected")
end if
if Request.Form("from") = "" or Request.Form("from") = "" then
error_report("The from e-mail is missing or invalid")
end if
lettext=""
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(BASEDIR & "\" & Request.Form("lfilename"), ForReading, false)
lettext = f.readall
'Open the maillist
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>Mail being sent ot subscribed members of " & Request.Form("filename") & vbCrlf
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 & 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
%>
