📄 admin_email.asp
字号:
<td class="tdbg">发表文章：</td>
<td class="tdbg"><input type="text" name="UserArticle" size="6" onkeyup="CheckNumer(this.value,this,'')" />
篇
<input type="radio" name="UserArticleType" checked="checked" value="0" />
多于
<input type="radio" name="UserArticleType" value="1" />
少于</td>
</tr></table>
</td></tr></table>
</td>
</tr>
<tr>
<td class="tdbg" align="right">邮件标题：</td>
<td class="tdbg"><input type="text" name="EmailTitle" size="80" /></td>
</tr>
<tr>
<td class="tdbg" align="right">邮件内容：</td>
<td class="tdbg">
<textarea name="EmailBody" style="display:none"></textarea>
<iframe id="editor" src="../Editor/Editor.asp?id=EmailBody&style=Other&cid=0" frameborder="0" scrolling="No" width="95%" height="350"></iframe>
</td>
</tr>
<tr class="tdbg">
<td width="15%" align="right">发件人：</td>
<td width="85%">
<input type="text" name="sendername" size="80" value="<%=Cl.Web_info(0)%>" disabled="disabled" />
</td>
</tr>
<tr class="tdbg">
<td width="15%" align="right">发件人Email：</td>
<td width="85%">
<input type="text" name="senderemail" size="80" value="<%=Cl.Web_info(8)%>" disabled="disabled" />
</td>
</tr>
<tr>
<td class="tdbg" align="right"></td>
<td class="tdbg">
<input type="hidden" name="Act" value="sendemail" />
<input type="submit" value="提交" <% If EmailObjInstalled=False Then response.write "disabled" end if%> />
<input type="reset" value="重填" onclick="UType(0)" />
<%
If EmailObjInstalled=False Then
Response.Write "<br /><font color=red>对不起，因为服务器不支持您选择的邮件发送组件("&EmailObjName&")，请到基本信息处重新配置邮件发送组件。</font>"
End If
%>
</td>
</tr>
</form>
</table>
<script language="JavaScript" type="text/javascript">
<!--
function openset(v,s){
if (v.value=='打开高级设置'){
document.getElementById(s).style.display = "";
v.value="关闭高级设置";
}
else{
v.value="打开高级设置";
document.getElementById(s).style.display = "none";
}
}
function UType(n){
if (n==1){
document.getElementById("ToUserName").style.display = "";
document.getElementById("ToUserEmail").style.display = "none";
document.getElementById("ToUserGroupID").style.display = "none";
}
else if(n==2){
document.getElementById("ToUserName").style.display = "none";
document.getElementById("ToUserEmail").style.display = "";
document.getElementById("ToUserGroupID").style.display = "none";
}
else if(n==3){
document.getElementById("ToUserName").style.display = "none";
document.getElementById("ToUserEmail").style.display = "none";
document.getElementById("ToUserGroupID").style.display = "";
}
else{
document.getElementById("ToUserName").style.display = "none";
document.getElementById("ToUserEmail").style.display = "none";
document.getElementById("ToUserGroupID").style.display = "none";
}
}
//-->
</script>
<%
End Sub
Sub SendStep2()
Server.ScriptTimeout=999999
Dim UserType
UserType = Request.Form("UserType")
EmailTitle = Request.Form("EmailTitle")
EmailBody = Request.Form("EmailBody")
If EmailTitle="" or EmailBody="" Then
ErrMsg = "请填写邮件的标题和内容!"
Cl.ShowErr(ErrMsg)
Exit Sub
End If
Select Case UserType
Case "0" : Call Sendtype_0() '按所有用户
Case "1" : Call Sendtype_1() '按指定用户
Case "2" : Call Sendtype_2() '按指定Email
Case "3" : Call Sendtype_3() '按指定用户组
Case Else
Cl.ShowErr( "请选收信的用户!") : Exit Sub
End Select
Cl.SaveAdminLog
Call Cl.ShowSuc("已经成功将发送事件存入列表，请在发送列表中选取发送!")
End Sub
'按所有用户
Sub Sendtype_0()
Dim SearchStr
Dim Rs,Sql,Total,FirstUserID
Sql = "Select Count(UserID) From "&Db.UserTable&""
Total = Cl.Execute_U(Sql)(0)
If Total>0 Then
Sql = "Select Top 1 UserID From "&Db.UserTable&" order by UserID"
FirstUserID = Cl.Execute_U(Sql)(0)
Call CreateXmlLog(Total,SearchStr,FirstUserID)
Else
Cl.ShowErr("发送目标用户为空，请更改发送条件再进行发送。")
Exit Sub
End If
End Sub
'按指定用户
Sub Sendtype_1()
Dim Searchstr
Dim ToUserName,Rs,Sql,i,ToUserID,FirstUserID
ToUserName = Trim(Request.Form("UserName"))
If ToUserName = "" Then
Cl.ShowErr("请填写目标用户名，注意区分大小写。")
Exit Sub
End If
ToUserName = Replace(ToUserName,"'","")
ToUserName = Split(ToUserName,",")
If Ubound(ToUserName)>100 Then
Cl.ShowErr("限制一次不能超过100位目标用户。")
Exit Sub
End If
For i=0 To Ubound(ToUserName)
SQL = "Select UserID From "&Db.UserTable&" Where "&Db.UserName&" = '"&ToUserName(i)&"' order by userid"
SET Rs = Cl.Execute_U(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
Cl.ShowErr("系统找不到相应目标用户名，注意区分大小写。")
Exit Sub
Else
SearchStr = "UserID in ("&ToUserID&")"
Call CreateXmlLog(Total,SearchStr,FirstUserID)
End If
End Sub
'按指定Email
Sub Sendtype_2()
Dim ToUserEmail,i,ii,Remain
ToUserEmail = Trim(Request.Form("UserEmail"))
If ToUserEmail = "" Then
Cl.ShowErr("请填写目标Email，注意区分大小写。")
Exit Sub
End If
ToUserEmail = Replace(ToUserEmail,"'","")
ToUserEmail = Split(ToUserEmail,",")
ii=0:Remain=Ubound(ToUserEmail)+1
If Ubound(ToUserEmail)>100 Then
ErrMsg = "限制一次不能超过100位目标用户。"
Cl.ShowErr(ErrMsg)
Exit Sub
End If
%>
<table cellpadding="0" cellspacing="0" border="0" width="95%" class="Border" align=center>
<tr><td colspan=2 class=tdbg>下面开始发送邮件给目标用户，总共发送<%=Remain%>封。
<table width="400" border="0" cellspacing="1" cellpadding="1">
<tr>
<td bgcolor=000000>
<table width="400" border="0" cellspacing="0" cellpadding="1">
<tr><td bgcolor=ffffff height=9><img src="../Images/bar/bar3.gif" width=0 height=16 id=img2 name=img2 align=absmiddle></td></tr></table>
</td></tr></table>
<span id=txt2 name=txt2 style="font-size:9pt">0</span><span style="font-size:9pt">%</span></td></tr>
</table>
<table cellpadding="0" cellspacing="0" border="0" width="95%" class="Border" align=center>
<tr><td colspan=2 class=tdbg>
<span id=txt3 name=txt3 style="font-size:9pt">
</span>
</td></tr></table>
<%
Dim ClEmail
Set ClEmail = New Cls_SendMail
ClEmail.SendObject = Cint(Cl.Web_Setting(17)) '设置选取组件
ClEmail.ServerLoginName = Cl.Web_Setting(19) '您的邮件服务器登录名
ClEmail.ServerLoginPass = Cl.Web_Setting(20) '登录密码
ClEmail.SendSMTP = Cl.Web_Setting(18) 'SMTP地址
ClEmail.SendFromEmail = Cl.Web_Info(8) '发送来源地址
ClEmail.SendFromName = Cl.Web_Info(0) '发送人信息
For i=0 To Remain-1
If ClEmail.ErrCode = 0 Then
ClEmail.SendMail ToUserEmail(i),EmailTitle,Replace(EmailBody,"{$username}",GetEmailName(ToUserEmail(i))) '执行发送邮件
End If
If ClEmail.ErrCode <> 0 Then
Cl.ShowErr(ClEmail.Description)
Exit Sub
end if
ii=ii+1
Response.Write "<script>img2.width=" & Fix((ii/Remain) * 400) & ";" & VbCrLf
Response.Write "txt2.innerHTML=""发送给"&GetEmailName(ToUserEmail(i))&"（"&ToUserEmail(i)&"）的邮件完成，正在发送下一个用户邮件，" & FormatNumber(ii/Remain*100,4,-1) & """;" & VbCrLf
Response.Write "txt3.innerHTML+=""发送给"&GetEmailName(ToUserEmail(i))&"（"&ToUserEmail(i)&"）的邮件完成<br />"";"
Response.Write "</script>"
Response.Flush
Next
Set ClEmail = Nothing
Response.Write "<input type=button value=发送完毕 onclick=""window.location.href='Admin_Email.asp'"">"
Response.end
End Sub
'按指定用户组及条件发送
Sub Sendtype_3()
Dim UserGroupID
Dim SearchStr,TempValue,DayStr
UserGroupID = Replace(Request.Form("UserGroupID"),chr(32),"")
If UserGroupID<>"" and Not Isnumeric(Replace(UserGroupID,",","")) Then
ErrMsg = "请正确选取相应的用户组。"
Else
UserGroupID = Cl.Checkstr(UserGroupID)
End If
If IsSqlDataBase=1 Then
DayStr = "d"
Else
DayStr = "'d'"
End If
If UserGroupID<>"" Then
If Isnumeric(UserGroupID) Then
SearchStr = "UserGroupID = "&UserGroupID
Else
SearchStr = "UserGroupID in ("&UserGroupID&")"
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("UserArticle")
If TempValue<>"" and IsNumeric(TempValue) Then
SearchStr = GetSearchString(TempValue,SearchStr,Request.Form("UserArticleType"),"UserArticle")
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 Cl.ShowErr(ErrMsg) : Exit Sub
Dim Rs,Sql,Total,FirstUserID
Sql = "Select Count(UserID) From "&Db.UserTable&" Where "& SearchStr
Total = Cl.Execute_U(Sql)(0)
If Total>0 Then
Sql = "Select Top 1 UserID From "&Db.UserTable&" Where "& SearchStr & " order by UserID"
FirstUserID = Cl.Execute_U(Sql)(0)
Call CreateXmlLog(Total,SearchStr,FirstUserID)
Else
Cl.ShowErr("发送目标用户为空，请更改发送条件再进行发送。")
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 "<?xml version=""1.0"" encoding=""gb2312""?><EmailLog/>"
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 = Cl.MemberName
node.attributes.setNamedItem(attributes)
Set attributes=XmlDom.createAttribute("MasterUserID")
attributes.text = Cl.UserID
node.attributes.setNamedItem(attributes)
Set attributes=XmlDom.createAttribute("MasterIP")
attributes.text = Cl.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,"EmailTitle","")
Set createCDATASection=XmlDom.createCDATASection(replace(EmailTitle,"]]>","]]>"))
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
Function GetEmailName(strEmail)
Dim strName
strName=Instr(strEmail,"@")
if strName<=0 then Exit Function
GetEmailName=left(strEmail,strName-1)
End Function
'<!--
'┌───────────────────────────────────────────────────────┐
'│ │
'│ CreateLive CMS Version 4.0 │
'│ Powered by Aspoo.CN │
'│ │
'│ 邮箱: support@aspoo.cn Info@aspoo.cn │
'│ ＱＱ: 3315263 596197794 │
'│ 网站: www.aspoo.cn www.aspoo.com │
'│ 论坛: bbs.aspoo.cn bbs.aspoo.com │
'│ │
'│ Copyright (C) 2005-2007 Aspoo.CN All Rights Reserved. │
'└───────────────────────────────────────────────────────┘
'-->
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -