<% function ops(a,t,s) 'a为被加分用户,t为total具体分数,s为spend具体分数;t或s为0表示不加减;减为负数) set rs7=server.createobject("adodb.recordset") sql7="select * from score where username='"& a &"'" rs7.open sql7,Application("dbconn"),1,3 if t<>0 then rs7("loginscore")=clng(rs7("loginscore"))+clng(t) if s<>0 then rs7("score")=clng(rs7("score"))+clng(s) rs7.update rs7.close() set rs7=nothing end function function check_score(u,sd) 'u为用户名,sd为所需要花费的分数 函数返回值0,1或者-1 set rs6=server.createobject("adodb.recordset") sql6="select * from score where username='"& u &"'" rs6.open sql6,Application("dbconn"),1,1 score1=clng(rs6("score")) rs6.close() set rs6=nothing if score1-sd>0 then check_score=1 if score1-sd=0 then check_score=0 if score1-sd<0 then check_score=-1 end function Function CheckTtlScore(u, sd) 'u为用户名,sd为所需要花费的分数 函数返回值0,1或者-1 Dim rs6, sql6 Set rs6 = Server.CreateObject("ADODB.Recordset") sql6 = "select * from score where username='"& u &"'" rs6.Open sql6,Application("dbconn"),1,1 score1 = Clng(rs6("loginscore")) rs6.close() Set rs6 = Nothing if score1-sd>0 then CheckTtlScore=1 if score1-sd=0 then CheckTtlScore=0 if score1-sd<0 then CheckTtlScore=-1 End Function function ologs(u1,u2,u2l,levent,t,s,board_id,topic_id,doc_id) 'u1接受分数用户,u2操作分数用户,u2l为U2的权限,事件中文说明, 't为total具体分数,s为spend具体分数;t或s为0表示不加减;减为负数) 'board_id为发生分数的板块id,不能为空或者0,必须是当前帖子回复所在BOARD 'topic_id为发生分数的主题id,当传回复时请传话题ID 'doc_id为发生分数的回复id,只是主题发生时请传0 '全部传数值型,勿传字符 set rs9=server.createobject("adodb.recordset") sql9="select * from score_log where id=1" rs9.open sql9,Application("dbconn"),1,3 rs9.addnew rs9("user1")=u1 rs9("user2")=u2 rs9("user2_level")=u2l rs9("board_id")=board_id rs9("topic_id")=topic_id rs9("doc_id")=doc_id rs9("event_time")=now if t<0 and s>=0 then rs9("event_detail")= levent &" "& cstr(t) &"T+" & cstr(s) &"S" elseif s<0 and t>=0 then rs9("event_detail")= levent &" +"& cstr(t) &"T" & cstr(s) &"S" elseif t<0 and s<0 then rs9("event_detail")= levent &" "& cstr(t) &"T" & cstr(s) &"S" else rs9("event_detail")= levent &" +"& cstr(t) &"T+" & cstr(s) &"S" end if rs9("IP")=Request.ServerVariables("REMOTE_ADDR") rs9.update rs9.close() set rs9=nothing end function function operate_score(user1,user2,score_event,board_id,topic_id,doc_id,ex) '================================================= '函数说明: 'user1为获得分数用户,传username;USER2为作改变分数动作的用户,直接传session("username"),系统自动加分为“system” 'score_event为发生分数操作的事件 'login 登录 +10 每天10分 total+spend score表:score为spend,loginscore为TOTAL 'lvmsg发LV贴,扣分-10%s 'gdtopic 主题精华 +20 total+spend 'gddoc 回复精华 +20 total+spend 'untopic 去推荐主题 -20 total+spend 'undoc 去推荐回复 -20 total+spend 'deltopic 删除主题 -20 spend 'deldoc 删除回复 -20 spend 'undeltopic撤销主题删除 +20 spend 'undeldoc 撤销回复删除 +20 spend 'pm 短消息 -1 spend 'uphead 上传头像 >1000 -20 spend 'mdtitle 修改title >2000 -100 spend 'uppic 上传图片 -20 spend 'sdscore 送分 spend 税率30% 'ex为送分和buy时候的分数量 'buyftp 购买FTP密码 spend 'board_id为发生分数的板块id,不能为空或者0,必须是当前帖子回复所在BOARD 'topic_id为发生分数的主题id,当传回复时请传话题ID 'doc_id为发生分数的回复id,只是主题发生时请传0 '全部传数值型,勿传字符 '================================================= ' ' ' ' ' '使用者IP地址 IP=Request.ServerVariables("REMOTE_ADDR") '判断USER2身份,因为该函数被USER2调用 if session("board_master")>0 then op=1 elseif session("NowDiGi")=true then op=2 elseif session("NowIPS")=true then op=3 elseif user2="system" then op=4 else op=0 end if '操作分数用户级别 if op=1 then user2_lv="master" elseif op=2 then user2_lv="seer" elseif op=3 then user2_lv="admin" elseif op=4 then user2_lv="system" elseif op=0 then user2_lv="user" end if '建立RS对象 set rs8=server.createobject("adodb.recordset") 'login 登录 if score_event="login" then '加分 sql8="select * from score where username='"&cstr(user1)&"'" 'response.write sql8 rs8.open sql8,Application("dbconn"),1,3 date1=date if date1 > rs8("lastlogindate") then lgs=clng(rs8("loginscore")) '+10 日常登录不加总分。 sps=clng(rs8("score")) + 30 ' 可用分加 30。 sql001="select * from board" set rs001=server.createobject("adodb.recordset") rs001.open sql001,Application("dbconn"),1,1 if rs001.bof and rs001.eof then ' else do while not rs001.eof master=master&cstr(rs001("board_master")) rs001.movenext loop if instr(master,cstr(user1)) > 0 then 'lgs=lgs+5 ' 版主每日登录总分不加 sps=sps+15 ' 可用分加 15 call ologs(user1,user2,user2_lv, "版主薪水", 0, 15, board_id, topic_id, doc_id) end if ' instr(master,cstr(user1)) > 0 end if ' rs001.bof and rs001.eof rs001.close() rs8("loginscore")=lgs rs8("score")=sps rs8("lastlogindate")=date rs8.update '写入记录 call ologs(user1,user2,user2_lv,"每日登录", 0, 30, board_id,topic_id,doc_id) end if ' date1 > rs8("lastlogindate") end if ' score_event="login" 'lvmsg 发LV贴 -10% spend if score_event="lvmsg" then 'LV发帖我想过了.就 0,1,10,20,30,40,50就行了.0反正是默认的. 1和10级的都减10分,20就减20分,30就减30分. '加分 'ex1=ex*0.1 'if ex1<1 then ex1=-1 'if ex1>1 then ex1=-ex1 Select Case ex Case 1, 10 ex1 = -10 Case Else ex1 = -ex End Select call ops(user1,0,ex1) '写入记录 call ologs(user1,user2,user2_lv,"发LV贴",0,ex1,board_id,topic_id,doc_id) end if Dim bonusTtl Dim bonusSpn bonusTtl = 20 bonusSpn = 20 GetBonusScoreValue board_id, bonusTtl, bonusSpn 'gdtopic 推荐主题 +20 total+spend if score_event="gdtopic" and op>0 then '加分 call ops(user1,bonusTtl,bonusSpn) '写入记录 call ologs(user1,user2,user2_lv,"主题鼓励",bonusTtl,bonusSpn,board_id,topic_id,doc_id) end if 'gddoc 推荐回复 +20 total+spend if score_event="gddoc" and op>0 then '加分 call ops(user1,bonusTtl,bonusSpn) '写入记录 call ologs(user1,user2,user2_lv,"回复鼓励",bonusTtl,bonusSpn,board_id,topic_id,doc_id) end if 'untopic 去推荐主题 -20 total+spend if score_event="untopic" and op>0 then '加分 call ops(user1,-bonusTtl,-bonusSpn) '写入记录 call ologs(user1,user2,user2_lv,"撤销鼓励主题",-bonusTtl,-bonusSpn,board_id,topic_id,doc_id) end if 'undoc 去推荐回复 -20 total+spend if score_event="undoc" and op>0 then '加分 call ops(user1,-bonusTtl,-bonusSpn) '写入记录 call ologs(user1,user2,user2_lv,"撤销鼓励回复",-bonusTtl,-bonusSpn,board_id,topic_id,doc_id) end if 'deltopic 删除主题 -2 spend if score_event="deltopic" and op>0 then '加分 call ops(user1,0,-2) '写入记录 call ologs(user1,user2,user2_lv,"删除主题",0,-2,board_id,topic_id,doc_id) end if 'deldoc 删除回复 -2 spend if score_event="deldoc" and op>0 then '加分 call ops(user1,0,-2) '写入记录 call ologs(user1,user2,user2_lv,"删除回复",0,-2,board_id,topic_id,doc_id) end if 'undeltopic 撤销删除主题 +20 spend if score_event="undeltopic" and op>0 then '加分 call ops(user1,0,+2) '写入记录 call ologs(user1,user2,user2_lv,"撤销主题删除",0,+2,board_id,topic_id,doc_id) end if 'undeldoc 撤销删除回复 +20 spend if score_event="undeldoc" and op>0 then '加分 call ops(user1,0,+2) '写入记录 call ologs(user1,user2,user2_lv,"撤销回复删除",0,+2,board_id,topic_id,doc_id) end if 'pm 短消息 -1 spend if score_event="pm" then '加分 call ops(user1,0,-1) '写入记录 call ologs(user1,user2,user2_lv,"短消息",0,-1,board_id,topic_id,doc_id) end if 'uphead 上传头像 >1000 -20 spend if score_event="uphead" then '加分 call ops(user1,0,-100) '写入记录 call ologs(user1,user2,user2_lv,"上传头像",0,-100,board_id,topic_id,doc_id) end if 'mdtitle 修改title >2000 -100 spend if score_event="mdtitle" then '加分 call ops(user1,0,-300) '写入记录 call ologs(user1,user2,user2_lv,"修改头衔",0,-300,board_id,topic_id,doc_id) end if 'uppic 上传图片 -10 spend if score_event="uppic" then '加分 call ops(user1,0,-20) '写入记录 call ologs(user1,user2,user2_lv,"上传图片",0,-20,board_id,topic_id,doc_id) end if 'sdscore 送分 spend if score_event="sdscore" then '加分 ex1=int(0.7*ex) ex=-ex call ops(user1,0,ex) call ops(user1,0,ex1) '写入记录 call ologs(user1,user2,user2_lv,"送分",0,ex,board_id,topic_id,doc_id) end if 'buyftp spend if score_event="buyftp" then ' ex=-ex call ops(user1,0,ex) '写入记录 call ologs(user1,user2,user2_lv,"购买FTP密码",0,ex,board_id,topic_id,doc_id) end if end function '======自由函数 function free_score(user1,user2,score_event,board_id,topic_id,doc_id,ext,exs) '加分 call ops(user1,ext,exs) '写入记录 call ologs(user1,user2,"system",score_event,ext,exs,board_id,topic_id,doc_id) end function Sub GetBonusScoreValue(ByVal boardId, ByRef ttl, ByRef spn) Dim rsBonus Dim strSql Set rsBonus = Server.CreateObject("ADODB.Recordset") strSql = "SELECT bonus_ttl, bonus_spn FROM board WHERE ID=" + CStr(boardId) rsBonus.Open strSql, Application("dbconn"), 1, 1 If (Not rsBonus.EOF) And (Not rsBonus.BOF) Then ttl = CInt(rsBonus("bonus_ttl")) spn = CInt(rsBonus("bonus_spn")) End If rsBonus.Close Set rsBonus = Nothing End Sub %> <% function wit(aa) qq=lcase(aa) bb=replace(qq,"'","’") cc=replace(bb,"select","(select)") dd=replace(cc,"update","(update)") ee=replace(dd,"exec","(exec)") ff=replace(ee,"delete","(delete)") gg=replace(ff,"insert","(insert)") hh=replace(gg,"drop","(drop)") ii=replace(hh,"master ","(master)") jj=replace(ii,"count","(count)") wit=jj end function function requestWIT(luker) a=request(luker) if IsNumeric(REQUEST(luker)) then requestWIT=cstr(REQUEST(luker)) else requestWIT=wit(request(luker)) end if end function Function BoardAllowPasteImg(boardId) BoardAllowPasteImg = False If IsNumeric(boardId) Then Dim rs Set rs = Server.CreateObject("ADODB.Recordset") Dim strSQL strSQL = "SELECT img_board FROM board WHERE (ID = " + CStr(boardId) + ")" rs.Open strSQL, Application("dbconn"), 1, 1 If Not (rs.BOF Or rs.EOF) Then BoardAllowPasteImg = (CInt(rs(0)) = 1) End If End If End Function function check_format(bbb) aaa=trim(bbb) if instr(aaa," or ")>0 or instr(aaa,"|")>0 or instr(aaa,"'")>0 or aaa="" then check_format=0 else check_format=1 end if end function function check_email(bbb) aaa=trim(bbb) if instr(aaa," or ")>0 or instr(aaa,"|")>0 or instr(aaa,"'")>0 or instr(aaa,"@")=0 or instr(aaa,".")=0 or aaa="" then check_email=0 else check_email=1 end if end function function doCode1(str) str=replace(replace(server.htmlencode(str),chr(32),"%20"),chr(13),"
") doCode1=str end function function doCode(str) str=replace(replace(server.htmlencode(str),chr(32)," "),chr(13),"
") doCode=str end function function undoCode(str) str=replace(replace(str," ",chr(32)),"
",chr(13)) undoCode=str end function function HTMLEncode(fString) fString = server.htmlencode(fString) fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") fString = replace(fString, " ", " ") fString = Replace(fString, CHR(13), "") fString = Replace(fString, CHR(10) & CHR(10), "

") fString = Replace(fString, CHR(10), "
") HTMLEncode = fString end function function HTMLDecode(fString) fString = replace(fString, " ", "_") fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") fString = Replace(fString, "", CHR(13)) fString = Replace(fString, "

", CHR(10) & CHR(10)) fString = Replace(fString, "
", CHR(10)) HTMLDecode = fString end function function showpic(strcontents) jj=instrrev(strcontents,"[showsign]") for i=1 to jj i=instr(i,strcontents,"[showsign]") k=k+1 next for h=1 to k strcontents=replace(strcontents,"[showsign]",cstr(int(rnd()*10000000)+h),1,2) next showpic=strcontents end function function UBBCode(strContent,bbcolor) 'strContent=server.htmlencode(strContent) dim re set re = New RegExp re.Global = True re.IgnoreCase = True ' re.MultiLine = True re.Pattern = "\[url=(.[^\]]*)\](.[^\[]*)\[\/url]" strContent = re.Replace(strContent,"$2") re.Pattern = "\[url](.[^\[]*)\[\/url]" strContent = re.Replace(strContent,"$1") re.Pattern = "\[FLASH](.[^\[]*)\[\/FLASH]" strContent = re.Replace(strContent,"$1") ' re.Pattern="\[IMG](.[^\[]*)\[\/IMG]" ' strContent=re.Replace(strContent,"") re.Pattern="\[FLY](.[^\[]*)\[\/FLY]" strContent=re.Replace(strContent,"$1") re.Pattern="\[MOVE](.[^\[]*)\[\/MOVE]" strContent=re.Replace(strContent,"$1") re.Pattern="\[COLOR=(.[^\]]*)\](.[^\[]*)\[\/COLOR]" strContent=re.Replace(strContent,"$2") re.Pattern = "\[b](.[^\[]*)\[\/b]" strContent = re.Replace(strContent,"$1") re.Pattern = "\[I](.[^\[]*)\[\/I]" strContent = re.Replace(strContent,"$1") re.Pattern = "\[u](.[^\[]*)\[\/u]" strContent = re.Replace(strContent,"$1") re.Pattern ="\[size=1](.[^\[]*)\[\/size]" strContent = re.Replace(strContent,"$1") re.Pattern ="\[size=2](.[^\[]*)\[\/size]" strContent = re.Replace(strContent,"$1") re.Pattern ="\[size=3](.[^\[]*)\[\/size]" strContent = re.Replace(strContent,"$1") re.Pattern ="\[size=4](.[^\[]*)\[\/size]" strContent = re.Replace(strContent,"$1") if instr(lcase(strContent),"script:")>0 or instr(lcase(strContent),"script>")>0 then temp= server.htmlencode(strContent) else temp= strContent end if re.Pattern="\[IMG](.[^\[]*)\[\/IMG]" temp=re.Replace(temp,"800) this.width=800;"" src=""$1"" onload=""if (this.width>800) this.width=800;"" align=""absmiddle"" border=""0"" onclick=""window.open(this.src);"" style=""cursor:hand"">") UBBCode=temp end function function checklen(strings,lens) '检查strings的长度是否超过预期 dim l,t,c,i l=len(trim(strings)) t=0 for i=1 to l c=Abs(Asc(Mid(strings,i,1))) if c>255 then t=t+2 else t=t+1 end if next if t>cint(lens) then checklen=1 else checklen=0 end if end function function cutstr(stringss,lenss) '切割预期长度的str dim l,t,c,i l=len(trim(stringss)) t=0 for i=1 to l c=Abs(Asc(Mid(stringss,i,1))) if c>255 then if t+2>=cint(lenss) then cutstr=m exit for end if t=t+2 else if t+1>=cint(lenss) then cutstr=m exit for end if t=t+1 end if m=m+Mid(stringss,i,1) next end function function addbr(stringsss,lensss) '换行函数 dim l,t,c,i,g l=len(trim(stringsss)) t=0 g=0 for i=1 to l c=Abs(Asc(Mid(stringsss,i,1))) m=Mid(stringsss,i,1) if c>255 then if g+2>=cint(lensss) then addstr=addstr&"
"&m g=2 else addstr=addstr&m g=g+2 end if else if g+1>=cint(lensss) then addstr=addstr&"
"&m g=1 else addstr=addstr&m g=g+1 end if end if next addbr=addstr end function function shownow(nows) '显示新格式日期 if len(month(nows))=1 then months="0"+cstr(month(nows)) else months=cstr(month(nows)) end if if len(day(nows))=1 then days="0"+cstr(day(nows)) else days=cstr(day(nows)) end if if len(hour(nows))=1 then hours="0"+cstr(hour(nows)) else hours=cstr(hour(nows)) end if if len(minute(nows))=1 then minutes="0"+cstr(minute(nows)) else minutes=cstr(minute(nows)) end if shownow=right(year(nows),2)+"/"+months+"/"+days+" "+hours+":"+minutes end function ' 生成认证会员标志图片 HTML Function GenCertUserImg(ByVal username) If IsCertUser(username) = True Then GenCertUserImg = "" Else GenCertUserImg = "" End If End Function ' 判断用户是否已认证。 Function IsCertUser(ByVal username) Dim r Set r = Server.CreateObject("ADODB.Recordset") r.Open "SELECT COUNT(*) FROM CertUsers WHERE username='" & username & "'", Application("dbconn"), 1, 1 If r(0) > 0 Then IsCertUser = True Else IsCertUser = False End If r.Close Set r = Nothing End Function ' 是否显示认证用户签名。 Function IsCertUserSigVisible(ByVal username) Dim r Set r = Server.CreateObject("ADODB.Recordset") r.Open "SELECT COUNT(*) FROM CertUsers WHERE username='" & username & "' AND showSig=1", Application("dbconn"), 1, 1 If r(0) > 0 Then IsCertUserSigVisible = True Else IsCertUserSigVisible = False End If r.Close Set r = Nothing End Function ' 设置认证用户的签名。 Sub SetCertUserSig(ByVal username, ByVal strSig, ByVal bShow) Dim conn Dim strSql strSig = Replace(strSig, "'", "''") strSql = "UPDATE CertUsers SET sig=LEFT('{1}', 100), showSig={2} WHERE username='{0}'" strSql = Replace(strSql, "{0}", username) strSql = Replace(strSql, "{1}", HTMLDecode(strSig)) If bShow = True Then strSql = Replace(strSql, "{2}", "1") Else strSql = Replace(strSql, "{2}", "0") End If Set conn = Server.CreateObject("ADODB.Connection") conn.Open Application("dbconn") conn.Execute strSql conn.Close Set conn = Nothing End Sub ' 获得认证用户的签名。 Function GetCertUserSig(ByVal username, ByVal inHtml) Dim r Dim strResult Set r = Server.CreateObject("ADODB.Recordset") If inHtml = True Then ' 如果是 HTML 格式,就要考虑“是否显示”选项。 r.Open "SELECT sig FROM CertUsers WHERE username='" & username & "' AND showSig=1", Application("dbconn"), 1, 1 Else r.Open "SELECT sig FROM CertUsers WHERE username='" & username & "'", Application("dbconn"), 1, 1 End If If (Not r.BOF) And (Not r.EOF) Then If IsNull(r("sig")) Then strResult = "" Else strResult = CStr(r("sig")) End If If inHtml = True Then strResult = HTMLEncode(strResult) Dim re Set re = New RegExp re.Global = True re.IgnoreCase = True re.Pattern = "\[COLOR=(.[^\]]*)\](.[^\[]*)\[\/COLOR]" strResult = re.Replace(strResult,"$2") re.Pattern = "\[b](.[^\[]*)\[\/b]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[I](.[^\[]*)\[\/I]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[u](.[^\[]*)\[\/u]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[size=1](.[^\[]*)\[\/size]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[size=2](.[^\[]*)\[\/size]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[size=3](.[^\[]*)\[\/size]" strResult = re.Replace(strResult,"$1") re.Pattern = "\[size=4](.[^\[]*)\[\/size]" strResult = re.Replace(strResult,"$1") End If GetCertUserSig = strResult Else GetCertUserSig = "" End If r.Close Set r = Nothing End Function ' 为一个帖子附加投票记录 Function AttachVoteToTopic(ByVal topicID, ByVal voteXML) voteXML = Replace(voteXML, "'", "''") Dim conn Dim strSql strSql = "INSERT INTO VoteInfo (topicID, voteXML) VALUES ({0},'{1}')" strSql = Replace(strSql, "{0}", topicID) strSql = Replace(strSql, "{1}", voteXML) Set conn = Server.CreateObject("ADODB.Connection") conn.Open Application("dbconn") conn.Execute strSql conn.Close Set conn = Nothing End Function ' 显示投票 Function ShowVote(ByVal topicID) On Error Resume Next Dim rVote Set rVote = Server.CreateObject("ADODB.Recordset") rVote.Open "SELECT voteXML FROM VoteInfo WHERE topicID=" + CStr(topicID), Application("dbconn"), 1, 1 If (Not rVote.BOF) And (Not rVote.EOF) Then Dim xmlDom Set xmlDom = Server.CreateObject("MSXML.DOMDocument") xmlDom.async = False xmlDom.loadXML(rVote("voteXML")) Dim root Set root = xmlDom.documentElement Dim voteDesc, strVoteDesc Set voteDesc = root.selectSingleNode("//VoteInfo/Description") strVoteDesc = voteDesc.text Dim voteInfo, strVoteType Set voteInfo = root.selectSingleNode("//VoteInfo") strVoteType = voteInfo.getAttribute("type") Dim timesVoted Dim opt, opts timesVoted = 0 Set opts = root.selectNodes("//VoteInfo/Option") Dim votedUsers, votedUserCount Set votedUsers = root.selectNodes("//VotedUserList/User") votedUserCount = votedUsers.length Set votedUsers = Nothing For Each opt In opts timesVoted = timesVoted + CInt(opt.getAttribute("count")) Next Dim strResult strResult = "

" strResult = strResult + "" strResult = strResult + "" strResult = strResult + "" strResult = strResult + "" strResult = strResult + "" Dim strAlpha strAlpha = "filter:progid:DXImageTransform.Microsoft.Alpha( Opacity=100, FinishOpacity=20, Style=1, StartX=0, FinishX=0, StartY=60, FinishY=0);" For Each opt In opts Dim bgColor, fColor bgColor = Rnd(Timer) * &HFFFFFF fColor = Not bgColor Dim nWidth If timesVoted > 0 Then nWidth = FormatNumber(CDbl(opt.getAttribute("count")) / timesVoted * 100, 1) Else nWidth = 0 End If strResult = strResult + "" strResult = strResult + "" Next strResult = strResult + "" strResult = strResult + "
" + HTMLEncode(strVoteDesc) + "(已经有 " + CStr(votedUserCount) + " 人投票)
" Dim strCtlID strCtlID = "ctl" + CStr(CInt(Rnd(Timer) * 1000)) If strVoteType = "m" Then strResult = strResult + "" Else strResult = strResult + "" End If strResult = strResult + "" If nWidth > 0 Then strResult = strResult + "
" + CStr(nWidth) + "%
" Else strResult = strResult + "(尚无得票)" End If strResult = strResult + "
" Response.Write strResult End If rVote.Close Set rVote = Nothing End Function ' 投票,如果没有发生错误,返回一个空字符串,否则返回错误信息。 Function Vote(ByVal topicID, ByVal options) Dim username username = LCase(Session("username")) If username = "" Then Vote = "必须先登录才能投票" Exit Function End If If UBound(options) < 0 Then Vote = "没有作任何选择。" Exit Function End If If IsUserVoted(topicID, username) Then Vote = "您已经投过票了。" Exit Function End If ' 开始处理投票 Dim r Set r = Server.CreateObject("ADODB.Recordset") r.Open "SELECT * FROM VoteInfo WHERE topicID=" + CStr(topicID), Application("dbconn"), 1, 3 If (Not r.BOF) And (Not r.EOF) Then Dim xmlDom Set xmlDom = Server.CreateObject("MSXML.DOMDocument") xmlDom.async = False xmlDom.loadXML(r("voteXML")) Dim strOpt For Each strOpt In options Dim opt Dim count Set opt = xmlDom.selectSingleNode("//VoteInfo/Option[. = """ + Replace(Replace(strOpt, "\", "\\"), """", "\""") + """]") count = CInt(opt.getAttribute("count")) + 1 opt.setAttribute "count", CStr(count) Next Dim u Set u = xmlDom.createElement("User") u.text = username xmlDom.documentElement.selectSingleNode("//VotedUserList").appendChild(u) r("voteXML") = xmlDom.xml r.Update Else Vote = "没有找到相关的投票信息。" End If r.Close Set r = Nothing Vote = "" End Function Function IsUserVoted(ByVal topicID, ByVal username) IsUserVoted = False Dim r Set r = Server.CreateObject("ADODB.Recordset") r.Open "SELECT voteXML FROM VoteInfo WHERE topicID=" + CStr(topicID), Application("dbconn"), 1, 1 If (Not r.BOF) And (Not r.EOF) Then Dim xmlDom Set xmlDom = Server.CreateObject("MSXML.DOMDocument") xmlDom.async = False xmlDom.loadXML(r("voteXML")) Dim votedUser Set votedUser = xmlDom.documentElement.selectNodes("//VotedUserList/User[. = """ + username + """]") If Not votedUser Is Nothing Then IsUserVoted = (votedUser.length >= 1) End If End If r.Close Set r = Nothing End Function Function TopicHasVote(ByVal topicID) Dim r Set r = Server.CreateObject("ADODB.Recordset") r.Open "SELECT COUNT(*) FROM VoteInfo WHERE topicID=" + CStr(topicID), Application("dbconn"), 1, 1 TopicHasVote = r(0) > 0 r.Close Set r = Nothing End Function %>
  " class="text"> onClick="return submitsearch();">
    &Favorites=y">[收藏区] [乐透区] [购物] [N档案] 
<% if instr(1,application("killed_user"),cstr(session.SessionID)&";",1) > 0 then session.Abandon () end if %> <% if session("username")<>"" then sql1="select * from msg where reciver='"& session ("username") &"' and readed='n' order by send_time desc" set rs1=server.createobject("adodb.recordset") rs1.open sql1,Application("dbconn"),1,1 if rs1.recordcount>0 then msg_num=rs1.recordcount end if rs1.close() end if %>
<%if msg_num>0 then%><%else%><%end if%>
Online User: <% Dim rsUser Set rsUser = Server.CreateObject("ADODB.Recordset") rsUser.Open "SELECT COUNT(*) FROM _SessionLog", Application("dbconn"), 1, 1 Response.Write rsUser(0).Value rsUser.Close Set rsUser = Nothing %> 4


一、我要如何得分?
得分方式有以下几种(不声明都为加总积分和可用分):
  1. 登录计分,一天加 10分;
  2. 发帖得分,好的主帖及回帖都有可能加分,加分一次是20分(这是得分主要的途径,所以希望大家要多发好帖,也要多帮助别人);
  3. 参加各种NDG的活动,新论坛开始,一直会在各区搞一些可以加分的活动,请大家认真和积极的参与,回帖;
  4. 为NDG提出好的建议,一经采用,将酌情给予相应的加分;
  5. 报告BUG,发现BUG后,及时报告ADMIN,也将酌情给予相应的加分。

二、我的分有什么用?
  1. 分数为二种:总积分和可使用积分;
  2. 积分功能可分为5档:1000分、2000分、5000分、10000分、20000分;
  3. 相应的功能是:
    • 总积分到1000:开通头像功能(目前暂为300分),改一次头像是减少20的可使用分;
    • 总积分到2000:开通头衔功能,只能设置一次;
    • 总积分到5000:开通头衔更改功能,更改一次减少100分可使用分。同时开通送分功能,届时可以将自己的分送给自己的好友;不过接收方只能得到所送分的70%;
    • 总积分到10000:将开通图片上传功能,可以在各个区使用此功能。上传一个图片,将减少20的可使用分;
    • 总积分到20000,将赠送NDG EML一个,免费使用。
  4. 短信功能一经注册,即可使用,发送一条短信将减少1的可使用分;
  5. 发表LV帖,减相应LV的10%的可使用积分;
  6. 如果帖子被删,将减少可使用积分2分;
  7. 其它新功能正在策划中,如有好建议可以去系统区提出,可以得到加分,大家努力。

三、BBS各种功能说明
  1. 推荐和举报功能:如果你觉得帖子不错,而没得精华的,可以点推荐;
    如果觉得帖子比较恶心、下流,或者违反BBS管理条列的,可以点举报。管理员在例行检查时会留意这些帖子;
  2. 图片拉动功能:图片在新的BBS中显示定了580*320,不管你贴多大的图,只能在这个范围中显示,但你可以在这个范围内拉动;
  3. 帖子右方B1,B2,B3...的意思. 按以前一楼二楼来说,是一种错误的说法,所以主楼下一帖就为B1,第二帖是B2,以此类推。(意思嘛,大家都应该知道:地下一层,地下二层.....)

四、关于UBB代码的使用

插图
[img]图片的URL[/img]

插入URL 方法一
[url=具体的URL]你想写的内容[/url]

来回移动的文字
[fly]文字[/fly]

颜色字
[color=颜色]内容[/color]

斜体
[I]内容[/I]

字的大小
[size=1,2,3,4]内容[/size]

插入FLASH
[flash]FLASH的URL[/flash]

插入URL 方法二
[url]具体URL[/url]

滚动的文字
[move]文字[/move]

粗体
[b]内容[/b]

下划线
[U]内容[/U]