推荐订阅源

sub SendMaillist()
 dim Sendername,Senderemail,Subject,Content,Priority,InceptType,InceptName,InceptEmail,i,j
 Sendername=trim(request("sendername"))
 Senderemail=trim(request("senderemail"))
 Subject=trim(request("Subject"))
 Content=trim(request("Content"))
 Priority=trim(request("Priority"))
 if Sendername="" then
  FoundErr=True
  ErrMsg=ErrMsg & "<br><li>发件人不能为空！</li>"
 end if
 if Senderemail="" then
  FoundErr=True
  ErrMsg=ErrMsg & "<br><li>发件人Email不能为空！</li>"
 end if
 if Subject="" then
  FoundErr=True
  ErrMsg=ErrMsg & "<br><li>邮件主题不能为空！</li>"
 end if
 if Content="" then
  FoundErr=True
  ErrMsg=ErrMsg & "<br><li>邮件内容不能为空！</li>"
 end if
 if Priority="" then
  Priority=3
 end if
 
 InceptType=Clng(request("incepttype"))
 sql="select UserName,Email from [User] "
 if InceptType=1 then  
  sql=sql & " where Email like '%@%'"  
 elseif InceptType=2 then
  InceptName=replace(replace(replace(replace(request("inceptname")," ",""),"'",""),chr(34),""),"|","','")
  sql=sql & " where UserName in ('" & InceptName & "') and Email like '%@%'"
 elseif InceptType=3 then
  InceptEmail=replace(replace(replace(replace(request("inceptemail")," ",""),"'",""),chr(34),""),"|","','")
  sql=sql & " where Email in ('" & InceptEmail & "')"
 end if
 
 
 if FoundErr=True then
  exit sub
 end if

 set rs=server.createobject("adodb.recordset")
 rs.open sql,conn,1,1
 if rs.bof and rs.eof then
  FoundErr=true
  ErrMsg=ErrMsg & "<br><li>暂时没有用户注册！</li>"
 else    
  response.write "<li>正在发送中，请等待 "
  do while not rs.eof  
   if IsValidEmail(rs("Email"))=True then     
    ErrMsg=SendMail(rs("Email"),rs("UserName"),Subject,Content,Sendername,Senderemail,Priority)
    if ErrMsg<>"" then
     FoundErr=True
     exit sub
    end if
    i=i+1
    response.write "."
   else
    j=j+1    
   end if
   rs.movenext   
  loop
  response.write "<BR><li>成功发送邮件："&i&"封"
  if j>0 then response.write "<BR><li>未发送邮件："&j&"封（邮件地址错误）。" end if
 end if
 rs.close
 set rs=nothing
 call CloseConn()
end sub