www.gusucode.com > 仿MOP对开式论坛程序 1.0源码程序 > sub.asp

    <%
Function creatvalidate(gbi,ip)
Dim ips,i
ips=Split(ip,".")
creatvalidate=gbi
For i=0 to Ubound(ips)
creatvalidate=creatvalidate*(ips(i)+1)
Next
creatvalidate=creatvalidate & gbmaduser
end Function

Function anonymitycode(ip)
Dim ips,i
ips=Split(ip,".")
For i=0 to Ubound(ips)
anonymitycode=(anonymitycode+Day(Date()))*7+ips(i)*33
Next
end Function

Function contentcode(str,html)
if html=1 then
contentcode=Replace(Replace(Replace(Replace(str,"'",""),Chr(60) &"%","&lt;%"),"%"& Chr(62),"%&gt;"),vbcrlf,"<br>"& vbcrlf)
else
contentcode=Replace(Replace(Replace(Replace(str,"'",""),"<","&lt;"),">","&gt;"),vbcrlf,"<br>"& vbcrlf)
end if
end Function

Function titlecode(str)
titlecode=Replace(Replace(Replace(str,"'",""),"<","&lt;"),">","&gt;")
end Function

Function gubb(str)
str=Replace(str,vbcrlf,Chr(1) & Chr(2) & Chr(3))
dim re
Set re=New RegExp
re.IgnoreCase=True
re.Global=True
re.Pattern="\[img\](.*?)\[\/img\]"
str=re.Replace(str,"<img src=""$1"">")
re.Pattern="\[url\](.*?)\[\/url\]"
str=re.Replace(str,"<a href=""$1"" target=""_blank"">$1</a>")
re.Pattern="\[url=(.*?)\](.*?)\[\/url\]"
str=re.Replace(str,"<a href=""$1"" target=""_blank"">$2</a>")
re.Pattern="\[email\](.*?)\[\/email\]"
str=re.Replace(str,"<a href=""mailto:$1"">$1</a>")
re.Pattern="\[email=(.*?)\](.*?)\[\/email\]"
str=re.Replace(str,"<a href=""mailto:$1"">$2</a>")
re.Pattern="\[flash\](.*?)\[\/flash\]"
str=re.Replace(str,"<font color=red>!下面是个flash，可能有危险代码，谨慎观看</font><br><a href=""$1"" target=""_blank"">$1</a>")
re.Pattern="\[fly\](.*?)\[\/fly\]"
str=re.Replace(str,"<marquee width=90% behavior=alternate scrollamount=3>$1</marquee>")
re.Pattern="\[move\](.*?)\[\/move\]"
str=re.Replace(str,"<marquee width=90% scrollamount=3>$1</marquee>")
re.Pattern="\[color=(.*?)\](.*?)\[\/color\]"
str=re.Replace(str,"<font color=""$1"">$2</font>")
re.Pattern="\[size=([1-7])\](.*?)\[\/size\]"
str=re.Replace(str,"<font size=""$1"">$2</font>")
re.Pattern="\[align=(.*?)\](.*?)\[\/align\]"
str=re.Replace(str,"<div align=""$1"">$2</div>")
re.Pattern="\[b\](.*?)\[\/b\]"
str=re.Replace(str,"<b>$1</b>")
re.Pattern="\[u\](.*?)\[\/u\]"
str=re.Replace(str,"<u>$1</u>")
re.Pattern="\[i\](.*?)\[\/i\]"
str=re.Replace(str,"<i>$1</i>")
re.Pattern="\[sub\](.*?)\[\/sub\]"
str=re.Replace(str,"<sub>$1</sub>")
re.Pattern="\[sup\](.*?)\[\/sup\]"
str=re.Replace(str,"<sup>$1</sup>")
re.Pattern="\[strike\](.*?)\[\/strike\]"
str=re.Replace(str,"<strike>$1</strike>")
re.Pattern="\[ul\](.*?)\[\/ul\]"
str=re.Replace(str,"<ul>$1</ul>")
re.Pattern="\[ol\](.*?)\[\/ol\]"
str=re.Replace(str,"<ol>$1</ol>")
re.Pattern="\[li\](.*?)\[\/li\]"
str=re.Replace(str,"<li>$1</li>")
str=Replace(str,Chr(1) & Chr(2) & Chr(3),vbcrlf)
gubb=str
Set re=Nothing
end Function

Function unhtmlcode(str)
if str<>"" then
Dim regex
Set regex=New RegExp
regex.IgnoreCase=True
regex.Global=True
regex.Pattern="<script"
str=regex.Replace(str,"&lt;script")
regex.Pattern="</script>"
str=regex.Replace(str,"&lt;/script&gt;")
regex.Pattern="\son([a-zA-Z]*)="
str=regex.Replace(str," on$1&#61")
regex.Pattern="<object"
str=regex.Replace(str,"&lt;object")
regex.Pattern="</object>"
str=regex.Replace(str,"&lt;/object&gt;")
regex.Pattern="<param"
str=regex.Replace(str,"&lt;param")
regex.Pattern="<embed(.*?)src=(""|'|)(.*?).swf(.*?)>"
str=regex.Replace(str,"<br><font class=""anonymity""><font color=red>!注意：下面这个Flash可能含有窃取你在本站的Cookie，请谨慎查看</font></font><br><a href=""$3.swf"">$3.swf</a><br>")
regex.Pattern="<embed"
str=regex.Replace(str,"<embed autostart=""false""")
regex.Pattern="<a"
str=regex.Replace(str,"<a target=""_blank""")
str=Replace(str,"  ","&nbsp;&nbsp;")
if ubb=1 then str=gubb(str)
Set regex=Nothing
end if
unhtmlcode=str
end Function

Sub randomtool()
if gbmaduser<>"" and Right(Minute(Time()),1)>5 then
Dim luck,tool
luck=Second(Time())+Hour(Time())
Select Case luck
Case 56
tool="精美礼盒"
Case 58
tool="显影水晶"
Case 60
tool="探察视镜"
Case 63
tool="社区支票"
Case 66
tool="悬浮陨石"
Case 68
tool="暗夜极光"
Case 71
tool="凤之羽粉"
Case 74
tool="天使翅膀"
Case 77
tool="乱抱树熊"
End Select
if tool<>"" then
rs.Open "tools Where gbmaduser='"& gbmaduser &"' and toolname='"& tool &"'",conn,1,3
if rs.Eof then
rs.AddNew
rs("gbmaduser")=gbmaduser
rs("toolname")=tool
rs("amount")=1
else
rs("amount")=rs("amount")+1
end if
rs.Update
rs.Close
end if
end if
End Sub

Function poster(name,color)
if color=1 then
poster="<font color=""#003399"">"& name &"</font>"
elseif color=2 then
poster="<font color=""#FFCCFF"">"& name &"</font>"
elseif color=3 then
poster="<font color=""#FFCCFF"">"& name &"</font>"
elseif color=4 then
poster="<font color=""#FFCCFF"">"& name &"</font>"
elseif color=5 then
poster="<font color=""#1008ad"">"& name &"</font>"
else
poster=name
end if
end Function

if rtool=1 then call randomtool()

Function unitetopic()
Dim i
if m mod 10=0 then
For i=1 to m step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
elseif m mod 10=1 then
For i=1 to m-1 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m))
elseif m mod 10=2 then
For i=1 to m-2 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-1) & tl(m))
elseif m mod 10=3 then
For i=1 to m-3 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-2) & tl(m-1) & tl(m))
elseif m mod 10=4 then
For i=1 to m-4 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
elseif m mod 10=5 then
For i=1 to m-5 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-4) & tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
elseif m mod 10=6 then
For i=1 to m-6 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-5) & tl(m-4) & tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
elseif m mod 10=7 then
For i=1 to m-7 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-6) & tl(m-5) & tl(m-4) & tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
elseif m mod 10=8 then
For i=1 to m-8 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-7) & tl(m-6) & tl(m-5) & tl(m-4) & tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
else
For i=1 to m-9 step 10
unitetopic=unitetopic & ((tl(i) & tl(i+1) & tl(i+2) & tl(i+3) & tl(i+4)) & (tl(i+5) & tl(i+6) & tl(i+7) & tl(i+8) & tl(i+9)))
Next
unitetopic=unitetopic & (tl(m-8) & tl(m-7) & tl(m-6) & tl(m-5) & tl(m-4) & tl(m-3) & tl(m-2) & tl(m-1) & tl(m))
end if
end Function

Sub creattopic(id)
Dim topichtml,topicfso,topicfsobj,topicread,topictext,topici,topicc
Set topicfso=CreateObject("Scripting.FileSystemObject")
rs.Open "Select title,content,remark,admincolor,gbmaduser,posttime,aboutlink,imglink,anonymity From Topic Where id="& id,conn,1,1
topichtml="<html><head><title>"& rs("title") &"</title><meta http-equiv=""Pragma"" content=""no-cache""><meta http-equiv=""expires"" content=""wed, 29 Aug 2000 00:00:00 GMT""><meta http-equiv=""Cache-Control"" content=""no-cache, must-revalidate""><meta http-equiv=""Content-Type"" content=""text/html;charset=gb2312""><meta http-equiv=""Content-Language"" content=""zh-cn"">"&_
"<link href=""../../"& defaulttheme &"index.css"" rel=""stylesheet"" type=""text/css""><script language=""JavaScript"" src=""../../open.js""></script></head><body onmousedown=""sm();"" ondblclick=""tm();"" onmousemove=""mp();"">"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">"&_
"<tr class=""toptr""><td class=""tdc"" height=""20"" background=""../../"& defaulttheme &"02.gif""><a href=""../../topictool.asp?id="& id &""" onClick=""return shows(this.href+'&title="& Replace(Replace(rs("title"),"""",""),"#","") &"');"">↓道具</a><a href=""#"" onclick=""clipboardData.setData('Text','精华 >> '+document.title+' >> '+window.location.href+'\r\n');alert('复制成功,可以发给QQ/MSN上的好友了')"" title=""点击复制地址发给QQ/MSN上的好友分享"""">↓复制本帖地址，传给QQ/MSN上的好友</a><BR><B>"& rs("title") &"</td></tr><tr class=""tds""></B><td>"& unhtmlcode(rs("content"))
if rs("aboutlink")<>"" then topichtml=topichtml &"<br>相关链接：<a href="""& rs("aboutlink") &""" target=""_blank"">"& rs("aboutlink") &"</a>"
if rs("imglink")<>"" then topichtml=topichtml &"<br><img src="""& rs("imglink") &""" border=""0"">"
topichtml=topichtml & unhtmlcode(rs("remark")) &"</td></tr>"
if rs("anonymity")<>"" then
topichtml=topichtml &"<tr class=""tds""><td><a href=""../../topicedit.asp?id="& id &""" class=""anonymity"" title=""编辑帖子"">神秘人物"& rs("anonymity") &"</a> <a href=""../../topictool.asp?topic="& id &""" onClick=""return shows(this.href+'&title="& rs("anonymity") &"');"" title=""使用 显影水晶 查看 神秘人物"& rs("anonymity") &""">使用道具</a> <font class=""del"">发贴时间："& rs("posttime") &"</font></td></tr>"
else
topichtml=topichtml &"<tr class=""tds""><td><a href=""../../topicedit.asp?id="& id &""" title=""编辑帖子"">"& poster(rs("gbmaduser"),rs("admincolor")) &"</a> <a href=""../../sendmessage.asp?username="& rs("gbmaduser") &""" onClick=""return shows(this.href);"" title=""发送密信给 "& rs("gbmaduser") &""">发送密信</a> <a href=""../../userinfo.asp?username="& rs("gbmaduser") &""" onClick=""return showb(this.href);"" title=""查看用户 "& rs("gbmaduser") &" 的详细信息"">作者信息</a> <font class=""del"">发贴时间："& rs("posttime") &"</font></td></tr>"
end if
rs.Close
Set topicfsobj=topicfso.GetFile(Server.MapPath(Chr(98) & Chr(111) & Chr(116) & Chr(116) & Chr(111) & Chr(109) & Chr(46) & Chr(97) & Chr(115) & Chr(112)))
Set topicread=topicfsobj.OpenAsTextStream(1,0)
topictext=topicread.ReadAll
topicread.Close
Set topicread=Nothing
topichtml=topichtml &"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table><br>"
rs.Open "reply Where topicid="& id &" Order by id",conn,1,1
if Not rs.Eof then
topichtml=topichtml &"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">"
m=1
For topici=1 to rs.RecordCount-1
if topici mod 5=0 then m=m+1
if topici Mod 2=0 then
topicc=" class=""otr"""
else
topicc=""
end if
tl(m)=tl(m) &("<tr class=""toptr""><td class=""tdc"" height=""20"" background=""../../"& defaulttheme &"02.gif""><strong><em><font size=2>"& topici &"</font></em></strong> L：</td></tr>")
if IsNull(rs("deler")) then
tl(m)=tl(m) &("<tr class=""tds""><td"& topicc &">"& unhtmlcode(rs("content")))
if rs("aboutlink")<>"" then tl(m)=tl(m) &("<br>相关链接：<a href="""& rs("aboutlink") &""" target=""_blank"">"& rs("aboutlink") &"</a>")
if rs("imglink")<>"" then tl(m)=tl(m) &("<br><img src="""& rs("imglink") &""" border=""0"">")
tl(m)=tl(m) & (unhtmlcode(rs("remark")) &"</td></tr>")
else
tl(m)=tl(m) &("<tr class=""tds""><td"& topicc &"><font class=""del"">该回复已经被<a href=""../../sendmessage.asp?username="& rs("deler") &""" onClick=""return shows(this.href);"" title=""发送密信给 "& rs("deler") &""">"& rs("deler") &"</a>删除</font>。 <a href=""../../topictool.asp?explore="& rs("id") &""" onClick=""return showb(this.href+'&title="& rs("deler") &"');"" title=""使用 探察视镜 查看该被删除的回复"">使用道具</a></td></tr>")
end if
if rs("anonymity")<>"" then
tl(m)=tl(m) &("<tr class=""tds""><td"& topicc &"><a href=""../../replyedit.asp?id="& rs("id") &""" class=""anonymity"" title=""编辑回复"">神秘人物"& rs("anonymity") &"</a> <a href=""../../topictool.asp?reply="& rs("id") &""" onClick=""return shows(this.href+'&title="& rs("anonymity") &"');"" title=""使用 显影水晶 查看 神秘人物"& rs("anonymity") &""">使用道具</a> <font class=""del"">回复时间："& rs("posttime") &"</font></td></tr>")
else
tl(m)=tl(m) &("<tr class=""tds""><td"& topicc &"><a href=""../../replyedit.asp?id="& rs("id") &""" title=""编辑回复"">"& poster(rs("gbmaduser"),rs("admincolor")) &"</a> <a href=""../../sendmessage.asp?username="& rs("gbmaduser") &""" onClick=""return shows(this.href);"" title=""发送密信给 "& rs("gbmaduser") &""">发送密信</a> <a href=""../../userinfo.asp?username="& rs("gbmaduser") &""" onClick=""return showb(this.href);"" title=""查看用户 "& rs("gbmaduser") &" 的详细信息"">作者信息</a> <font class=""del"">回复时间："& rs("posttime") &"</font></td></tr>")
end if
tl(m)=tl(m) &("</table><table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">")
rs.MoveNext
Next
topichtml=topichtml & unitetopic()
if rs.RecordCount Mod 2=0 then
topicc=" class=""otr"""
else
topicc=""
end if
topichtml=topichtml &"<tr class=""toptr""><td class=""tdc"" height=""20"" background=""../../"& defaulttheme &"02.gif""><strong><em><font size=2>"& rs.RecordCount &"</font></em></strong> L：</td></tr>"
if IsNull(rs("deler")) then
topichtml=topichtml &"<tr class=""tds""><td"& topicc &">"& unhtmlcode(rs("content"))
if rs("aboutlink")<>"" then topichtml=topichtml &"<br>相关链接：<a href="""& rs("aboutlink") &""" target=""_blank"">"& rs("aboutlink") &"</a>"
if rs("imglink")<>"" then topichtml=topichtml &"<br><img src="""& rs("imglink") &""" border=""0"">"
topichtml=topichtml & unhtmlcode(rs("remark")) &"</td></tr>"
else
topichtml=topichtml &"<tr class=""tds""><td"& topicc &"><font class=""del"">该回复已经被<a href=""../../sendmessage.asp?username="& rs("deler") &""" onClick=""return shows(this.href);"" title=""发送密信给 "& rs("deler") &""">"& rs("deler") &"</a>删除</font>。 <a href=""../../topictool.asp?explore="& rs("id") &""" onClick=""return showb(this.href+'&title="& rs("deler") &"');"" title=""使用 探察视镜 查看该被删除的回复"">使用道具</a></td></tr>"
end if
if rs("anonymity")<>"" then
topichtml=topichtml &"<tr class=""tds""><td"& topicc &"><a href=""../../replyedit.asp?id="& rs("id") &""" class=""anonymity"" title=""编辑回复"">神秘人物"& rs("anonymity") &"</a> <a href=""../../topictool.asp?reply="& rs("id") &""" onClick=""return shows(this.href+'&title="& rs("anonymity") &"');"" title=""使用 显影水晶 查看 神秘人物"& rs("anonymity") &""">使用道具</a> <font class=""del"">回复时间："& rs("posttime") &"</font></td></tr>"
else
topichtml=topichtml &"<tr class=""tds""><td"& topicc &"><a href=""../../replyedit.asp?id="& rs("id") &""" title=""编辑回复"">"& poster(rs("gbmaduser"),rs("admincolor")) &"</a> <a href=""../../sendmessage.asp?username="& rs("gbmaduser") &""" onClick=""return shows(this.href);"" title=""发送密信给 "& rs("gbmaduser") &""">发送密信</a> <a href=""../../userinfo.asp?username="& rs("gbmaduser") &""" onClick=""return showb(this.href);"" title=""查看用户 "& rs("gbmaduser") &" 的详细信息"">作者信息</a> <font class=""del"">回复时间："& rs("posttime") &"</font></td></tr>"
end if
topichtml=topichtml &"</table><table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table><br>"
end if
rs.Close

topichtml=topichtml &"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">"&_
"<tr class=""toptr""><td class=""tdc"" height=""20"" background=""../../"& defaulttheme &"02.gif"">回复帖子</td></tr>"&_
"<script language=""JavaScript"" src=""../../reply.asp?id="& id &"""></script>"&_
"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"">"&_
"<tr></tr>"&_
"</table>"&_

"</body>"&_
"</html>"
Set topicfsobj=topicfso.CreateTextFile(Server.MapPath("topic/"& link),true)
topicfsobj.Write topichtml
topicfsobj.Close
Set topicfsobj=Nothing
Set topicfso=Nothing
end Sub

Sub topicdel(link)
Dim topicfso
Set topicfso=CreateObject("Scripting.FileSystemObject")
topicfso.DeleteFile(Server.MapPath("topic/"& link))
Set topicfso=Nothing
end Sub
%>