dv_clsmain.asp

一个很好的论坛程序.论坛数据和程序使用最新更新29号动网7.1论坛程序美化优化设置：1.帖子中改变字体大小2.论坛信息变量3.双击下滚

<%
Dim Ad_3(100),i3
Class Cls_Forum
	Rem Const
	Public BoardID,SqlQueryNum,Forum_Info,Forum_Setting,Forum_user,Forum_Copyright,Forum_ads,Forum_ChanSetting
	Public Forum_sn,Forum_Version,Stats,StyleName,ErrCodes,NowUseBBS,Cookiepath
	Public lanstr,mainhtml,mainsetting,sysmenu,mainpic
	Public MyUserInfo,UserToday,BoardJumpList,BoardList,CacheData,Maxonline
	Public UserGroupID,Lastlogin,GroupSetting,FoundUserPer
	Public Vipuser,Boardmaster,Superboardmaster,Master,FoundIsChallenge,FoundUser
	Public ScriptName,MemberName,MemberWord,MemberClass,UserHidden,UserID,UserTrueIP
	Public sendmsgnum,sendmsgid,sendmsguser,Page_Admin,Forum_AdLoop3
	Public BadWords,rBadWord,Forum_emot,Forum_PostFace,Forum_UserFace,SkinID
	Private adcode_1,adcode_2,adcode_4,ScriptTrueUrl,Forum_CSS,Main_Sid,ReloadCount,Nowstats,CssID
	Public Reloadtime,CacheName
	Private LocalCacheName,Cache_Data,IsTopTable,CookiesSid
	Public Board_Setting,boarduser,LastPost,Board_Ads,Board_user,BoardType,IsGroupSetting,BoardMasterList,Board_Data,Sid,Boardreadme,BoardRootID,BoardParentID
	Rem Sub 
	Private Sub Class_Initialize()
		Dim UserAgent,path
		UserAgent = Trim(Lcase(Request.Servervariables("HTTP_USER_AGENT")))
		If InStr(UserAgent,"teleport") > 0 or InStr(UserAgent,"webzip") > 0 or InStr(UserAgent,"flashget")>0 or InStr(UserAgent,"offline")>0 Then
			Response.Write "请不要采用teleport/Webzip/Flashget/Offline等工具来浏览论坛！"
			Response.End
		End If
		SqlQueryNum = 0
		If Application(Forum_CacheName)<> Forum_CacheName Then 
			Application.Lock
			Application(Forum_CacheName) = Forum_CacheName
			Application(Forum_CacheName & "_sn") = LCase(Replace(Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("URL"),Split(request.ServerVariables("SCRIPT_NAME"),"/")(ubound(Split(request.ServerVariables("SCRIPT_NAME"),"/"))),""))
			Application.unLock
		End If 
		Forum_sn = Application(Forum_CacheName & "_sn"):Vipuser = False:Boardmaster = False
		Superboardmaster = False:Master = False:FoundIsChallenge = False:FoundUser = False
		BoardID = Request("BoardID")
		'If BoardID="" Then BoardId=Request.Form("BoradID")
		If IsNumeric(BoardID) = 0 or BoardID = "" Then BoardID = 0
		BoardID = Clng(BoardID)
		MemberName = checkStr(Trim(Request.Cookies(Forum_sn)("username")))
		MemberWord = checkStr(Trim(Request.Cookies(Forum_sn)("password")))
		UserHidden = Request.Cookies(Forum_sn)("userhidden")
		UserID = Trim(Request.Cookies(Forum_sn)("UserID"))
		If IsNumeric(UserHidden) = 0 or Userhidden = "" Then UserHidden = 2
		If IsNumeric(UserID) = 0 Or UserID="" Then UserID=0
		UserID = Clng(UserID)
		UserTrueIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
		If UserTrueIP = "" Then UserTrueIP = Request.ServerVariables("REMOTE_ADDR")
		UserTrueIP = CheckStr(UserTrueIP)
		Dim Tmpstr,i
		Tmpstr = Request.ServerVariables("PATH_INFO")
		Tmpstr = Split(Tmpstr,"/")
		i = UBound(Tmpstr)
		ScriptName = Lcase(Tmpstr(i))
		MemberClass = checkStr(Request.Cookies(Forum_sn)("userclass"))
		Page_Admin=False
		If InStr(ScriptName,"showerr")>0 Or InStr(ScriptName,"login")>0 Or InStr(ScriptName,"reg")>0 Or InStr(ScriptName,"admin_")>0 Then Page_Admin=True
		sendmsgnum=0:sendmsgid=0:sendmsguser=""
		Reloadtime=28800
		CacheName=Replace(Server.MapPath("index.asp"),"index.asp","")
		ReloadCount=0
		IsTopTable = 0		
	End Sub
	Private Sub class_terminate()
		If IsObject(Conn) Then 
			Conn.Close
			Set Conn = Nothing
		End If 
	End Sub
	Public Property Let Name(ByVal vNewValue)
		LocalCacheName=LCase(vNewValue)
	End Property
	Public Property Let Value(ByVal vNewValue)
		If LocalCacheName<>"" Then 
			ReDim Cache_Data(2)
			Cache_Data(0)=vNewValue
			Cache_Data(1)=Now()
			Application.Lock
			Application(CacheName & "_" & LocalCacheName) = Cache_Data
			Application.unLock
		Else
			Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName."
		End If
	End Property
	Public Property Get Value()
		If LocalCacheName<>"" Then 
			Cache_Data=Application(CacheName & "_" & LocalCacheName)	
			If IsArray(Cache_Data) Then
				Value=Cache_Data(0)
			Else
				Err.Raise vbObjectError + 1, "DvbbsCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."
			End If
		Else
			Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName."
		End If
	End Property
	Public Function ObjIsEmpty()
		ObjIsEmpty=True	
		Cache_Data=Application(CacheName & "_" & LocalCacheName)
		If Not IsArray(Cache_Data) Then Exit Function
		If Not IsDate(Cache_Data(1)) Then Exit Function
		If DateDiff("s",CDate(Cache_Data(1)),Now()) < (60*Reloadtime) Then ObjIsEmpty=False		
	End Function
	Public Sub DelCahe(MyCaheName)
		Application.Lock
		Application.Contents.Remove(CacheName&"_"&MyCaheName)
		Application.unLock
	End Sub
	'取得基本设置数据
	Public Sub GetForum_Setting()
		Name="setup"
		If ObjIsEmpty() Then ReloadSetup()
		CacheData=value
		'每日更新数据
		Name="Date"
		'DelCahe "Date"
		'第一次起用论坛或者重启IIS的时候加载缓存
		If ObjIsEmpty() Then
			ReloadAllForumInfo
			ReloadAllBoardInfo
			Name="setup"
			ReloadSetup()
			CacheData=value
			'value=Date()
		End If
		Name="Date"
		If Cstr(value) <> Cstr(Date()) Then
			ReloadAllForumInfo
			ReloadAllBoardInfo
			Name="setup"
			ReloadSetup()
			CacheData=value
		End If
		Dim Setting
		Setting=CacheData(1,0)
		Setting = Split(Setting,"|||")
		Forum_Info = Setting(0)
		Forum_Info = Split (Forum_Info,",")
		Forum_Setting = Setting(1)
		Forum_Setting = Split (Forum_Setting,",")
		Forum_user = Setting(2)
		Forum_user = Split (Forum_user,",")
		Forum_Copyright = Setting(3)
		Forum_ChanSetting = CacheData(24,0)
		Forum_ChanSetting = Split(Forum_ChanSetting,",")
		Forum_Version = CacheData(18,0)
		BadWords = Split(CacheData(3,0),"|")
		rBadWord = Split(CacheData(4,0),"|")
		Main_Sid=CacheData(17,0)
		Maxonline = CacheData(5,0)
		NowUseBBS = CacheData(19,0)
		Cookiepath = CacheData(26,0)

		'关闭论坛相关部分
		If Forum_Setting(21)="1" And Not Page_Admin Then Response.redirect "showerr.asp?action=stop"		
		Dim OpenTime,tmpsetting,ischeck
		'判断BoardID的值，获取对应的设置
		If BoardID>0 Then
			If BoardID=444 Or BoardID=777 Or BoardID="" Then
  				Response.Write "错误的版面参数"
  				Response.End
			End If
			Name="BoardInfo_" & BoardID
  			If ObjIsEmpty() Then ReloadBoardInfo(BoardID)
			Board_Data = Value
			boarduser = Split(Board_Data(13,0) & "",",")
			Board_Ads = Split(Board_Data(17,0),"$")
			Board_user = Split(Board_Data(18,0),",")
			Forum_user = Board_User
			board_Setting = Split(Board_Data(16,0),",")
			LastPost = Split(Board_Data(14,0),"$")
			BoardType = Board_Data(1,0)
			IsGroupSetting = Board_Data(19,0)
			BoardMasterList = Board_Data(8,0)
			BoardRootID = Board_Data(5,0)
			BoardParentID=Board_Data(2,0)
			Sid = Board_Data(15,0)
			Boardreadme=Board_Data(7,0)
			OpenTime=Split(Board_Setting(22),"|")
			tmpsetting=Board_Setting(21)
			Forum_ads =Board_Ads
			ischeck=Clng(Board_Setting(18))
			If Board_Setting(50)<>"0" And Board_Setting(50)<>"" Then Response.Redirect Board_Setting(50)
		Else
			Forum_ads =  CacheData(2,0)
			Forum_ads = Split(Forum_ads,"$")
			OpenTime=Split(Forum_Setting(70),"|")
			tmpsetting=Forum_Setting(69)
			ischeck=Forum_Setting(26)
			If Not IsNumeric(ischeck) Then ischeck=0
			ischeck=CLng(ischeck)		
		End If
		'IP锁定
		If Not Page_Admin Then IPlock()
		'定时开放判断
		If Not Page_Admin And Cint(tmpsetting)=1 and Ubound(OpenTime)=1 Then
			If IsNumeric(OpenTime(0)) and IsNumeric(OpenTime(1)) Then
				If CInt(OpenTime(0))< CInt(OpenTime(1)) Then
					If Hour(Now)<Cint(OpenTime(0)) or Hour(Now)>Cint(OpenTime(1)) Then Response.redirect "showerr.asp?action=stop&time"&OpenTime(0)&","&OpenTime(1)
				Else
					If Hour(Now)< Cint(OpenTime(0)) And Hour(Now) > Cint(OpenTime(1)) Then Response.redirect "showerr.asp?action=stop&time"&OpenTime(0)&","&OpenTime(1)
				End If
			End If
		End If
		'在线人数限制
		If ischeck > 0 And Not Page_Admin Then
			If MyBoardOnline.Forum_Online > ischeck And BoardID=0 Then
				If Not IsONline(Membername,1) Then Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck
			End If
			If BoardID<> 0 And MyBoardOnline.Board_Online > ischeck Then
				If Not IsONline(Membername,1) Then Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck
			End If
		End If
		If Forum_ChanSetting(0)="1" And Forum_ChanSetting(1)="1" Then Get_Chan_Ad
	End Sub 
	Public Function IsONline(UserName,action)
		IsONline=False
		If Trim(UserName)="" Then Exit Function
		If IsArray(Session("UserID")) And action=1 Then
			If Ubound(Session("UserID"))=37 Then
				IsONline=True:Exit Function 
			End If
		End If
		Dim Rs
		Set Rs =Execute("Select Count(*) From Dv_Online Where Username='"&UserName&"'")
		If Rs(0)<> 0 Then IsONline=True
		Set rs=Nothing  
	End Function  
	Public Sub ReloadSetup()
		Dim SQL,Rs,i
		SQL = "Select * from [Dv_setup] "
		Set Rs = Execute(SQL)
		value = Rs.GetRows(1)
		Set Rs = Nothing
	End Sub 
	Public Sub ReloadTemplateslist()		
		Dim Rs,SQL,tmpdata
		SQL = "select ID,StyleName from [Dv_Style]"
		Set Rs = Execute(SQL)
		tmpdata = Rs.GetString(,,"|||","@@@","")
		tmpdata = Left(tmpdata,Len(tmpdata)-3)	
		Set Rs = Nothing 
		value=tmpdata
Response.Write "错误测试："&value&""
Response.End
	End Sub
	Public Sub LoadTemplates(Page_Fields)
		If IsDeBug = 0 Then On Error Resume Next'容错代码。
		Dim Style_Pic,Main_Style,TempStyle
		CookiesSid = Request.Cookies("skin")("SkinID_"&BoardID)
		If Not IsNumeric(CookiesSid) Or CookiesSid = "" Then
			If BoardID = 0 Then 
				SkinID = Main_Sid
			Else
				SkinID = sid
			End If
		Else
			SkinID=CookiesSid
		End If
		SkinID=CLng(SkinID)
		Name="StyleName"&SkinID
		If ObjIsEmpty() Then TemplatesToCache ("StyleName")
		StyleName=value
		Name="Forum_CSS"&SkinID
		If ObjIsEmpty() Then TemplatesToCache ("Forum_CSS")
		'风格换肤修改
		CssID=Request.Cookies("skin")("cssid_"&BoardID)
		If CssID="" Then CssID=0
		CssID=CLng(CssID)
		TempStyle=value		
		TempStyle=Split(TempStyle,"@@@")
		If CssID > UBound(Split(TempStyle(1),"|||"))-1 Then
			CssID=0
		End If
		Forum_CSS=Split(TempStyle(1),"|||")(CssID)
		
		Name="Main_Style"&SkinID
		If ObjIsEmpty() Then TemplatesToCache ("Main_Style")
		Dim Rs,SQL
		SQL = "Select Main_Style from [Dv_Style] where id =1"
		Set Rs = Execute(SQL)
		Main_Style=rs("Main_Style")
set rs=nothing
'Response.Write "错误测试："&Main_Style&"<br><br>"
'Response.End
		If Not (Instr(ScriptName,"index")>0 Or Instr(ScriptName,"list")>0) Then
			Name="Style_Pic"&SkinID
			If ObjIsEmpty() Then TemplatesToCache ("Style_Pic")
			Style_Pic=value
			Style_Pic = Split(Style_Pic,"@@@")
			Forum_UserFace = Style_Pic(0)
			Forum_PostFace = Style_Pic(1)
			Forum_Emot = Style_Pic(2)
		End If
		If Page_Fields<>"" Then
			Name="page_"&Page_Fields&SkinID
			If ObjIsEmpty() Then TemplatesToCache ("page_"&Page_Fields)
			Template.value=value	
		End If
		Main_Style = Split(Main_Style,"@@@")
		mainhtml = Split(Main_Style(0),"|||")
		lanstr = Split(Main_Style(1),"|||")
		mainpic = Split(Main_Style(2),"|||")
		mainsetting = Split(mainhtml(0),"||")
		If IsDeBug = 0 Then
			If Err Then
				err.Clear
				If ReloadCount=0 Then 
					ReloadCount=1
					DelCahe "StyleName"&SkinID
					DelCahe "Forum_CSS"&SkinID
					DelCahe "Main_Style"&SkinID
					DelCahe "Style_Pic"&SkinID
					If Page_Fields<>"" Then DelCahe "page_"&Page_Fields&SkinID
					LoadTemplates Page_Fields
				End If
			End If
		End If	
	End Sub
	Public Sub TemplatesToCache(Page_Fields)
		Dim Rs,SQL
		SQL = "Select "&Page_Fields&" from [Dv_Style] where id = " & SkinID
		Set Rs = Execute(SQL)
		If Not Rs.EOF Then
			value=Rs(0)
Response.Write "错误测试x："&value&"<br><br>"
Response.End
		Else
			'处理错误
			If boardid<>0 Then
				If Cint(SkinID)=Cint(sid) Then Fixsid()
			Else
				If SkinID=CInt(CacheData(17,0)) Then
					Call FixSetupsid()		
				End if
			End If
			Response.redirect "cookies.asp?action=stylemod&SkinID=0&boardid="&Boardid					
		End If
		Set Rs = Nothing
	End Sub
	Private Sub Fixsid()
		Dim Rs,SQL