clsmain.asp

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

<%
Class Cls_Forum
	Public Forum_setting,Club_Class,UserLoginED,User_SysTem,Wid,TK_UserID,Linkshows
	Public UserGroupID,Newmessage,Posttopic,Postrevert,Deltopic,Goodtopic,Regtime,Landtime,Postblog,UserMebe,LoginNum,Levelname,UserName,UserPass,UserUp,Cookies_Path
	Public Members,GroupName,Memberrank,GroupRank,IsBrowse,IsManage,UserColor,UserImg,Rank
	Public Group_Browse,Group_Manage,UserGroup,ActUrl,SkinKey,HtmlTemp,Onlinemany,Regonline,GuestOnline,HtmlNews
	Public Today,Bannertext,Styleurl,SkinID,Allword,IsWeTimes
	Public IndexHtml,PostHtml,UserHtml,ElseHtml,Admin_Master
	Public IsMaster,SuperMaster,BoardMaster,IsVips,UserGroupExs
	Private SeeUIP,CloseForum

	Private Sub Class_Initialize()
		If Not Response.IsClientConnected Then Response.End
		UserLoginED = False : SkinID = 1 : SeeUIP = False
		IsMaster = false:SuperMaster= False:BoardMaster = False :IsVips = False 
		UserGroupID = 28 
		TK_UserID = CID(Request.Cookies(Forum_sn)("UserID"))
		ActUrl = Request.ServerVariables("script_name") &"?" &Request.ServerVariables("Query_String")
		IsWeTimes=FormatDateTime(Now(),0)'格式化时间
		Cache.Name = "NewCountDate"
		Cache.Reloadtime = 14400
		If Cache.ObjIsEmpty() Then
			Cache.Value = Now
		End If
		If DateDiff("d",CDate(Cache.Value),Now())<>0 Then
			UpNewsDate()
			Cache.Value = Now
		End If
	End Sub

	'论坛基本参数Allclass=0,Clubname=1,Cluburl=2,Homename=3,Homeurl=4,Badwords=5,Badip=6,Badlist=7,ManageText=8,CacheName=9,UpFileGenre=10,ReForumName=11,Newreguser=12,agreement=13,Nowdate=14,Today=15,oldday=16,PostNum=17,RepostNum=18,UserNum=19,ForumBest=20,ExtCredits=21,MustOpen=22,ClearMail=23,ClearIP=24,UserKey=25,BodyMeta=26,ClearPost=27,JsUrl=28,29=Starday
 	Public Sub GetForum_Setting()
		Dim Rs,SQL,Temp
     	Cache.Name = "Club_Class"
     	Cache.Reloadtime = 14400
	 	If Not Cache.ObjIsEmpty() Then
	    	Club_Class = Split(Cache.Value,"#@#")
	 	Else
			Set Rs = Execute("Select Allclass,Clubname,Cluburl,Homename,Homeurl,Badwords,Badip,Badlist,ManageText,CacheName,UpFileGenre,ReForumName,Newreguser,agreement,Nowdate,Today,oldday,PostNum,RepostNum,UserNum,ForumBest,ExtCredits,MustOpen,ClearMail,ClearIP,UserKey,BodyMeta,ClearPost,JsUrl,Starday from ["&Isforum&"Clubconfig]")
			Temp = Rs.GetString(,1, "#@#","","")
			Rs.Close:Set Rs=Nothing
			Cache.Value = Temp
			Club_Class = Split(Temp,"#@#")
			Application.Lock
			LockCache "TodayNum" , Club_Class(15)
			LockCache "OldTodayNum" , Club_Class(16)
			LockCache "PostNum" , Club_Class(17)
			LockCache "RepostNum" , Club_Class(18)
			LockCache "UserNum" , Club_Class(19)
	 	End If
		Forum_setting = Split(Club_Class(0),"$$$")
		Server.ScriptTimeout = Forum_setting(91)
		Cookies_Path = Club_Class(9)
		If Application(CacheName&"_TodayNum")="" or Application(CacheName&"_OldTodayNum")="" or Application(CacheName&"_PostNum")="" or Application(CacheName&"_RepostNum")="" or Application(CacheName&"_UserNum")="" Then Cache.DelCache("Club_Class")
		LockCache "ConverPostNum" , CID(Application(CacheName&"_PostNum")) + Application(CacheName&"_RepostNum")
	End Sub

	Public Sub LockCache(SetName,NewValue)
		Application.Lock	'锁定
		Application(CacheName &"_"&SetName) = NewValue		'赋值
		Application.unLock	'解除锁定
	End Sub 

	Private Sub UpNewsDate
		'更新系统单日统计
		Dim t
		t = CID(Execute("Select SUM(today)From ["&Isforum&"Bbsconfig]")(0))
		Execute("Update ["&Isforum&"Clubconfig] Set Oldday="& t &",Nowdate="&SqlNowString&",Today=0")
		Execute("Update ["&Isforum&"bbsconfig] set today=0")
		Cache.DelCache("Club_Class")
		UpUserMonPosts
	End Sub

	Private Sub UpUserMonPosts
		'工资管理
		Dim Rs,URs
		If Day(Now) = "1" Then
			Set Rs = team.execute("Select WageMach,WageGroupID From ["&Isforum&"Wages]")
			Do While Not Rs.Eof 
				team.execute("Update ["&IsForum&"User] Set Extcredits"&Forum_setting(99)&"=Extcredits"&Forum_setting(99)&"+"&RS(0)&" Where UserGroupID = "& Int(Rs(1)) )
				If URs = "" Then
					URs = Rs(1)
				Else
					URs = URs & "," & Rs(1)
				End if
				Rs.MoveNext
			Loop
			Rs.Close:Set Rs=Nothing
			Set Rs = team.execute("Select UserName From ["&IsForum&"User] Where UserGroupID in ("&URs&") ")
			Do While Not Rs.Eof 
				team.Execute("insert into ["&Isforum&"Message] (author,incept,content,Sendtime,MsgTopic) values ('系统消息','"&Rs(0)&"','您本月的工资已经发放，请注意查收',"&SqlNowString&",'工资发放消息')")
				team.execute("Update ["&Isforum&"User] set Newmessage=Newmessage+1 where UserName='"&Rs(0)&"'")
				Rs.MoveNext
			Loop
			Rs.Close:Set Rs=Nothing
		End If
	End Sub

	'验证用户登陆
	Public Sub CheckUserLogin()
		Dim RS,Rmp
		If TK_UserID > 0 Then
			If Session(CacheName&"_UserLogin")&"" = "" Then
				Set RS = Execute("Select UserName,UserPass,UserGroupID,Levelname,Newmessage,Posttopic,Postrevert,Deltopic,Goodtopic,Regtime,Landtime,Postblog,UserUp,LoginNum,Extcredits0,Extcredits1,Extcredits2,Extcredits3,Extcredits4,Extcredits5,Extcredits6,Extcredits7,Members,Friend From ["&Isforum&"User] where ID="& TK_UserID)
				If Rs.Eof And Rs.Bof Then
					CheckGuestLogin : Exit Sub
				Else
					If Not (LCase(RS(0))=LCase(TK_UserName) and RS(1)=TK_UserPass ) Then
						CheckGuestLogin : Exit Sub
					ElseIf Not trim(RS(13))=Trim(Request.Cookies(Forum_sn)("LoginNum")) Then 
						CheckGuestLogin : Exit Sub
					Else
						Rmp = Rs.GetString(,1, "#@#","","")
						Session(CacheName&"_UserLogin") = Rmp
					End If
				End If
				RS.Close:Set Rs=Nothing
			End If
			User_SysTem = Split(Session(CacheName&"_UserLogin"),"#@#")
			'判断Session和Cookies用户名
			If User_SysTem(0)<>TK_UserName Then	
				CheckGuestLogin : Exit Sub
			End If
			UserGroupID = User_SysTem(2)
			UserUp = User_SysTem (12)
			UserGroupExs = User_SysTem (14)
			If InStr(User_SysTem(3),"||") > 0 Then
				Levelname = Split(User_SysTem(3),"||")
			Else
				Levelname = Split("附小一年级||||||0||0","||")
			End if
			Newmessage = User_SysTem(4)
			Members = User_SysTem(22)
			Select Case UserGroupID
				Case 1
					IsMaster = True
				Case 2
					SuperMaster = True
				Case 3
					BoardMaster = True
				Case 4 
					IsVips = True
				Case 5
					team.error " 您的帐号尚未激活。<meta http-equiv=refresh content=3;url=""GetUserInfo.asp"">"
				Case 7
					Response.Redirect "Close.asp"
			End Select
			UserLoginED = True
		Else
			CheckGuestLogin
			UserGroupID = 28
		End If
		GetGroupSetting()
	End Sub

	Public Function ManageUser()
		ManageUser = False
		If IsMaster Then 
			ManageUser = True
			Exit Function
		End if
		If SuperMaster Then 
			ManageUser = True
			Exit Function
		End If
		If BoardMaster Then 
			ManageUser = True
			Exit Function
		End If
		If IsVips Then 
			If  Admin_Master =1 or Admin_Master =2 Or Admin_Master = 3 Then
				ManageUser = True
				Exit Function
			End If
		End If
	End Function
	
	Public Sub CheckGuestLogin	
		UserLoginED = False
		TK_UserID = 0
		Session(CacheName&"_UserLogin") = ""
		EmptyCookies
		TK_UserName = "游客"& Session.SessionID
	End Sub

	Public Sub EmptyCookies()
		'判断Cookies更新目录
		Dim cookies_path_s,cookies_path_d,cookies_path,i
		cookies_path_s=split(Request.ServerVariables("PATH_INFO"),"/")
		cookies_path_d=ubound(cookies_path_s)
		cookies_path="/"
		For i=1 to cookies_path_d-1
			cookies_path=cookies_path&cookies_path_s(i)&"/"
		Next
		Response.Cookies(Forum_sn)("username") = ""
		Response.Cookies(Forum_sn)("userpass") = ""
		Response.Cookies(Forum_sn)("LoginNum") = ""
		Response.Cookies(Forum_sn)("UserID") = 0
		Response.Cookies(Forum_sn).path=cookies_path
	End Sub

	Public Function Createpass()'系统分配随机密码
		Dim Ran,i,LengthNum
		LengthNum=16
		Createpass=""
		For i=1 To LengthNum
			Randomize
			Ran = CInt(Rnd * 2)
			Randomize
			If Ran = 0 Then
				Ran = CInt(Rnd * 25) + 97
				Createpass =Createpass& UCase(Chr(Ran))
			ElseIf Ran = 1 Then
				Ran = CInt(Rnd * 9)
				Createpass = Createpass & Ran
			ElseIf Ran = 2 Then
				Ran = CInt(Rnd * 25) + 97
				Createpass =Createpass& Chr(Ran)
			End If
		Next
		Createpass= Createpass
	End Function

	Private Sub GetGroupSetting()
		Dim tmp,Rs,SQL
		Cache.Reloadtime = Cid(Forum_setting(44))
		Cache.Name="GroupSetting_"& UserGroupID
		If Cache.ObjIsEmpty() Then 
			SQL = "Select IsBrowse,IsManage,GroupRank,UserImg,UserColor,GroupName,rank From ["&isforum&"UserGroup] where ID = " & UserGroupID
			Set Rs = Execute(SQL)
			If Rs.Eof Then
				Set Rs=Nothing
				SQL = "Select IsBrowse,IsManage,GroupRank,UserImg,UserColor,GroupName,rank From ["&isforum&"UserGroup] where ID = 28"
				Set Rs = Execute(SQL)
				Cache.value = Rs.GetString(,1, "$$##$$","","")
			Else
				Cache.value = Rs.GetString(,1, "$$##$$","","")
			End If
			Rs.close:Set Rs=nothing
		End If
		tmp = Split(Cache.Value,"$$##$$")
		Group_Browse = Split(tmp(0),"|") : Group_Manage = Split(tmp(1),"|") : Admin_Master = tmp(2) 
		'组名称||颜色||图片||星星||签名UBB
		If UserLoginED Then
			If Not (Trim(tmp(5))=Levelname(0)) Or Not (Trim(tmp(4))=Levelname(1)) Or Not (Trim(tmp(3))=Levelname(2)) Or Not (Trim(tmp(6))=Levelname(3)) Or Not (Int(Group_Browse(21)) = Int(Levelname(4))) Then
				Execute("Update ["&Isforum&"user] set Levelname='"&tmp(5)&"||"&tmp(4)&"||"&tmp(3)&"||"&tmp(6)&"||"&Group_Browse(21)&"',Landtime="&SqlNowString&" Where ID="& TK_UserID)
				Session(CacheName&"_UserLogin")=""
			End If
		End If
		If Group_Browse(0) = 0 Then	
			Response.Redirect "Close.asp?action=upower"
		End if
		Call UpUserClass()
	End Sub 

	Private Sub UpUserClass
		If UserLoginED Then
			If Group_Manage(5) = 1 Then
				SeeUIP = True
			End If
			If Not Isdate(User_SysTem(10)) Then User_SysTem(10) = Now()
			If DateDiff("d",User_SysTem(10),Date())<>0 Then
				Execute("Update ["&Isforum&"user] set UserUp='0|"&Now()&"',Landtime="&SqlNowString&" Where ID="& TK_UserID)
				Session(CacheName&"_UserLogin")=""
			End If
			'更新用户在线时间
			If Not IsDate(Request.Cookies("Class")("UserLogintime")) Then
				Response.Cookies("Class")("UserLogintime") = Now
			End if
			If DateDiff("s",CDate(Request.Cookies("Class")("UserLogintime")),IsWeTimes) > 600 Then
				Execute("update ["&Isforum&"user] set Degree=Degree+10,LastLoginIP='"&RemoteAddr&"' Where ID="& TK_UserID)
				Response.Cookies("Class")("UserLogintime") = Now
			End If
		End if
	End Sub

 	Public Sub LoadTemplates(ID)
		Dim Rs,SQL,value
		ID = INT(ID)
		Cache.Name = "Templates"&ID
     	Cache.Reloadtime = Cid(Forum_setting(44))
		If Cache.ObjIsEmpty() Then
	    	Set Rs = Execute("Select StyleName,StyleWid,Styleurl,Style_index,Style_post,Style_user,Style_else,StyleCss From ["&Isforum&"Style] Where ID="& ID)
			If Rs.Eof and Rs.Bof Then
				Set Rs = Nothing
				Set Rs = Execute("Select StyleName,StyleWid,Styleurl,Style_index,Style_post,Style_user,Style_else,StyleCss From ["&Isforum&"Style] Where ID="& INT(team.Forum_setting(18)))
				If Rs.Eof And Rs.Bof Then
					Set Rs = Nothing
					Set Rs = Execute("Select StyleName,StyleWid,Styleurl,Style_index,Style_post,Style_user,Style_else,StyleCss From ["&Isforum&"Style] ")
					If Rs.Eof And Rs.Bof Then
						Response.Redirect "Club.asp?message=没有找到应有的模版，请导入新的模版文件。 "
					Else
						value = Rs.GetString(,1, "@|@","","")
					End if
				Else
					value = Rs.GetString(,1, "@|@","","")
				End If
			Else
				value = Rs.GetString(,1, "@|@","","")
			End If
			Cache.Value = value
			Rs.Close:Set Rs=Nothing
	 	End If
		HtmlTemp = Split(Cache.Value,"@|@")
		Styleurl=HtmlTemp(2)
		Wid=HtmlTemp(1)
		HtmlTemp(3)=Replace(Replace(HtmlTemp(3),"{$Csslist}",HtmlTemp(2)),"{$csswindth}",HtmlTemp(1))
		HtmlTemp(4)=Replace(Replace(HtmlTemp(4),"{$Csslist}",HtmlTemp(2)),"{$csswindth}",HtmlTemp(1))
		HtmlTemp(5)=Replace(Replace(HtmlTemp(5),"{$Csslist}",HtmlTemp(2)),"{$csswindth}",HtmlTemp(1))
		HtmlTemp(6)=Replace(Replace(HtmlTemp(6),"{$Csslist}",HtmlTemp(2)),"{$csswindth}",HtmlTemp(1))
		IndexHtml=Split(HtmlTemp(3),"@@@"):PostHtml=Split(HtmlTemp(4),"@@@")
		UserHtml=Split(HtmlTemp(5),"@@@"):ElseHtml=Split(HtmlTemp(6),"@@@")
		HtmlNews = Split(HtmlTemp(7),"@@@")
	End Sub

	Public Property Let ChooseName(ByVal strPkey)
		SkinKey = CID(strPkey)
	End Property

	Public Function AdvShows(a)
		Dim i,Advtmp,topAdvs
		Dim tmp,u,url,n
		Advtmp = ForumAdvs()
		If IsArray(Advtmp) Then
			topAdvs = ""
			For i = 0 To Ubound(Advtmp,2)
				If (Advtmp(2,i)="all" or Advtmp(2,i)="index") and CID(Advtmp(0,i)) = 1 and CID(Advtmp(1,i)) = a Then
					If Advtmp(3,i) <>"" Then 
						If DateDiff("d",CDate(Advtmp(3,i)),Date())<0 Then Advtmp(5,i) = ""	
					End if
					If Advtmp(4,i) <>"" Then 
						If DateDiff("d",CDate(Advtmp(4,i)),Date())>0 Then Advtmp(5,i) = ""
					End if
					If Advtmp(5,i)<>"" Then
						If topAdvs = "" Then
							topAdvs = Advtmp(5,i)
						Else
							topAdvs = topAdvs & "$$$" & Advtmp(5,i) 
						End if
					End if
				End if
			Next
			If Instr(topAdvs,"$$$")>0 Then
				u = Split(topAdvs,"$$$")
				AdvShows = u(Second(now) mod Ubound(u))
			Else
				AdvShows = topAdvs
			End if
		End if