用asp发送邮件程序

Dim NewCloud_Ads
Dim Rs
Dim SQL
Dim NowStats
Dim HtmlTitle
Dim Style_CSS
Dim HtmlTempStr
Dim TempTopStr
Dim TempFootStr
Dim boardtype
Dim FoundErr
Dim ErrMsg
Dim ID
Dim SucMsg
Dim topic
Dim mailbody
Dim announce
Dim useremail
ArticlEndMail
CloseConn
Public Sub ArticlEndMail()
On Error Resume Next
Newasp.LoadTemplates ("")
Set NewCloud_Ads = Server.CreateObject("NewCloudAsp.Admin_Adcolumn")
Set Rs = Server.CreateObject("adodb.recordset")
NowStats = "邮件打包发送"
HtmlTitle = "邮件打包发送"
TempTopStr = Newasp.mainhtml(0) & Newasp.mainhtml(1) & Newasp.mainhtml(2) & Newasp.mainhtml(3)
TempFootStr = Newasp.mainhtml(4)
Style_CSS = Replace(Replace(Newasp.Style_CSS, "{$SetupDir}", Newasp.SetupDir), "{$PicUrl}", Newasp.TempDir)
HtmlTempStr = TempTopStr
HtmlTempStr = Replace(HtmlTempStr, "{$NavMenu}", Newasp.SortingMenu)
HtmlTempStr = Replace(HtmlTempStr, "{$Width}", Newasp.mainset(0))
HtmlTempStr = Replace(HtmlTempStr, "{$Style_CSS}", Style_CSS)
If CInt(Newasp.Setting(5)) = 0 Then
HtmlTempStr = Replace(HtmlTempStr, "{$TopMeun}", Newasp.mainset(9))
Else
HtmlTempStr = Replace(HtmlTempStr, "{$TopMeun}", Newasp.mainset(10))
End If
HtmlTempStr = Replace(HtmlTempStr, "{$NowStats}", NowStats)
HtmlTempStr = Replace(HtmlTempStr, "{$Title}", HtmlTitle)
HtmlTempStr = Replace(HtmlTempStr, "{$Adcolumn(0)}", NewCloud_Ads.RunScriptAds(7))
HtmlTempStr = Replace(HtmlTempStr, "{$Adcolumn(1)}", NewCloud_Ads.BannerAds(7))
HtmlTempStr = Replace(HtmlTempStr, "{$Adcolumn(2)}", NewCloud_Ads.AdsColumn(7, 2))
HtmlTempStr = Replace(HtmlTempStr, "{$Adcolumn(3)}", NewCloud_Ads.AdsColumn(7, 3))
Response.Write HtmlTempStr
TempFootStr = Replace(TempFootStr, "{$FootMeun}", Newasp.mainset(11))
TempFootStr = Replace(TempFootStr, "{$Width}", Newasp.mainset(0))
TempFootStr = Replace(TempFootStr, "{$Adcolumn(4)}", NewCloud_Ads.ScriptFloatAds(7))
TempFootStr = Replace(TempFootStr, "{$Adcolumn(5)}", NewCloud_Ads.ScriptFixedAds(7))
Response.Write "

Response.Write Newasp.mainset(0)
Response.Write """ class=TableBorder border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""Border"">"
Response.Write " " Response.Write " 邮件打包发送" Response.Write " "
Response.Write " " Response.Write " " FoundErr = False ID = CLng(Request("ID")) If Not IsNumeric(ID) And ID"" then Response.write"错误的系统参数!ID必须是数字" Exit Sub Response.End End If If ID = "" Then FoundErr = True ErrMsg = ErrMsg + "" + "请指定相关文章" Exit Sub End If Set Rs = Server.CreateObject("adodb.recordset") If FoundErr Then Call errormsg Else Call showPage End If Response.Write "" Response.Write " " Response.Write " "
Response.Write ""
Response.Write TempFootStr
Set NewCloud_Ads = Nothing
End Sub
Private Sub showPage()
On Error Resume Next
If FoundErr Then
Call errormsg
Else
If Request("action") = "sendmail" Then
If IsValidEmail(Trim(Request.Form("mail"))) = False Then
ErrMsg = ErrMsg + "
" + "您的Email有错误!"
FoundErr = True
Else
useremail = Trim(Request.Form("mail"))
End If
If SendMail = "OK" Then
Call success
End If
Call announceinfo
If FoundErr Then
Call errormsg
Else
Call success
End If
Else
Call pag
End If
End If
If Err.Number 0 Then Err.Clear
End Sub
Private Sub announceinfo()
topic = "您从" & Newasp.Setting(0) & "发来的文章资料"
mailbody = mailbody & ""
Rs.Open "Select title,content,infotime,writer from NC_Article where id=" & ID & "", conn, 1, 1
If Rs.bof And Rs.Eof Then
FoundErr = True
ErrMsg = ErrMsg + "
" + "没有有找到相关文章"
Else
announce = announce & "

" announce = announce & "-- 作者：" & Rs("writer") & " " announce = announce & "-- 发布时间：" & Rs("infotime") & " " announce = announce & "-- " & Rs("title") & " " announce = announce & "" & Rs("content") & "" announce = announce & "

"
End If
Rs.Close
mailbody = mailbody + announce
mailbody = mailbody & ""
Select Case CInt(Newasp.Setting(10))
Case 0
SucMsg = SucMsg + "对不起!系统未开启邮件功能。"
Case 1
Call Jmail(useremail, topic, mailbody)
Case 2
Call Cdonts(useremail, topic, mailbody)
Case 3
Call aspemail(useremail, topic, mailbody)
Case Else
SucMsg = SucMsg + "系统未开启邮件功能，请记住您的注册信息。"
End Select
If SendMail = "OK" Then
SucMsg = SucMsg + "恭喜您，您的打包邮递发送成功。"
Else
SucMsg = SucMsg + "由于系统错误，您的打包邮递发送未成功。"
End If
End Sub
Private Sub pag()
Response.Write "

" Response.Write " " Response.Write " 打包邮递 " Response.Write " 把本文打包邮递。 请正确输入你要邮递的邮件地址！" Response.Write " 邮递的 Email 地址：

"
End Sub
Private Sub success()
Response.Write "

" Response.Write " 成功：打包邮递 " Response.Write SucMsg Response.Write " " Response.Write "

"
End Sub
Private Sub errormsg()
Response.Write "
"
Response.Write "

" Response.Write " 错误信息 产生错误的可能原因： " Response.Write ErrMsg Response.Write " " Response.Write "

"
End Sub
%>