<% 
' 活跃度插件V2.0 Beta1 For DVBBS 7.1
' 插件作者：若阑
' 网址：QQ电子宠物社区 http://www.qqpet.com/
' 演示地址：http://bbs.huians.com/dispbbs.asp?boardID=61&ID=22124&page=1
' 发布方式：免费
' 编写时间: 2005-03-20
' 功能描述：插件用于添加两个论坛参数，活跃度和在线时间，参数有后台设置
' Copyright (C) 2005
Const RL_ActiveVer = 710		' 如果是DV7.1 就设置成710
'在线时长统计
Dim RL_ActiveSetting,RL_StartTime,RL_Sql,RL_Rs
Dim g_RLActiveValue,g_RLActiveMax,g_RLActiveWord,g_RLOnline
Dim g_ShowXSLStr
g_ShowXSLStr="<br/><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text>活跃度：<xsl:value-of select=""""@RLActive""""/>/<xsl:value-of select=""""@RLActiveMax""""/>"
g_ShowXSLStr=g_ShowXSLStr & "<br/><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text>活跃等级：<xsl:value-of select=""""@RLActiveWord""""/>"
g_ShowXSLStr=g_ShowXSLStr & "<br/><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text><xsl:text disable-output-escaping=""""yes"""" >&amp;nbsp;&amp;nbsp;</xsl:text>在线等级：<xsl:value-of select=""""@RLActOnline""""/>"

RL_ActiveSetting = split(Dvbbs.forum_setting(88),"@@")
if CLng(Ubound(RL_ActiveSetting))<>18 then
	RL_ActiveSetting="1@@20@@5@@100*500*1000*5000@@①年迈乌龟*②懒惰白猪*③活泼小兔*④生猛海鲜@@1@@skins/default/bar/bar1.gif@@skins/default/bar/bar5.gif@@1@@3@@0@@0@@恭喜,你的在线等级已经升了一级@@0*0*0*0*0*0*0*0@@0*0*0*0*0*0*0*0@@15@@5@@1@@1"
	RL_ActiveSetting=split(RL_ActiveSetting,"@@")
end if
RL_Sql="select RLStartTime from DV_User where UserID=" & Dvbbs.UserID
Set RL_Rs=Dvbbs.Execute(RL_Sql)
if not RL_Rs.eof then
	RL_StartTime=RL_Rs(0)
else
	RL_StartTime=Now()
end if
RL_Rs.Close
Set RL_Rs=nothing

' 更新在线时间
Sub UpdateOnlineTime()
	Dim RL_ActOnTime,RL_ActOnline
	if Dvbbs.ScriptName="list.asp" Or Dvbbs.ScriptName="dispbbs.asp" then
		' 定义JS变量
		Response.Write("<Script Language=""javascript"">")
		Response.Write("var RL_ActiveValue='';") 		'活跃度显示
		Response.Write("var RL_ActiveValueMax='';") 	'活跃度最大值显示
		Response.Write("var RL_ActiveWord='';") 		'活跃度等级显示
		Response.Write("var RL_Online='';") 			'在线等级显示
		Response.Write("</script>")
		
		Dvbbs.Board_Setting(68)=split(Dvbbs.Board_Setting(68),"*")
		if cint(RL_ActiveSetting(17))=1 then
			if GetTotalOnline(Dvbbs.MemberName) < Clng(Dvbbs.Board_Setting(68)(0)) then
				Response.redirect "showerr.asp?ErrCodes=<li>在线时间不够<font color=red>"&Clng(Dvbbs.Board_Setting(68)(0))&"</font>分钟。无法进入本版面&action=OtherErr"
			end if
		end if
		if cint(RL_ActiveSetting(18))=1 and Ubound(Dvbbs.Board_Setting(68))>=1 then
			if GetActiveCount(Dvbbs.MemberName) < Clng(Dvbbs.Board_Setting(68)(1)) then
				Response.redirect "showerr.asp?ErrCodes=<li>活跃度不够<font color=red>"&Clng(Dvbbs.Board_Setting(68)(1))&"</font>。无法进入本版面&action=OtherErr"
			end if
		end if
	end if
	
	if IsNull(Session("RLActiveOnline")) or not IsDate(Session("RLActiveOnline")) then
		Session("RLActiveOnline")=Now()
	''''''''如果停留5分钟'''''''''''''''''
	else
		RL_ActOnTime = DateDiff("s",Session("RLActiveOnline"),Now())
		if RL_ActOnTime>=CLng(RL_ActiveSetting(9))*60 then
			Session("RLActiveOnline")=Now()
			' 读取原来等级,看是否已经升级
			RL_Sql = "select RLActTimeT from Dv_User where UserId=" & Dvbbs.UserID
			Set RL_Rs = Dvbbs.Execute(RL_Sql)
			if not RL_Rs.eof then
				RL_ActOnline = RL_Rs("RLActTimeT")

				' 更新在线等级
				RL_Sql = "update Dv_User set RLActTimeT = RLActTimeT + " & CLng( RL_ActOnTime \ 60 )
				if DateDiff("d", RL_StartTime, Now()) >= CLng(RL_ActiveSetting(2)) then
					RL_Sql = RL_Sql & ", RLTopicCountA = 0, RLActTimeA = 0, RLStartTime="&SqlNowString
				else
					RL_Sql = RL_Sql & ", RLActTimeA = RLActTimeA + " & CLng( RL_ActOnTime \ 60 )
				end if
				RL_Sql = RL_Sql & " where UserId=" & Dvbbs.UserID
				Dvbbs.Execute(RL_Sql)
				
				' 如果在线等级升级
				Dim TempClass,Sms
				TempClass=GetOnlineClass(RL_ActOnline + CLng( RL_ActOnTime \ 60 ))
				if GetOnlineClass(RL_ActOnline) < TempClass then
					if cint(RL_ActiveSetting(10))=1 then
						Sms=AdwardOnlineUp(TempClass)	' 奖励用户
					end if
					if cint(RL_ActiveSetting(11))=1 then
						SMSOnlineUp TempClass,Sms		' 短信通知
					end if
				end if

			end if
			RL_Rs.Close
			Set RL_Rs = Nothing
		end if
	end if
end Sub

' 更新发贴数目
Sub UpdatePostCount()
	if RL_ActiveSetting(8) = "1" then
		RL_Sql = "update Dv_User set RLTopicCountA = RLTopicCountA + 1" & " where UserId=" & Dvbbs.UserID
		Dvbbs.Execute(RL_Sql)
	end if
End Sub

' 获取活跃度数值
Function GetActiveCount(RL_UserName)
	Dim RL_ActiveCount, RL_ActTimeA, RL_TopicCountA, RL_Days
	RL_Sql="select  RLActTimeA, RLTopicCountA from DV_User where UserName='" & RL_UserName & "'"
	Set RL_Rs=Dvbbs.Execute(RL_Sql)
	if not RL_Rs.eof then
		RL_ActTimeA = RL_Rs(0)
		RL_TopicCountA = RL_Rs(1)
	else
		RL_ActTimeA = 0
		RL_TopicCountA = 0
	end if
	RL_Rs.Close
	Set RL_Rs=nothing

	RL_Days=DateDiff("d", RL_StartTime, Now())+1
	RL_ActiveCount = (RL_ActTimeA \ RL_Days) * RL_ActiveSetting(0) + (RL_TopicCountA \ RL_Days) * CLng(RL_ActiveSetting(1)) '计算公式 活跃度 = 平均在线时间 * 权重 + 平均发贴 * 权重
	GetActiveCount = RL_ActiveCount
End Function

' 获取在线时间
Function GetTotalOnline(RL_UserName)
	Dim RL_TotalOnline
	RL_Sql="select RLActTimeT from DV_User where UserName='" & RL_UserName & "'"
	Set RL_Rs=Dvbbs.Execute(RL_Sql)
	if not RL_Rs.eof then
		RL_TotalOnline = RL_Rs(0)
	else
		RL_TotalOnline = 0
	end if
	RL_Rs.Close
	Set RL_Rs=nothing

	GetTotalOnline = RL_TotalOnline
End Function

' 获取在线和活跃度的文字信息,返回给4个JS变量RL_ActiveValue,RL_ActiveValueMax,RL_ActiveWord,RL_Online
Sub GetActiveEachInfo(RL_UserName)
	Dim RL_Str,RL_ActiveCount,RL_Days, RL_UserClass, RL_NextClassNeed, RL_ActTimeT, RL_ActTimeA, RL_TopicCountA, RL_ActLevel,RL_ActLevelStr,i
	RL_Sql="select RLActTimeT, RLActTimeA, RLTopicCountA from DV_User where UserName='" & RL_UserName & "'"
	Set RL_Rs=Dvbbs.Execute(RL_Sql)
	if not RL_Rs.eof then
		RL_ActTimeT = RL_Rs(0)
		RL_ActTimeA = RL_Rs(1)
		RL_TopicCountA = RL_Rs(2)
	else
		RL_ActTimeT = 0
		RL_ActTimeA = 0
		RL_TopicCountA = 0
	end if
	RL_Rs.Close
	Set RL_Rs=nothing
	' 是否要活跃度
	if RL_ActiveSetting(8) = "1" then 
		RL_Days=DateDiff("d", RL_StartTime, Now())+1
		RL_ActiveCount = (RL_ActTimeA \ RL_Days) * RL_ActiveSetting(0) + (RL_TopicCountA \ RL_Days) * CLng(RL_ActiveSetting(1)) '计算公式 活跃度 = 平均在线时间 * 权重 + 平均发贴 * 权重
		RL_ActLevel = Split( RL_ActiveSetting(3), "*" )
		RL_ActLevelStr = Split( RL_ActiveSetting(4), "*" )
		
		RL_Str = ""
		For i=0 to Ubound(RL_ActLevel)
			if RL_ActiveCount < CLng(RL_ActLevel(i)) then
				RL_Str = RL_ActLevelStr(i)
				Exit For
			end if
		Next
		'i=UBound(RL_ActLevel)
		' 超过最大值
		if i>UBound(RL_ActLevel) then
			i=UBound(RL_ActLevel)
			RL_ActiveCount=RL_ActLevel(i)
			RL_Str = RL_ActLevelStr(UBound(RL_ActLevelStr))&"↑"
		end if
		
		 g_RLActiveValue = RL_ActiveCount
		 g_RLActiveMax = RL_ActLevel(i)
		 g_RLActiveWord = RL_Str
		 
		'Response.Write("RL_ActiveValue='"&RL_ActiveCount&"';") '活跃度进变量
		'Response.Write("RL_ActiveValueMax='"&RL_ActLevel(i)&"';") '活跃度最大值进变量
		'Response.Write("RL_ActiveWord='"&RL_Str&"';") '活跃度等级进变量
	else
		'Response.Write("RL_ActiveValue='';") '活跃度进变量
		'Response.Write("RL_ActiveValueMax='';") '活跃度最大值进变量
		'Response.Write("RL_ActiveWord='';") '活跃度等级进变量
		g_RLActiveValue = ""
		g_RLActiveMax = ""
		g_RLActiveWord = ""
	end if
	if RL_ActiveSetting(5) = "1" then 
		RL_UserClass = 0
		RL_NextClassNeed = 0
		
		For i=1 to 100
			if RL_ActTimeT \ 60 < CLng(RL_ActiveSetting(16))*i*i + CLng(RL_ActiveSetting(15))*i then 
				RL_NextClassNeed = (CLng(RL_ActiveSetting(16))*i*i + CLng(RL_ActiveSetting(15))*i)*60 - RL_ActTimeT
				Exit For
			end if
			RL_UserClass = RL_UserClass + 1
			
		Next
		
		
		RL_Str = ""
		Dim TempStr

		TempStr = "在线:"&RL_ActTimeT \ 60&"小时"&RL_ActTimeT mod 60&"分钟.&#13&#10离升级差"&RL_NextClassNeed\60&"小时"&RL_NextClassNeed mod 60&"分钟.&#13&#10目前等级:"&RL_UserClass&""
				
		if RL_UserClass = 0 then
			RL_Str = RL_Str &"||"& "Images/noclass.gif" & "||" & TempStr&"||"&".还没有等级.加油使星星变颜色哦"
		end if
		
		
		For i=1 to RL_UserClass \ 16
			RL_Str = RL_Str & "<img src=""Images/time_sun.gif"" alt="""&TempStr&""">"
		Next
		RL_UserClass = RL_UserClass mod 16
		
		For i=1 to RL_UserClass \ 4
			RL_Str = RL_Str & "<img src=""Images/time_yueliang.gif"" alt="""&TempStr&""">"
		Next
		RL_UserClass = RL_UserClass mod 4
		
		For i=1 to RL_UserClass
			RL_Str = RL_Str & "<img src=""Images/time_star.gif"" alt="""&TempStr&""">"
		Next
		'Response.Write("RL_Online='"&RL_Str&"';") '在线等级进变量
		g_RLOnline = RL_ActTimeT
	else
		'Response.Write("RL_Online='';") '在线等级进变量
		g_RLOnline = 0
	End if
End Sub

' 计算在线等级
Function GetOnlineClass(l_RLActTimeT)
Dim RL_UserClass,i

	RL_UserClass = 0
	
	For i=1 to 100
		if l_RLActTimeT \ 60 < CLng(RL_ActiveSetting(16))*i*i + CLng(RL_ActiveSetting(15))*i then 
			Exit For
		end if
		RL_UserClass = RL_UserClass + 1
	Next
	
	GetOnlineClass = RL_UserClass
End Function

' 从在线数值返回在线图片
Function GetOnlineClassPic(RL_ActTimeT)
Dim RL_UserClass,RL_NextClassNeed,RL_Str,TempStr,i

	RL_UserClass = 0
	RL_NextClassNeed = 0
	
	For i=1 to 100
		if RL_ActTimeT \ 60 < CLng(RL_ActiveSetting(16))*i*i + CLng(RL_ActiveSetting(15))*i then 
			RL_NextClassNeed = (CLng(RL_ActiveSetting(16))*i*i + CLng(RL_ActiveSetting(15))*i)*60 - RL_ActTimeT
			Exit For
		end if
		RL_UserClass = RL_UserClass + 1
		
	Next
	
	
	RL_Str = ""

	TempStr = "在线:"&RL_ActTimeT \ 60&"小时"&RL_ActTimeT mod 60&"分钟.&#13&#10离升级差"&RL_NextClassNeed\60&"小时"&RL_NextClassNeed mod 60&"分钟.&#13&#10目前等级:"&RL_UserClass&""
			
	if RL_UserClass = 0 then
		RL_Str = RL_Str & "<img src=""Images/noclass.gif"" alt="""&TempStr&""">"
	end if
	
	
	For i=1 to RL_UserClass \ 16
		RL_Str = RL_Str & "<img src=""Images/time_sun.gif"" alt="""&TempStr&""">"
	Next
	RL_UserClass = RL_UserClass mod 16
	
	For i=1 to RL_UserClass \ 4
		RL_Str = RL_Str & "<img src=""Images/time_yueliang.gif"" alt="""&TempStr&""">"
	Next
	RL_UserClass = RL_UserClass mod 4
	
	For i=1 to RL_UserClass
		RL_Str = RL_Str & "<img src=""Images/time_star.gif"" alt="""&TempStr&""">"
	Next
	
	GetOnlineClassPic = RL_Str
End Function

' 返回在线最高排名
Function GetTopTen()
Dim RL_WORD,RL_i,RL_Days,RL_ActiveCount
	RL_Sql = "select Top 10 UserName,RLActTimeT from Dv_User order by RLActTimeT desc"
	Set RL_Rs=Dvbbs.Execute(RL_Sql)
	if not RL_Rs.eof then
		RL_i = 0
		RL_WORD = "<table width=""100%""><tr><td colspan=5>在线等级:</td><tr>"
		Do While not RL_Rs.eof and RL_i<10
			RL_WORD = RL_WORD &"<td>"& RL_i+1 &".<a href=""dispuser.asp?name="&RL_Rs(0)&""" target=""_blank"">"
			if RL_Rs(0)=Dvbbs.MemberName then
				RL_WORD = RL_WORD &"<font color=blue>"&RL_Rs(0)&"</font>"
			else
				RL_WORD = RL_WORD &RL_Rs(0)
			end if
			RL_WORD = RL_WORD & "</a>"&GetOnlineClassPic(RL_Rs(1))&"</td>"
			RL_i = RL_i+1
			if RL_i=5 then RL_WORD = RL_WORD & "</tr><tr>"
			RL_Rs.MoveNext
		Loop
		RL_WORD = RL_WORD & "</tr></table>"
	else
		RL_WORD = "还没有用户"
	end if
	RL_Rs.Close
	
	Set RL_Rs = nothing
	GetTopTen = RL_WORD
End Function

' 升级奖励用户
Function AdwardOnlineUp(UpClass)
Dim TempPoint,Message
RL_ActiveSetting(13) = split(RL_ActiveSetting(13),"*")
if Ubound(RL_ActiveSetting(13))<7 then
	Exit Function
end if
RL_ActiveSetting(14) = split(RL_ActiveSetting(14),"*")
if Ubound(RL_ActiveSetting(14))<7 then
	Exit Function
end if
Message = ""
TempPoint = cint(RL_ActiveSetting(13)(2)) + cint(RL_ActiveSetting(14)(2))*UpClass
if TempPoint > 0 then Message=Message & "奖励金钱" & TempPoint
RL_Sql = "Update Dv_User set userWealth=userWealth+" & TempPoint
TempPoint = cint(RL_ActiveSetting(13)(0)) + cint(RL_ActiveSetting(14)(0))*UpClass
if TempPoint > 0 then
	Message=Message & ",奖励文章" & TempPoint
	RL_Sql = RL_Sql & ", UserPost=UserPost+"&TempPoint
end if
TempPoint = cint(RL_ActiveSetting(13)(1)) + cint(RL_ActiveSetting(14)(1))*UpClass
if TempPoint > 0 then
	Message=Message & ",奖励主题" & TempPoint
	RL_Sql = RL_Sql & ", UserTopic=UserTopic+"&TempPoint
end if
TempPoint = cint(RL_ActiveSetting(13)(3)) + cint(RL_ActiveSetting(14)(3))*UpClass
if TempPoint > 0 then
	Message=Message & ",奖励积分" & TempPoint
	RL_Sql = RL_Sql & ", userEP=userEP+"&TempPoint
end if
TempPoint = cint(RL_ActiveSetting(13)(4)) + cint(RL_ActiveSetting(14)(4))*UpClass
if TempPoint > 0 then
	Message=Message & ",奖励魅力" & TempPoint
	RL_Sql = RL_Sql & ", userCP=userCP+"&TempPoint
end if
TempPoint = cint(RL_ActiveSetting(13)(5)) + cint(RL_ActiveSetting(14)(5))*UpClass
if TempPoint > 0 then
	Message=Message & ",奖励威望" & TempPoint
	RL_Sql = RL_Sql & ", UserPower=UserPower+"&TempPoint
end if

' 判断是否是DVSP3以上
if RL_ActiveVer >=703 then
	TempPoint = cint(RL_ActiveSetting(13)(6)) + cint(RL_ActiveSetting(14)(6))*UpClass
	if TempPoint > 0 then
		Message=Message & ",奖励金币" & TempPoint
		RL_Sql = RL_Sql & ", UserMoney=UserMoney+"&TempPoint
	end if
	TempPoint = cint(RL_ActiveSetting(13)(7)) + cint(RL_ActiveSetting(14)(7))*UpClass
	if TempPoint > 0 then
		Message=Message & ",奖励点券" & TempPoint
		RL_Sql = RL_Sql & ", UserTicket=UserTicket+"&TempPoint
	end if
end if
RL_Sql = RL_Sql & " where UserID=" & Dvbbs.UserID
Dvbbs.Execute(RL_Sql)
AdwardOnlineUp = Message
End Function

' 短信通知
Sub SMSOnlineUp(TempClass,Sms)
	Dim msgcontent
	msgContent=RL_ActiveSetting(12)
	if Sms<>"" then msgContent = msgContent & Chr(10) & Sms
	Dvbbs.Execute("Insert Into Dv_Message(incept,sender,title,content,sendtime,flag,issend) values('"&Dvbbs.CheckStr(Dvbbs.MemberName)&"','"&Dvbbs.MemberName&"','系统消息','"&Dvbbs.CheckStr(msgContent)&"',"&SqlNowString&",0,1)")
	Update_User_Msg(Dvbbs.MemberName)
End Sub

Public Function Update_User_Msg(username)
	Dim msginfo
	If newincept(username)>0 Then
		msginfo=newincept(username) & "||" & inceptid(1,username) & "||" & inceptid(2,username)
	Else
		msginfo="0||0||null"
	End If
	Dvbbs.Execute("Update [Dv_User] Set UserMsg='"&dvbbs.CheckStr(msginfo)&"' Where username='"&dvbbs.CheckStr(username)&"'")
End Function
'统计留言
Public Function newincept(iusername)
	Dim rs
	Rs=Dvbbs.Execute("Select Count(id) From Dv_Message Where flag=0 and issend=1 and delR=0 And incept='"& iusername &"'")
	newincept=Rs(0)
	Set Rs=Nothing
	If IsNull(newincept) Then newincept=0
End Function
Public Function inceptid(stype,iusername)
	Dim ars
	set ars=Dvbbs.Execute("Select top 1 id,sender From Dv_Message Where flag=0 and issend=1 and delR=0 And incept ='"& iusername &"'")
	if stype=1 then
		inceptid=ars(0)
	else
		inceptid=ars(1)
	end if
	set ars=nothing
End Function
%>