一个使用cdo的邮件列表asp程序(管理端).txt

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

            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>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER><B>检查<BR>删除</B></TD>
  <TD BGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>电子邮件地址</B></TD>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER VALIGN=MIDDLE><B>IP 地址</B></TD>
  <TD  BGCOLOR="99FF99" ALIGN=CENTER  VALIGN=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

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

%>