clsmain.asp

一个asp写的论坛源代码,论坛所需要的功能都有

					End If
					tmp = Replace(tmp,"{$chcheid}",iif(Tmpid<>"","<br>[ <B>子论坛</B>:"&Tmpid&" ]",""))
				End if
			Next
		End If
		ForumList_tips = tmp
	End Function
	'用户在线部分
	Public Sub OnlinActions(s)
		Dim UserSessionID,SQl,Rs,Eremite,Onlineuser,UserActions,SQL1,Fid,Act,Bbsname,U
		U = 0
		UserSessionID = Ccur(Session.SessionID) : UserActions = Split(s,",")
		Eremite = Cid(Request.Cookies("online")("Eremite")) : ActUrl = Replace(ActUrl,"&","")
		If Not IsDate(Request.Cookies("Class")("UpUserInfos")) Then
			Response.Cookies("Class")("UpUserInfos") = Now
		End If	
		If Not UserLoginED Then
			'游客部分
			If IsWebSearch Then 
				Exit Sub
			Else
				Set Rs = Execute("Select Acturl,Forumid From ["&Isforum&"Online] Where Sessionid = " &UserSessionID )
				If Rs.Eof And Rs.Bof Then
					Execute("Insert Into ["&Isforum&"Online](Forumid,Sessionid,UserName,Ip,Eremite,Bbsname,Act,Acturl,Cometime,Lasttime,Levelname) Values (" & CID(UserActions(0)) & "," &UserSessionID& ",'游客','"& RemoteAddr &"',-1,'"& HtmlEncode(UserActions(2)) &"','"& HtmlEncode(UserActions(1)) &"','" & ActUrl &"',"&SqlNowString & "," & SqlNowString & ",'游客')" )
					'更新在线人数
					UpdateOnline(CID(UserActions(0)))
					'将在线列表数据进行更新
					Cache.DelCache("ShowLines"&UserActions(0))
				Else
					If DateDiff("s",CDate(CDate(Request.Cookies("Class")("UpUserInfos"))),IsWeTimes) > 60 Or Not (Trim(RS(0)) = Trim(ActUrl)) Then
						Execute("Update ["&Isforum&"Online] Set Lasttime = " & SqlNowString & ",Forumid=" & CID(UserActions(0)) & ",Ip='" & RemoteAddr & "',BbsName='"& HtmlEncode(UserActions(2)) &"',Act='"& HtmlEncode(UserActions(1)) &"',Acturl='"& team.CheckStr(Acturl) &"' Where Sessionid = " & UserSessionID )
						UpdateOnline(CID(UserActions(0)))
						Response.Cookies("Class")("UpUserInfos") = Now
					End If
					'判断用户活动到另外板块才更新在新列表记录
					If Not CID(Rs(1)) = CID(UserActions(0)) Then
						Cache.DelCache("ShowLines"&UserActions(0))
					End If
				End If
				Rs.Close:Set Rs = Nothing
			End if
		Else
			'注册用户部分
			SQL1 = "Select Acturl,Eremite From ["&Isforum&"Online] Where Sessionid ="& TK_UserID
			Set Rs = Execute(SQL1)
			If Rs.Eof and Rs.Bof Then
				Execute("Insert Into ["&Isforum&"Online](Forumid,Sessionid,Username,Ip,Eremite,Bbsname,Act,Acturl,Cometime,Lasttime,Levelname) Values ('" & CID(UserActions(0)) & "','" & TK_UserID & "','"& TK_UserName&"','"& RemoteAddr &"',"& Eremite &",'"& HtmlEncode(UserActions(2)) &"','"& HtmlEncode(UserActions(1)) &"','" & ActUrl &"',"&SqlNowString & "," & SqlNowString & ",'"&Members&"')" )
				Execute("Delete From ["&Isforum&"Online] Where Sessionid = " & UserSessionID)
				'更新在线人数
				UpdateOnline(CID(UserActions(0)))
				'将在线列表数据进行更新
				Cache.DelCache("ShowLines"&UserActions(0))
				Cache.DelCache("UserOnlineCache")
			Else
				If DateDiff("s",CDate(Request.Cookies("Class")("UpUserInfos")),IsWeTimes) > 60 Or Not (Trim(RS(0)) = Trim(ActUrl)) or Not (Eremite = Cid(RS(1)) ) Then
					Execute("Update ["&Isforum&"Online] Set Lasttime = " & SqlNowString & ",Forumid = '" &CID(UserActions(0))& "',Ip = '" & RemoteAddr & "',BbsName='"& HtmlEncode(UserActions(2)) &"',Act='"& HtmlEncode(UserActions(1)) &"',Acturl='"& Acturl &"',UserName='"& TK_UserName &"',Eremite="&Eremite&",Levelname='"&Members&"' Where Sessionid = " & TK_UserID )
					Response.Cookies("Class")("UpUserInfos") = Now
					UpdateOnline(CID(UserActions(0)))
				End If			
				'判断用户活动到另外板块才更新在新列表记录
				If Not CID(Rs(1)) = CID(UserActions(0)) Then
					Cache.DelCache("ShowLines"&UserActions(0))
				End If
			End If
			Rs.Close:Set Rs = Nothing
		End If
		'删减人数并进行重新统计
		DelOnline(CID(UserActions(0)))	
		UserOnlineinfos()
	End Sub

	Public Sub DelOnline(a)
		Cache.Reloadtime= 60
		'判断在线总人数进行更新。
		Cache.Name="ForumOnline"
		If Cache.ObjIsEmpty() Then UpdateOnline(a)
		Onlinemany = Cache.Value
		If Int(Onlinemany) > Cache.Value Then
			Cache.Value = Onlinemany
		End if
		'判断在线注册用户人数进行更新。
		Cache.Name="ForumUserOnline"
		If Cache.ObjIsEmpty() Then UpdateOnline(a)
		Regonline = Cache.Value
		'修正统计值
		If CID(Regonline) > CID(Onlinemany) Then UpdateOnline(a)
		'设置游客数。
		GuestOnline = CID(Onlinemany) - CID(Regonline)
		'========================================================
		'设置删除不活动用户的时间
		Cache.Name = "GetNewsOnlinetime"
		If Cache.ObjIsEmpty() Then 
			Cache.Value = Now()
		End if
		If DateDiff("s",Cache.Value,Now())> Clng(Forum_setting(45)*10) then
			Rem 设置每N×10秒进行判断，删除超时用户
			If IsSqlDataBase=1 Then
				Execute("Delete From ["&Isforum&"Online] Where Datediff(Mi, Lasttime, " & SqlNowString & ") > " & Clng(Forum_setting(45)))
			Else
				Execute("Delete From ["&Isforum&"Online] Where Datediff('s',Lasttime, " & SqlNowString & " ) > "& Forum_setting(45) &" * 60 ")
			End If
			Cache.Value=Now()
			UpdateOnline(a)
			Cache.DelCache("UserOnlineCache")
		End If
		Rem 更新在线峰值
		If Int(Split(Club_Class(20),"|")(0))<Int(Onlinemany) Then
			Execute("update ["&Isforum&"ClubConfig] set ForumBest='"&Onlinemany&"|"& Now() &"' ")
			Club_Class(20) = Onlinemany &"|" & Now
			Cache.DelCache("Club_Class")
		End If
	End Sub

	Public Sub UpdateOnline(a)
		Dim Rs	
		Cache.Reloadtime = 60
		'总人数
		Cache.Name="ForumOnline"
		Set Rs=Execute("Select Count(*) From ["&Isforum&"Online]")
		Cache.Value = CID(Rs(0))
		Onlinemany = Cache.Value
		'总注册人数
		Cache.Name="ForumUserOnline"
		Set Rs=Execute("Select Count(*) From ["&Isforum&"Online] Where Eremite>-1")
		Cache.Value = CID(Rs(0))
		Regonline = Cache.Value
		If Int(a) > 0 Then
			Set Rs=Execute("Select Count(*) From ["&Isforum&"Online] Where forumid="&a)
			Cache.Name = "Forumidonline"& a
			Cache.Value = CID(Rs(0))
			Set Rs=Execute("Select Count(*) From ["&Isforum&"Online] Where Eremite>-1 and forumid="&a)
			Cache.Name = "Regforumidonline"& a
			Cache.Value = CID(Rs(0))
		End If
		Set Rs=Nothing
	End Sub

	'公告
  	Public Function Affiche()
    	Dim tmp,RS
    	Cache.Name="BBsAffiche"
    	Cache.Reloadtime = Cid(Forum_setting(44))
		If Cache.ObjIsEmpty() Then
	   		Set Rs=Execute("Select ID,Affichetitle,Affichecontent,Afficheman,Affichetime,Afficheinfo From ["&Isforum&"affiche] Order By AfficheTime Desc")
	   		If RS.Eof And Rs.Bof Then
				tmp = "暂无公告"
			Else
				tmp = Rs.GetRows(-1)
	   		End If
			Cache.Value = tmp
			RS.Close:Set RS=Nothing
		End If
   		Affiche = Cache.Value
  	End Function

	'友情链接
  	Public Function Forum_Link()
		Dim Rs,Value,i,tmp,tmp1,tmp2,tmp3
    	Cache.Name="Superlink"
    	Cache.Reloadtime = Cid(Forum_setting(44))
		If Cache.ObjIsEmpty() Then
	   		Set Rs=Execute("Select Name,Url,Logo,Intro,SetTops From ["&Isforum&"link] Order By SetTops Asc")
	   		If RS.Eof Then
				Exit Function
			Else
	      		Cache.Value = Rs.GetRows(-1)
	   		End If
			RS.Close:Set RS=Nothing
		End If
		Value = Cache.Value
		if isarray(value) Then
			tmp1 = "":tmp2 = ""
			for i = 0 to Ubound(Value,2)
				If Value(3,i)&"" = "" Then
					If Value(2,i) &"" = "" Then
						If tmp1 = "" Then
							tmp1 = "[<a href="""& Value(1,i) &""" target=""_blank"" title="""& Value(0,i) &""">"& Value(0,i) &"</a>]" 
						Else
							tmp1 = tmp1 & " [<a href="""& Value(1,i) &""" target=""_blank"" title="""& Value(0,i) &""">"& Value(0,i) &"</a>]" 
						End if
					Else
						If tmp2 = "" Then
							tmp2 = "<a href="""& Value(1,i) &""" target=""_blank"" title="""& Value(0,i) &"""><img src="& Value(2,i) &" border=""0"" Align=""absmiddle""></a>"
						Else
							tmp2 = tmp2 & " <a href="""& Value(1,i) &""" target=""_blank"" title="""& Value(0,i) &"""><img src="& Value(2,i) &" border=""0"" Align=""absmiddle""></a>"
						End if
					End if
				Else
					tmp3 =  tmp3& "	<tr class=""a4"">"
					tmp3 =  tmp3& "	<td width=""5%"" align=""center"" valign=""middle""><img src="""&Styleurl&"/link.gif"" alt="""" /></td>"
					tmp3 =  tmp3& "	<td width=""77%"" valign=""middle""> <a href="""& Value(1,i) &""" target=""_blank"" title="""& Value(0,i) &""" class=""bold""> "& Value(0,i) &" </a> <br> "& Value(3,i) &" </td>"
					tmp3 =  tmp3& "	<td width=""18%"" align=""center"" valign=""middle""> <img src="& Value(2,i) &" border=""0"" alt="""& Value(3,i) &""" /> </td>"
					tmp3 =  tmp3& "	</tr> "
				End if
			Next
			tmp = tmp2 & "<br>" & tmp1
			Linkshows = tmp3
		End if
   		Forum_Link = tmp 
  	End Function

	'载入定制的在线人员列表
  	Public Function LoadOnlineShows()
    	Dim Tmp,RS
    	Cache.Name="OnlineShowsCache"
    	Cache.Reloadtime = Cid(Forum_setting(44))
		If Cache.ObjIsEmpty() Then
	   		Set Rs = execute("Select OnlineName,Onlineimg From ["&isforum&"OnlineTypes] Order By Sorts Asc")
	   		If RS.Eof Then
				Exit Function
			Else
	      		Cache.Value = Rs.GetRows(-1)
	   		End If
			RS.Close:Set RS=Nothing
		End If
   		LoadOnlineShows = Cache.Value
  	End Function

	'首页显示定制在线列表人员分类
  	Public Function OnlineShows()
    	Dim Tmp,i,tmp1
		Tmp = LoadOnlineShows : tmp1 = ""
		If Isarray(tmp) Then
			for i=0 to Ubound(tmp,2)
				If tmp1 = "" Then
					tmp1 = "<img src="""& StyleUrl & "/"&tmp(1,i)&""" alt="""&tmp(0,i)&""" /> "&tmp(0,i)&""
				Else
					tmp1 = tmp1& " &nbsp; &nbsp;<img src="""& StyleUrl & "/"&tmp(1,i)&""" alt="""&tmp(0,i)&""" /> "&tmp(0,i)&""
				End if
			Next
		End if
   		OnlineShows = tmp1
  	End Function

	Public Function ShowLines(a)
		Dim tmp,Rs,linetmp,u,p,i,OnlineTmp,SQL
		Cache.Name = "ShowLines"& a
		Cache.Reloadtime = Cid(Forum_setting(44))
		if Request("showlines")="no" Then Exit Function
		If team.Forum_setting(39)=0 And Request("showlines")<>"yes" Then Exit Function
		If Cache.ObjIsEmpty() Then
			If a = 0 Then
				SQL = "Select UserName,LevelName,IP,Bbsname,Acturl,Lasttime,Eremite From ["&Isforum&"Online] "
			Else
				SQL = "Select UserName,LevelName,IP,Bbsname,Acturl,Lasttime,Eremite From ["&Isforum&"Online] Where forumid = "& a
			End if
			Set Rs = Execute(SQL)
	   		If RS.Eof Then
				Exit Function
			Else
	      		Cache.Value = Rs.GetRows(-1)
	   		End If
			Rs.Close:Set Rs=Nothing
		End If
		tmp = Cache.Value
		Linetmp = LoadOnlineShows
		If IsArray(tmp) Then
			OnlineTmp = "<tr>" : p = 0
			For u = 0 to Ubound(tmp,2)
				p = p+1
				If Isarray(linetmp) Then
					for i=0 to ubound(linetmp,2)
						If Trim(linetmp(0,i)) = tmp(1,u) Then
							OnlineTmp = OnlineTmp & "<td nowrap align=""left""><img src="""& styleurl &"/"&Linetmp(1,i)&"""  alt="""&Linetmp(0,i)&""" />"
							If CID(tmp(6,u)) = 2 Then 
								OnlineTmp = OnlineTmp & "<span alt=""隐身用户"">隐身用户</span>"
							Else
								OnlineTmp = OnlineTmp & "<a href=""Profile.asp?username="&tmp(0,u)&""" title=""等级:"&tmp(1,u)&"&#xA;位置:"&tmp(3,u)&"&#xA;活动:"&formatdatetime(tmp(5,u),4)&"&#xA;"&Iif(SeeUIP,tmp(2,u),"....")&" ""> "&tmp(0,u)&" </a> </td>"
							End If	
						End if
					Next
				End if
				If p = 8 Then OnlineTmp = OnlineTmp & "</tr><tr> " : p = 0
			Next
		End If
		Showlines = OnlineTmp
	End Function

	Public Function UserOnlineinfos()	'判断用户状态
		Dim SQL,RS,tmp
		Cache.Name = "UserOnlineCache"
		Cache.Reloadtime = 10
		If Cache.ObjIsEmpty() Then
			Set Rs = Execute("Select UserName From ["&Isforum&"Online] Where Eremite = 0")
			If RS.Eof Then
				Exit Function
	   		Else
		   		Do While Not RS.Eof
		      		tmp = tmp & "$$"&Rs(0)&"$$"
	   				Rs.MoveNext
				Loop
				Cache.Value = tmp
			End if
			RS.Close:Set RS=Nothing
		End If
		UserOnlineinfos = Cache.Value
	End Function

	'导航菜单
  	Public function MenuTitle()
		Dim Tmp
		Tmp = Replace(ElseHtml(4),"{$clubname}",Club_Class(1))
		Tmp = Replace(Tmp,"{$topic}",x1)
		Tmp = Replace(Tmp,"{$bbsname}",x2)
		Tmp = Replace(Tmp,"{$forumid}",Fid)
		MenuTitle = tmp
	End function

	'短讯通知
	Public function TeamNewMsg()
		Dim u,RS,MessTmp,tmp
		MessTmp = ""
		If Newmessage>0 then
			MessTmp = Replace(ElseHtml(5),"{$newmessage}",Newmessage)
			MessTmp = Replace(MessTmp,"{$msgwav}",IIf(Request.Cookies(Forum_Sn)("msgsound")="","<bgsound src=""images/plus/pm1.wav"">","<bgsound src=""images/plus/pm"&Request.Cookies(Forum_Sn)("msgsound")&".wav"">"))
			Set RS=Execute("Select top "&CID(Newmessage)&" msgtopic,Author,SendTime,ID From ["&Isforum&"message] Where Incept='"&TK_UserName&"' Order By ID Desc")
			Do While Not Rs.Eof
				tmp = tmp & "<li><a href=""Msg.asp?action=readmsg&sid="&Rs(3)&""" style=""cursor:hand"" target=""_blank"">短信内容: "&HtmlEncode(RS(0))&" - [来自: "&RS(1)&" / "&RS(2)&" ] </li>"
				Rs.Movenext
			Loop
			Rs.Close:Set Rs=Nothing
			MessTmp = Replace(MessTmp,"{$msgcontent}",IIF(tmp="","<a href=""Msg.asp"">您的消息因为长期未读，已被系统删除，请进入短信管理页面将未读短信提示数量清零。</a>",tmp))
		End if
		TeamNewMsg = MessTmp
	End function

	'无条件转向
	Public Sub Error(Message)
		Response.Redirect "Error.asp?Message="&SerVer.URLencode(Message)&""
	End Sub
	'带条件转向
	Public Sub Error1(Message)
		Response.Redirect "Error.asp?Message1="&SerVer.URLencode(Message)&""
	End Sub
	'弹出提示
	Public Sub Error2(Message)
		Response.Redirect "Error.asp?Message2="&SerVer.URLencode(Message)&""
	End Sub
	'=========================================================================

	'检查验证码是否正确
	Public Function CodeIsTrue(a)
		Dim CodeStr
		CodeStr=Trim(a)
		If CStr(Session("GetCode"))=CStr(CodeStr) And CodeStr<>""  Then
			CodeIsTrue=True
			Session("GetCode")=empty
		Else
			CodeIsTrue=False