一个使用cdo的邮件列表asp程序.txt

用纯ＡＳＰ代码实现图片上传并存入数据库中

    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

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

%>



以前收集的一些资料---一个使用CDO的邮件列表ASP程序(用户端)    


--------------------------------------------------------------------------------

 【batman】 于 99-8-7 下午 02:52:26 加贴在 Joy ASP ↑：


这是用户使用的页面和实现的asp
用户页面：subscrib.html
<BODY BGCOLOR="#ffffff">
<CENTER>
<P>
<table WIDTH=125 BORDER=0 CELLSPACING=0>
<tr> 
  <td width="100%" valign="top" align="middle" bgcolor="#0066cc" 
    height="20"><strong><font color="#ffffff" size="2" face="Verdana, Arial">
<A NAME="NEWSLETTER">
    信件</font></strong></A></td>
</tr>
<tr> 
<td valign="top" bgcolor="#99ccff" width="100%" >
  <font face="Arial, Helvetica" size="1"><font color="#000000">
  <FORM ACTION="subscribe.asp" METHOD="post">
  <INPUT TYPE="radio" NAME="action" VALUE="subscribe" checked>订阅邮件<BR>
  <INPUT TYPE="radio" NAME="action" VALUE="unsubscribe">取消订阅<BR>
  <CENTER>
  <INPUT NAME="email" VALUE="your-email" SIZE=10 MAXLENGTH=100 ><BR>
  <INPUT TYPE="hidden" NAME="datafile" VALUE="subscribe">
  <INPUT TYPE="submit" VALUE="DO IT!"><BR>
  快来加入邮件列表。 
  </CENTER></FORM>
           </font>
           </font>
   </td>
</tr>
</table>
</BODY></HTML>
文件名为subscrib.asp
<%
BASEDIR= Server.MapPath("/tmp/maillist")

Forreading = 1
Forwriting = 2
Forappending = 8

delimiter = "|" 
linedelimiter = vbCrlf 

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 "配置出错: 没有选择数据文件<br>"
    Response.End
end if

if action = "" then
    Response.Write "配置出错<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 = "移走"
    else
        whichaction = "添加到"
    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>谢谢 -)</H1>
      <B>你的电子邮件地址已经被 <%= whichaction %> 邮件列表.<BR>
      请选择下面的连接返回上一个页面。 <BR>
      <P>
      <A HREF="<%= return_to%>"><B><%= return_to %></B></A></B>
      <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>
抱歉，你还有一些重要的信息没有填写，请返回重新填写。
</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 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 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 "对不起，不能够在这运行。<br>"
        Response.End
    end if
    
end sub
%>