dv_clsmain.asp

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

		i3 = 0
		If Forum_AdLoop3<>"" And Forum_ChanSetting(5)="1" And Instr(ScriptName,"dispbbs")>0 Then
			Name = "TopicAdCode"
			If ObjIsEmpty() Then LoadTopicAdCode
			If IsArray(Value) Then
				TempData = Value
				For i=0 To Ubound(TempData,2)
					If TempData(1,i)=239 Or TempData(1,i)=240 Or TempData(1,i)=1 Or TempData(1,i)=2 Then
						ad_3(i3)=" "
					Else
						ad_3(i3)=ReCssUrl(TempData(0,i))
					End If
					i3 = i3 + 1
				Next
			End If
		End If
		If i3=0 Then Ad_3(0)=" "
	End Function
	Private Function LoadTopicAdCode()
		Dim Rs
		Set Rs=Execute("Select a_adcode,a_id From Dv_AdCode Where a_id In ("&Forum_AdLoop3&")")
		If Not Rs.Eof Then
			Value = Rs.GetRows(-1)
		Else
			Value = ""
		End If
		Set Rs=Nothing
	End Function
	Private Function LoadForumAdCode1()
		Dim Rs
		Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0001'")
		If Not Rs.Eof Then
			Value = Rs.GetRows(-1)
		Else
			Value = ""
		End If
		Set Rs=Nothing
	End Function
	Private Function LoadForumAdCode2()
		Dim Rs
		Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0002'")
		If Not Rs.Eof Then
			Value = Rs.GetRows(-1)
		Else
			Value = ""
		End If
		Set Rs=Nothing
	End Function
	Private Function LoadForumAdCode3()
		Dim Rs
		Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0004'")
		If Not Rs.Eof Then
			Value = Rs.GetRows(-1)
		Else
			Value = ""
		End If
		Set Rs=Nothing
	End Function
	Public Function ReCssUrl(str)
		if str="" then exit function
		str=replace(str,"%css%","Get_Css.asp?SkinID="&SkinID)
		str=replace(str,"%url%",Forum_info(1))
		If CacheData(23,0)="" or isnull(CacheData(23,0)) Then
		str=replace(str,"%username%","dvbbs")
		str=replace(str,"%mouseId%","dvbbs")
		Else
		str=replace(str,"%username%",CacheData(23,0))
		str=replace(str,"%mouseId%",CacheData(23,0))
		End If
		ReCssUrl=str
	End Function
	Rem 读取部分
	Public Property Get RegSplitWords
		Dim Setting:Setting = Split(CacheData(1,0),"|||"):RegSplitWords = Setting(4)
	End Property
	Public Function ReloadBoardInfo(BoardID)
		'数组(21)用来记录版面的下拉菜单,22用来保存该版面的导航,23用来保存该版面的新闻和小字报
		Dim Rs,GetData
		Set Rs=Execute("select BoardID,BoardType,ParentID,ParentStr,Depth,RootID,Child,readme,BoardMaster,PostNum,TopicNum,indexIMG,todayNum,boarduser,LastPost,Sid,Board_Setting,Board_Ads,Board_user,IsGroupSetting,BoardTopStr,BoardID As TempStr,BoardID As TempStr1,BoardID As TempStr2 from Dv_board where BoardID="&BoardID)
  			If Not Rs.Eof Then
  				Name = "BoardInfo_" & BoardID
   				Value = Rs.GetRows(1)
				GetData = Value
				'If GetData(2,0)>0 Then LoadBoardParentStr BoardID,GetData(3,0)
				'LoadBoardNews_Paper(BoardID)
				LoadBoardList(BoardID)
  			Else
  				'自动修正所有版面的boards数
  				ReloadAllBoardInfo()
  				Response.Redirect "index.asp"
  			End If
  		Rs.Close
  		Set Rs = Nothing
 	End Function
	'缓存版面公告和小字报信息
	Public Function LoadBoardNews_Paper(BoardID)
		Dim tRs,bgs,MyGetData,TempStr,NoAnn,NoColor
		If Not IsArray(lanstr) Then
			NoAnn = "当前没有公告"
		Else
			NoAnn = lanstr(9)
		End If
		If Not IsArray(mainsetting) Then
			NoColor = "blue"
		Else
			NoColor = mainsetting(10)
		End If
		Set tRs=Execute("Select Top 1 title,addtime,bgs From [Dv_bbsnews] Where boardid="&BoardID&" Order By ID Desc")
		If tRs.BOF And tRs.EOF Then
			TempStr = NoAnn & "|||"
		Else
			bgs=tRs(2)
			If bgs="" or IsNull(bgs) Then
				TempStr=tRs(0) & "|||" & tRs(1)
			Else
				TempStr="<img src=Skins/Default/filetype/mid.gif border=0><bgsound src="&bgs&" border=0>"&tRs(0)&"|||"&tRs(1)
			End if
		End If
		'小字报部分
		If IsSqlDataBase=1 Then
			Set tRs=Execute("Select Top 5 S_id as id,S_username as postuser,S_title as topic From Dv_Smallpaper Where Datediff(D,S_addtime,"&SqlNowString&")<=1 And S_boardid="&BoardID&" Order By S_addtime Desc")
		Else
			Set tRs=Execute("Select Top 5 S_id as id,S_username as postuser,S_title as topic From Dv_Smallpaper Where Datediff('D',S_addtime,"&SqlNowString&")<=1 And S_boardid="&BoardID&" Order By S_addtime Desc")
		End If
		If tRs.Eof And tRs.Bof Then
			TempStr=TempStr & "|||"
		Else
			Dim TempData,i
			TempData=tRs.GetRows(-1)
			For i=0 To Ubound(TempData,2)
				If i=0 Then
					TempStr = TempStr & "|||&nbsp;&nbsp;<font color="&NoColor&">"&HtmlEncode(TempData(1,i))&"</font>：<a href=javascript:openScript(""viewpaper.asp?id="&TempData(0,i)&"&boardid="&BoardID&""",500,400)>"&HtmlEncode(TempData(2,i))&"</a>&nbsp;&nbsp;"
				Else
					TempStr = TempStr & "&nbsp;&nbsp;<font color="&NoColor&">"&HtmlEncode(TempData(1,i))&"</font>：<a href=javascript:openScript(""viewpaper.asp?id="&TempData(0,i)&"&boardid="&BoardID&""",500,400)>"&HtmlEncode(TempData(2,i))&"</a>&nbsp;&nbsp;"
				End If
			Next
		End If
		MyGetData = Value
		MyGetData(23,0) = TempStr
		Value = MyGetData
		Set tRs=Nothing
	End Function
	'缓存导航相关信息
	Public Function LoadBoardParentStr(BoardID,MyParentStr)
		Dim tRs,GetData,MyGetData
		Set tRs=Execute("Select Boardid,Boardtype,Boardmaster,Parentid From Dv_Board Where Boardid In ("&MyParentStr&") Order By Orders")
		If Not tRs.Eof Then
			GetData = tRs.GetRows(-1)
			MyGetData = Value
			MyGetData(22,0) = GetData
			Value = MyGetData
		End If
		Set tRs = Nothing
	End Function
	Private Function LoadBoardList(BoardID)
		Dim Forum_Boards,i,ii,Depth,Board_Datas,MyBoardList,MyBoardRootID,MyBoard_Data
		If BoardID=0 Then Exit Function
		Name="BoardInfo_" & BoardID
		MyBoard_Data=value
		MyBoardRootID=Clng(MyBoard_Data(5,0))
		Forum_Boards=Split(CacheData(27,0),",")
		For i=0 To Ubound(Forum_Boards)
			Name="BoardInfo_" & Forum_Boards(i)
			If ObjIsEmpty() Then ReloadBoardInfo(Forum_Boards(i))
			Board_Datas = Value
			Depth=Board_Datas(4,0)
			If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "<a href=list.asp?boardid="&Forum_Boards(i)&">"
			Select Case Depth
			Case 0
				If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "╋"
			Case 1
				If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "&nbsp;&nbsp;├"
			End Select
			If Depth>1 Then
				For ii=2 To Depth
					If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "&nbsp;&nbsp;│"
				Next
				If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "&nbsp;&nbsp;├"
			End If
			If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & Board_Datas(1,0) & "</a><br>"
		Next
		Name="BoardInfo_" & BoardID
		MyBoard_Data=value
		MyBoard_Data(21,0)=MyBoardList
		value=MyBoard_Data
		Forum_Boards=Null
		Board_Datas=Null
	End Function
	Public Function ReloadAllBoardInfo()
		Dim Rs,Boards,i
		i = 0
		Set Rs=Execute("Select BoardID From Dv_Board Order By RootID,Orders")
		Do While Not Rs.Eof
			If i = 0 Then
				Boards = Rs(0)
			Else
				Boards = Boards & "," & Rs(0)
			End If
			i = i + 1
		Rs.MoveNext
		Loop
		Set Rs=Nothing
		Execute("Update dv_Setup Set Forum_Boards='"&Boards&"'")
		ReloadSetupCache Boards,27
	End Function
	'更新分版面部分缓存数组，入口：版面ID、更新内容、数组位置、更新方式，0直接赋值，1数值相加
	Public Sub ReloadBoardCache(BoardID,MyValue,N,act)
		If BoardID=444 Or BoardID=777 Or BoardID="" Then
  			Response.Write "错误的版面参数"
  			Response.End
		End If
		Dim Tmpdata
		Name="BoardInfo_" & BoardID
		If ObjIsEmpty() Then ReloadBoardInfo(BoardID)
		Tmpdata=Value
		If act=1 And IsNumeric(Tmpdata(N,0)) And IsNumeric(MyValue) Then
			Tmpdata(N,0)=CLng(Tmpdata(N,0))+MyValue
		Else
			Tmpdata(N,0) = MyValue
   		End If
   		Value=Tmpdata
	End Sub
	Public Function ReloadForumPlusMenu()
		Dim Rs,tRs,TempMenu,TempMenu1,MSetting
		Name="ForumPlusMenu"&SkinID
		Set Rs=Dvbbs.Execute("Select * From Dv_Plus Where Plus_Type='0' Order By ID")
		If Rs.Eof And Rs.Bof Then
			Value=""
			Exit Function
		End If
		Do While Not Rs.Eof
			MSetting=Split(Rs("Plus_Setting"),"|")
			Set tRs=Dvbbs.Execute("Select * From Dv_Plus Where Plus_Type='"&Rs("ID")&"' Order By ID")
			If tRs.Eof And tRs.Bof Then
				Select Case MSetting(0)
				Case 0
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href="""&Rs("MainPage")&""" title="""&Rs("Plus_CopyRight")&""">"&Rs("Plus_Name")&"</a>"
				Case 1
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href="""&Rs("MainPage")&""" title="""&Rs("Plus_CopyRight")&""" target=_blank>"&Rs("Plus_Name")&"</a>"
				Case 2
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href=""JavaScript:openScript('"&Rs("MainPage")&"',"&MSetting(1)&","&MSetting(2)&")"" title="""&Rs("Plus_CopyRight")&""">"&Rs("Plus_Name")&"</a>"
				Case 3
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href=""JavaScript:openScript('"&Rs("MainPage")&"',screen.width,screen.height)"" title="""&Rs("Plus_CopyRight")&""">"&Rs("Plus_Name")&"</a>"
				End Select
			Else
				Do While Not tRs.Eof
					MSetting=Split(tRs("Plus_Setting"),"|")
					Select Case MSetting(0)
					Case 0
						TempMenu1 = TempMenu1 & "<div class=menuitems><a href="&tRs("MainPage")&" title="&tRs("Plus_CopyRight")&">"&tRs("Plus_Name")&"</a></div>"
					Case 1
						TempMenu1 = TempMenu1 & "<div class=menuitems><a href="&tRs("MainPage")&" title="&tRs("Plus_CopyRight")&" target=_blank>"&tRs("Plus_Name")&"</a></div>"
					Case 2
						TempMenu1 = TempMenu1 & "<div class=menuitems><a href=JavaScript:openScript(\'"&tRs("MainPage")&"\',"&MSetting(1)&","&MSetting(2)&") title="&tRs("Plus_CopyRight")&">"&tRs("Plus_Name")&"</a></div>"
					Case 3
						TempMenu1 = TempMenu1 & "<div class=menuitems><a href=JavaScript:openScript(\'"&tRs("MainPage")&"\',screen.width,screen.height) title="&tRs("Plus_CopyRight")&">"&tRs("Plus_Name")&"</a></div>"
					End Select
				tRs.MoveNext
				Loop
				MSetting=Split(Rs("Plus_Setting"),"|")
				Select Case MSetting(0)
				Case 0
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href="""&Rs("MainPage")&""" title="""&Rs("Plus_CopyRight")&""" onMouseOver=""showmenu(event,'"&TempMenu1&"')"">"&Rs("Plus_Name")&"</a>"
				Case 1
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href="""&Rs("MainPage")&""" title="""&Rs("Plus_CopyRight")&""" target=_blank onMouseOver=""showmenu(event,'"&TempMenu1&"')"">"&Rs("Plus_Name")&"</a>"
				Case 2
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href=""JavaScript:openScript('"&Rs("MainPage")&"',"&MSetting(1)&","&MSetting(2)&")"" title="""&Rs("Plus_CopyRight")&""" onMouseOver=""showmenu(event,'"&TempMenu1&"')"">"&Rs("Plus_Name")&"</a>"
				Case 3
					TempMenu = TempMenu & " <img src="&mainpic(18)&" align=absmiddle> <a href=""JavaScript:openScript('"&Rs("MainPage")&"',screen.width,screen.height)"" title="""&Rs("Plus_CopyRight")&""" onMouseOver=""showmenu(event,'"&TempMenu1&"')"">"&Rs("Plus_Name")&"</a>"
				End Select
				TempMenu1=""
			End If
		Rs.MoveNext
		Loop
		Value=TempMenu
		Set tRs=Nothing
		Set Rs=Nothing
	End Function
	'取得带端口的URL，推荐使用
	Property Get Get_ScriptNameUrl()
		If request.servervariables("SERVER_PORT")="80" Then
			Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
		Else
			Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
		End If
	End Property
	'删除服务器上论坛的所有缓存数据
	Public Sub DelallCache()
	Dim Cacheobj
	For Each Cacheobj in Application.Contents
		If CStr(Left(Cacheobj,Len(CacheName)+1))=CStr(CacheName&"_") Then
			Application.Lock
			Application.Contents.Remove(Cacheobj)
			Application.UnLock	
		End If
	Next 
	End Sub 
End Class
Class cls_Templates
	Public html,Strings,pic
	Public Property Let Value(ByVal vNewValue)
		Dim tmpstr:tmpstr = vNewValue:tmpstr = Split(tmpstr,"@@@")
		html = Split(tmpstr(0),"|||"):Strings = Split(tmpstr(1),"|||"):pic = Split(tmpstr(2),"|||")
	End Property
End Class
Class cls_UserOnlne
	Public Forum_Online,Forum_UserOnline,Forum_GuestOnline
	Private l_Online,l_GuestOnline
	Private Sub Class_Initialize()
		Dvbbs.Name="Forum_Online"
		Dvbbs.Reloadtime=60
		If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum
		Dvbbs.Name="Forum_Online"
		Forum_Online = Dvbbs.Value
		Dvbbs.Name="Forum_UserOnline"
		If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum
		Forum_UserOnline=Dvbbs.Value
		If Forum_Online < 0  Or Forum_UserOnline < 0 Or Forum_UserOnline > Forum_Online Then ReflashOnlineNum
		Forum_GuestOnline = Forum_Online - Forum_UserOnline
		l_Online=-1:l_GuestOnline=-1
		Dvbbs.Reloadtime=28800
	End Sub
	Public Sub OnlineQuery()
		Dim SQL,SQL1
		Dim TempNum,TempNum1
		Dvbbs.Name="delOnline_time"
		If Dvbbs.ObjIsEmpty() Then Dvbbs.Value=Now()
		If DateDiff("s",Dvbbs.Value,Now()) > Cint(Dvbbs.Forum_Setting(8))*10 Then
			Dvbbs.Value=Now()
			If Not IsObject(Conn) Then ConnectionDatabase
			If IsSqlDataBase = 1 Then
				SQL = "Delete From [DV_Online] Where UserID=0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & CInt(Dvbbs.Forum_Setting(8))
				SQL1 = "Delete From [DV_Online] Where UserID>0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & CInt(Dvbbs.Forum_Setting(8))
			Else
				SQL = "Delete From [Dv_Online] Where UserID=0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60" 
				SQL1 = "Delete From [Dv_Online] Where UserID>0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60"
			End If
			Conn.Execute SQL,TempNum
			Conn.Execute SQL1,TempNum1
			Dvbbs.SqlQueryNum =