<% Head() Dim Admin_flag Admin_flag=",20," Founderr=False Dim XmlDom Dim FilePath Dim EmailTopic,EmailBody FilePath = MyDbPath & "data/SendMailLog.config" FilePath = Server.MapPath(FilePath) If not Dvbbs.master or instr(","&session("flag")&",",Admin_flag)=0 Then Errmsg=ErrMsg + "

本页面为管理员专用，请登录后进入。

您没有管理本页面的权限。" Dvbbs_error() Else Call Main() Footer() End If Sub Main() %>

用户邮件通知
	①发送邮件列表只会保留最新十条记录； ②每次发送邮件请不要设置过多，要根据服务器的情况而定; ③邮件列表将保留发送的记录，还未发送完的可以在下一次执行发送。 ④批量发送邮件，将会占用服务器资源，请尽量在访问量少的时间进行批量操作。
系统群发邮件 \| 群发邮件任务记录

<% Select Case Request("Act") Case "sendemail" : Call SendStep2() Case "ShowLog" : Call ShowLog() Case "DelSendLog" : Call DelSendLog() Case "SendLog" : Call SendLog() Case Else Call SendStep1 End Select End Sub '删除记录 Sub DelSendLog() Dim DelNodes,DelChildNodes Set XmlDom = Server.CreateObject("MSXML.DOMDocument") If Not XmlDom.load(FilePath) Then ErrMsg = "邮件列表中为空，请填写发邮件后再执行本操作!" Dvbbs_Error() Exit Sub End If 'Response.Write Request.Form("DelNodes").count For Each DelNodes in Request.Form("DelNodes") Set DelChildNodes = XmlDom.DocumentElement.selectSingleNode("SendLog[@AddTime='"&DelNodes&"']") If Not (DelChildNodes is nothing) Then XmlDom.DocumentElement.RemoveChild(DelChildNodes) End If Next XmlDom.save FilePath Set XmlDom=Nothing Dv_suc("所选的记录已删除!") End Sub '根据记录发送邮件 Sub SendLog() Dim SelNodes,SelChildNodes,SendOrders SelNodes = Trim(Request.Form("DelNodes")) SendOrders = Trim(Request.Form("SendOrders")) If SendOrders="" or Not IsNumeric(SendOrders) Then ErrMsg = "请填写每次发送邮件的记录数!" Dvbbs_Error() Exit Sub Else SendOrders = Clng(SendOrders) End If Set XmlDom = Server.CreateObject("MSXML.DOMDocument") If Not XmlDom.load(FilePath) Then ErrMsg = "邮件列表中为空，请填写发邮件后再执行本操作!" Dvbbs_Error() Exit Sub End If Set SelChildNodes = XmlDom.DocumentElement.selectSingleNode("SendLog[@AddTime='"&SelNodes&"']") If SelChildNodes is nothing Then ErrMsg = "发送的记录不存在，请填写发邮件后再执行本操作!" Dvbbs_Error() Exit Sub End If Dim EmailTopic,EmailBody,Total,SearchStr,LastUserID,Remain Dim Sql,Rs,i,ii Total = SelChildNodes.getAttribute("Total") Remain = SelChildNodes.getAttribute("Remain") EmailTopic = SelChildNodes.selectSingleNode("EmailTopic").text EmailBody = SelChildNodes.selectSingleNode("EmailBody").text EmailBody = Replace(EmailBody, CHR(10) & CHR(10), "

") EmailBody = Replace(EmailBody, CHR(10), "
") SearchStr = SelChildNodes.selectSingleNode("Search").text LastUserID = Int(SelChildNodes.getAttribute("LasterUserID")) If Remain="0" Then ErrMsg = "已经发送完毕!" Dvbbs_Error() Exit Sub End If SQL = "Select Top "&SendOrders&" UserID,UserName,UserEmail From Dv_User where UserID>= " & LastUserID If SearchStr<>"" Then SQL = SQL &" and "& SearchStr End If SQL = SQL & " order by UserID " SET Rs = Dvbbs.Execute(SQL) If Not Rs.eof Then SQL=Rs.GetRows(-1) Rs.close:Set Rs = Nothing Else ErrMsg = "已经发送完毕!" Dvbbs_Error() Exit Sub End If %>

下面开始发送邮件给目标用户，总共发送<%=Total%>封，目前剩余发送<%=Remain%>封，每次发送最限为<%=SendOrders%>封。

0%

<% Dim DvEmail Set DvEmail = New Dv_SendMail DvEmail.SendObject = Cint(Dvbbs.Forum_Setting(2)) '设置选取组件 1=Jmail,2=Cdonts,3=Aspemail DvEmail.ServerLoginName = Dvbbs.Forum_info(12) '您的邮件服务器登录名 DvEmail.ServerLoginPass = Dvbbs.Forum_info(13) '登录密码 DvEmail.SendSMTP = Dvbbs.Forum_info(4) 'SMTP地址 DvEmail.SendFromEmail = Dvbbs.Forum_info(5) '发送来源地址 DvEmail.SendFromName = Dvbbs.Forum_info(0) '发送人信息 For i=0 To Ubound(SQL,2) If DvEmail.ErrCode = 0 Then DvEmail.SendMail SQL(2,i),EmailTopic,EmailBody '执行发送邮件 If Not DvEmail.ErrCode = 0 Then ErrMsg = DvEmail.Description Dvbbs_Error() Exit Sub End If Else ErrMsg = DvEmail.Description Dvbbs_Error() Exit Sub End If ii=ii+1 Response.Write "" Response.Flush LastUserID = SQL(0,i) Next Set DvEmail = Nothing Remain = Remain -ii If Remain<0 Then Remain = 0 SelChildNodes.attributes.getNamedItem("Remain").text = Remain SelChildNodes.attributes.getNamedItem("LasterUserID").text = LastUserID SelChildNodes.attributes.getNamedItem("LastTime").text = now() XmlDom.documentElement.appendChild(SelChildNodes) XmlDom.save FilePath Set XmlDom=Nothing If Remain>0 Then '改继续发送方式 2005-10-6 Dv.Yz Response.Write "

" End If End Sub '显示邮件记录列表 Sub ShowLog() Set XmlDom = Server.CreateObject("MSXML.DOMDocument") If Not XmlDom.load(FilePath) Then ErrMsg = "邮件列表中为空，请填写发邮件后再执行本操作!" Dvbbs_Error() Exit Sub End If Dim Node,SendLogNode,Childs Set SendLogNode = XmlDom.DocumentElement.SelectNodes("SendLog") Childs = SendLogNode.Length '列表数 If Childs>10 Then Dim objRemoveNode,i For i=0 To (Childs-11) XmlDom.documentElement.removeChild(SendLogNode.item(i)) Next XmlDom.save FilePath End If %>
<% Dim SearchStr,Topic i=0 For Each Node in SendLogNode 'SearchStr = Node.selectSingleNode("Search").text Topic = Node.selectSingleNode("EmailTopic").text 'Node.getAttribute("MasterName") %> <% i=i+1 Next %>

发送邮件列表
选取	标题	总共发送数目	剩余发送数目	操作者	操作者IP	添加时间	更新时间	操作
每次发送邮件封
">	<%=Topic%>	<%=Node.getAttribute("Total")%>	<%=Node.getAttribute("Remain")%>	<%=Node.getAttribute("MasterName")%>	<%=Node.getAttribute("MasterIP")%>	<%=Node.getAttribute("AddTime")%>	<%=Node.getAttribute("LastTime")%>
全选

<% Set XmlDom = Nothing End Sub '填写发送邮件信息 Sub SendStep1() %>

用户邮件通知

选择用户：

(多个用户名请以英文逗号“,”分隔,注意区分大小写;)

用户类别：

用户名单用户组所有用户

邮件标题：

邮件内容：

<% End Sub Sub SendStep2() Server.ScriptTimeout=999999 Dim UserType UserType = Request.Form("UserType") EmailTopic = Request.Form("EmailTopic") EmailBody = Request.Form("EmailBody") If EmailTopic="" or EmailBody="" Then ErrMsg = "请填写邮件的标题和内容!" Dvbbs_Error() Exit Sub End If Select Case UserType Case "0" : Call Sendtype_0() '按指定用户 Case "1" : Call Sendtype_1() '按指定用户组 Case "2" : Call Sendtype_2() '按所有用户 Case Else ErrMsg = "请选收信的用户!" Dvbbs_Error() Exit Sub End Select Dv_suc("已经成功将发送事件存入列表，请在发送列表中选取发送!") End Sub '按指定用户 Sub Sendtype_0() Dim Searchstr Dim ToUserName,Rs,Sql,i,ToUserID,FirstUserID ToUserName = Trim(Request.Form("UserName")) If ToUserName = "" Then ErrMsg = "请填写目标用户名，注意区分大小写。" Dvbbs_Error() Exit Sub End If ToUserName = Replace(ToUserName,"'","") ToUserName = Split(ToUserName,",") If Ubound(ToUserName)>100 Then ErrMsg = "限制一次不能超过100位目标用户。" Dvbbs_Error() Exit Sub End If For i=0 To Ubound(ToUserName) SQL = "Select UserID From [Dv_user] Where UserName = '"&ToUserName(i)&"' order by userid" SET Rs = Dvbbs.Execute(SQL) If Not Rs.eof Then If i=0 or ToUserID="" Then ToUserID = ToUserID & Rs(0) FirstUserID = Rs(0) Else ToUserID = ToUserID &","& Rs(0) End If End If Next Rs.Close : Set Rs = Nothing Dim Total Total = Ubound(Split(ToUserID,","))+1 If Total = 0 Then ErrMsg = "系统找不到相应目标用户名，注意区分大小写。" Dvbbs_Error() Exit Sub Else SearchStr = "UserID in ("&ToUserID&")" Call CreateXmlLog(Total,SearchStr,FirstUserID) End If End Sub '按指定用户组及条件发送 Sub Sendtype_1() Dim GetGroupID Dim SearchStr,TempValue,DayStr GetGroupID = Replace(Request.Form("GetGroupID"),chr(32),"") If GetGroupID<>"" and Not Isnumeric(Replace(GetGroupID,",","")) Then ErrMsg = "请正确选取相应的用户组。" Else GetGroupID = Dvbbs.Checkstr(GetGroupID) End If If IsSqlDataBase=1 Then DayStr = "d" Else DayStr = "'d'" End If If GetGroupID<>"" Then If Isnumeric(GetGroupID) Then SearchStr = "UserGroupID = "&GetGroupID Else SearchStr = "UserGroupID in ("&GetGroupID&")" End If End If '登陆次数 TempValue = Request.Form("Logins") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("LoginsType"),"UserLogins") End If '发表文章 TempValue = Request.Form("UserPost") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("UserPostType"),"UserPost") End If '主题文章 TempValue = Request.Form("UserTopic") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("UserTopicType"),"UserTopic") End If '精华文章 TempValue = Request.Form("UserBest") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("UserBestType"),"UserIsBest") End If '最后登陆时间 TempValue = Request.Form("LoginTime") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("LoginTimeType"),"Datediff("&DayStr&",Lastlogin,"&SqlNowString&")") End If '注册时间 TempValue = Request.Form("RegTime") If TempValue<>"" and IsNumeric(TempValue) Then SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("RegTimeType"),"Datediff("&DayStr&",JoinDate,"&SqlNowString&")") End If If SearchStr="" Then ErrMsg = "请填写发送的条件选项。" End If If ErrMsg<>"" Then Dvbbs_Error() : Exit Sub Dim Rs,Sql,Total,FirstUserID Sql = "Select Count(UserID) From Dv_user Where "& SearchStr Total = Dvbbs.Execute(Sql)(0) If Total>0 Then Sql = "Select Top 1 UserID From Dv_user Where "& SearchStr & " order by userid" FirstUserID = Dvbbs.Execute(Sql)(0) Call CreateXmlLog(Total,SearchStr,FirstUserID) Else ErrMsg = "发送目标用户为空，请更改发送条件再进行发送。" Dvbbs_Error() Exit Sub End If End Sub '按所有用户 Sub Sendtype_2() Dim SearchStr Dim Rs,Sql,Total,FirstUserID Sql = "Select Count(UserID) From Dv_user" Total = Dvbbs.Execute(Sql)(0) If Total>0 Then Sql = "Select Top 1 UserID From Dv_user order by userid" FirstUserID = Dvbbs.Execute(Sql)(0) Call CreateXmlLog(Total,SearchStr,FirstUserID) Else ErrMsg = "发送目标用户为空，请更改发送条件再进行发送。" Dvbbs_Error() Exit Sub End If End Sub '添加发送记录 Sub CreateXmlLog(SendTotal,Search,LasterUserID) Dim node,attributes,createCDATASection,ChildNode Set XmlDom = Server.CreateObject("MSXML.DOMDocument") If Not XmlDom.load(FilePath) Then XmlDom.loadxml "" End If Set node=XmlDom.createNode(1,"SendLog","") Set attributes=XmlDom.createAttribute("Total") attributes.text = SendTotal node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("Remain") attributes.text = SendTotal node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("LasterUserID") attributes.text = LasterUserID node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("MasterName") attributes.text = Dvbbs.Membername node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("MasterUserID") attributes.text = Dvbbs.UserID node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("MasterIP") attributes.text = Dvbbs.UserTrueIP node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("AddTime") attributes.text = Now() node.attributes.setNamedItem(attributes) Set attributes=XmlDom.createAttribute("LastTime") attributes.text = Now() node.attributes.setNamedItem(attributes) Set ChildNode = XmlDom.createNode(1,"Search","") Set createCDATASection=XmlDom.createCDATASection(replace(Search,"]]>","]]>")) ChildNode.appendChild(createCDATASection) node.appendChild(ChildNode) Set ChildNode = XmlDom.createNode(1,"EmailTopic","") Set createCDATASection=XmlDom.createCDATASection(replace(EmailTopic,"]]>","]]>")) ChildNode.appendChild(createCDATASection) node.appendChild(ChildNode) Set ChildNode = XmlDom.createNode(1,"EmailBody","") Set createCDATASection=XmlDom.createCDATASection(replace(EmailBody,"]]>","]]>")) ChildNode.appendChild(createCDATASection) node.appendChild(ChildNode) XmlDom.documentElement.appendChild(node) XmlDom.save FilePath Set XmlDom = Nothing End Sub Function GetSearchString(Get_Value,Get_SearchStr,UpType,UpColumn) Get_Value = Clng(Get_Value) If Get_SearchStr<>"" Then Get_SearchStr = Get_SearchStr & " and " If UpType="1" Then Get_SearchStr = Get_SearchStr & UpColumn &" <= "&Get_Value Else Get_SearchStr = Get_SearchStr & UpColumn &" >= "&Get_Value End If GetSearchString = Get_SearchStr End Function %>