clsmain.asp

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

			Session("GetCode")=empty
		End If	
	End Function

	Public Sub ChkPost()		'检测来源
		If Forum_setting(49) = 1 then
			Dim server_v1,server_v2,Chkpost
			Chkpost=False 
			server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
			server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
			If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True
			If Chkpost = False Then error "来源错误"
		End if
	End Sub

	Public Sub LockIP()
		Dim IPlock,locklist
		Dim i,StrUserIP,StrKillIP
		Locklist = Club_Class(6)
		StrUserIP = RemoteAddr					'用户来源IP
		If StrUserIP & "" = "" Then Exit Sub
		StrUserIP=Split(StrUserIP,".")				'用户IP分段
		If Ubound(StrUserIP)<>3 Then Exit Sub
		If Trim(Locklist) &"" = "" Then
			Exit Sub
		Else
			If InStr(Locklist,Chr(13)&Chr(10)) >0 Then
				Locklist = Split(locklist,Chr(13)&Chr(10))
				For i= 0 to UBound(Locklist)
					Locklist(i)=Trim(Locklist(i))
					If Locklist(i)<>"" Then 
						StrKillIP = Split(Locklist(i),".")	'受限IP分段
						If Ubound(StrKillIP)<>3 Then Exit For
						IPlock = True
						If (StrUserIP(0) <> StrKillIP(0)) And Instr(StrKillIP(0),"*")=0 Then IPlock=False
						If (StrUserIP(1) <> StrKillIP(1)) And Instr(StrKillIP(1),"*")=0 Then IPlock=False
						If (StrUserIP(2) <> StrKillIP(2)) And Instr(StrKillIP(2),"*")=0 Then IPlock=False
						If (StrUserIP(3) <> StrKillIP(3)) And Instr(StrKillIP(3),"*")=0 Then IPlock=False
						If IPlock Then Exit For
					End If
				Next
			Else
				If Locklist <>"" Then 
					StrKillIP = Split(Locklist,".")	'受限IP分段
					If Ubound(StrKillIP)=3 Then
						IPlock = True
						If (StrUserIP(0) <> StrKillIP(0)) And Instr(StrKillIP(0),"*")=0 Then IPlock=False
						If (StrUserIP(1) <> StrKillIP(1)) And Instr(StrKillIP(1),"*")=0 Then IPlock=False
						If (StrUserIP(2) <> StrKillIP(2)) And Instr(StrKillIP(2),"*")=0 Then IPlock=False
						If (StrUserIP(3) <> StrKillIP(3)) And Instr(StrKillIP(3),"*")=0 Then IPlock=False
					End if
				End If				
			End if
			'判断Cookies更新目录
			Dim cookies_path_s,cookies_path_d,cookies_path
			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 & "Kill").Expires = DateAdd("s", 360, Now())
			Response.Cookies(Forum_sn & "Kill").Path = cookies_path
			If IPlock Then
				Response.Cookies(Forum_sn & "Kill")("kill") = "1"
			Else
				Response.Cookies(Forum_sn & "Kill")("kill") = "0"
			End If
		End if
	End Sub

	Function myBoardJump()
		Dim RS,tmp,tmp1,i
		Cache.Name = "BoardJump"
		Cache.Reloadtime = Cid(Forum_setting(44))
		If Cache.ObjIsEmpty() Then
			Set Rs=Execute("Select ID,Bbsname,Followid From ["&Isforum&"bbsconfig] Where Hide=0 Order By SortNum")
	   		If RS.Eof Then
				Exit Function
			Else
	      		Cache.Value = Rs.GetRows(-1)
	   		End If
			Rs.Close:Set Rs=Nothing
		End If
		myBoardJump = Cache.Value
	End Function

	Function BoardJump()	
		Dim tmp1,i,Boards
		Boards = myBoardJump()
		tmp1 = "<select onchange=""if(this.options[this.selectedIndex].value!=''){location=this.options[this.selectedIndex].value;}""><option value="""" selected>论坛跳转 ...</option>"
		If IsArray(Boards) Then
			For i = 0 To UBound(Boards,2)
				If Boards(2,i)=0 Then
					tmp1 = tmp1 & "<optgroup label="""&Boards(1,i) &""">"& BoardJump_Li(Boards(0,i),0)&"</optgroup>"
				End if
			Next
		End if
		tmp1 = tmp1 & " </select>"
		BoardJump = tmp1 
	End Function

	Function BoardJump_Li(a,b)
		Dim tmp1,i,Boards
		Dim U,Y
		Boards = myBoardJump()
		If isArray(Boards) Then
			For i=0 To Ubound(Boards,2)
				If Boards(2,i) = a Then
					U = 1+b
					tmp1 = tmp1 & "<option value=""Forums.asp?fid="&Boards(0,i)&""">"
					For Y=0 To U
						tmp1 = tmp1 & "&nbsp; &nbsp;"
					Next
					tmp1 = tmp1 & "&gt; "& Boards(1,i)&"</option>" 
					tmp1 = tmp1 & BoardJump_Li(Boards(0,i),U) 
				End if
			Next
		End if
		BoardJump_Li = tmp1
	End function

	Function BBs_Value_List(a,b)
		Dim tmp1,i,Boards
		Dim U,Y
		Boards = myBoardJump()
		If isArray(Boards) Then
			For i=0 To Ubound(Boards,2)
				If Boards(2,i) = a Then
					U = 1+b
					tmp1 = tmp1 & "<option value="""&Boards(0,i)&""">"
					For Y=0 To U
						tmp1 = tmp1 & "&nbsp; &nbsp;"
					Next
					If a = 0 Then
						tmp1 = tmp1 & "╋"
					Else
						tmp1 = tmp1 & "├"
					End if
					tmp1 = tmp1 & ""& Boards(1,i)&"</option>" & Vbcrlf
					tmp1 = tmp1 & BBs_Value_List(Boards(0,i),U) 
				End if
			Next
		End if
		BBs_Value_List = tmp1
	End function

	'记录查询错误事件
	Public Sub SaveLOG(msg)
		Dim lConnStr,lConn,ldb
		ldb = MyDbPath & LogDate
		lConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
		Set lConn = Server.CreateObject("ADODB.Connection")
		lConn.Open lConnStr
		lConn.Execute("Insert Into SaveLog (UserName,IP,Windows,Remark,Logtime) Values ('"&TK_UserName&"','"&RemoteAddr&"','"&Request.Servervariables("HTTP_USER_AGENT")&"','"&Replace(Left(msg,255),"'","''")&"','"&Now&"')")
		lConn.Close
		Set lConn = Nothing 
	End Sub

	Public Function address(sip)
		Dim aConnStr,aConn,adb
		Dim str1,str2,str3,str4
		Dim  num
		Dim country,city
		Dim irs,SQL
		address="未知"
		If IsNumeric(Left(sip,2)) Then
			If sip="127.0.0.1" Then sip="192.168.0.1"
			str1=Left(sip,InStr(sip,".")-1)
			sip=mid(sip,instr(sip,".")+1)
			str2=Left(sip,instr(sip,".")-1)
			sip=Mid(sip,InStr(sip,".")+1)
			str3=Left(sip,instr(sip,".")-1)
			str4=Mid(sip,instr(sip,".")+1)
			If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then
			Else		
				num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1
				adb = IPDate
				aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)
				Set AConn = Server.CreateObject("ADODB.Connection")
				aConn.Open aConnStr
				country="亚洲"
				city=""
				sql="select top 1 country,city from tm_address where ip1 <="& num &" and ip2 >="& num 
				Set irs=aConn.execute(sql)
				If Not(irs.EOF And irs.bof) Then
					country=irs(0)
					city=irs(1)
				End If
				irs.close
				Set irs=Nothing
				aConn.Close
				Set aConn = Nothing 
				SqlQueryNum = SqlQueryNum+1
			End If
			address=country&city
		End If
	End Function
	'是否真正的搜索引擎
	Public Function IsWebSearch()
		IsWebSearch = False
		Dim Botlist,i,Agent
		Agent = Request.ServerVariables("HTTP_USER_AGENT")
		Botlist=Array("Google,Isaac,SurveyBot,Baiduspider,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir")
		For i=0 to UBound(Botlist)
			If InStr(Agent,Botlist(i))>0  Then 
				IsWebSearch = True
				Exit For
			End If
		Next 
	End Function

	Public Function BuildFile(ByVal sFile, ByVal sContent)
		Dim is_gb2312
        Dim oFSO, oStream
		If Int(Forum_setting(65)) = 0 Then Exit Function
		is_gb2312 = 1
        If is_gb2312 = 1 Then
            Set oFSO = server.CreateObject("Scripting.FileSystemObject")
			sFile=Server.MapPath(sFile)
            Set oStream = oFSO.CreateTextFile(sFile, True)
            oStream.Write sContent
            oStream.Close
            Set oStream = Nothing
            Set oFSO = Nothing
        Else
            Set oStream = server.CreateObject("ADODB.Stream")
            With oStream
                .Type = 2
                .Mode = 3
                .Open
                .Charset = "gb2312"
                .Position = oStream.size
				.Write = sContent
                .SaveToFile sFile, 2
                .Close
            End With
            Set oStream = Nothing
        End If
    End Function

	Public Function Checkstr(Str)
		If Isnull(Str) Then
			CheckStr = ""
			Exit Function 
		End If
		Str = Replace(Str,Chr(0),"")
		CheckStr = Replace(Str,"'","''")
	End Function

   	Public Function Execute(SQL)
		If Not IsObject(Conn) Then ConnectionDatabase
		If IsDeBug = 0 Then 
			On Error Resume Next
			Set Execute = Conn.Execute(SQL)
			If Err Then
				Err.Clear
				Set Conn = Nothing
				Response.Write "数据查询错误，请检查您的查询代码是否正确。"
				Response.End
			End If
		Else
			Response.Write SQL & "<br>"
			Set Execute = Conn.Execute(SQL)
		End If
		SqlQueryNum = SqlQueryNum+1
   	End Function
	'释放
	Public Sub Htmlend
		Set team = Nothing
		Set Cache = Nothing
		Set conn = Nothing
		Response.End
	End sub

	'类注销
	Private Sub Class_Terminate()
		Err.Clear
		If IsObject(Conn) Then Conn.Close:Set Conn=Nothing
		If IsObject(Cache) Then Cache.Close:Set Cache=Nothing
		If IsObject(team) Then team.Close:Set team=Nothing
		Response.End
	End Sub
End Class

Class Cls_Cache
	'缓存类 By DV
	Public Reloadtime,MaxCount
	Private LocalCacheName,CacheData,DelCount
	Private Sub Class_Initialize()
		Reloadtime=14400	'定义默认更新时间
	End Sub
	Private Sub SetCache(SetName,NewValue)
		Application.Lock	'锁定
		Application(SetName) = NewValue		'赋值
		Application.unLock	'解除锁定
	End Sub 
	Public Sub MakeEmpty(MyCaheName)
		Application.Lock	'锁定
		Application(CacheName&"_"&MyCaheName) = Empty	'清除缓存
		Application.unLock	'解除锁定
	End Sub 
	Public  Property Let Name(ByVal vNewValue) 'ByVal关键字,vNewValue自定义变量
		LocalCacheName=LCase(vNewValue)	'设置类变量Name
	End Property
	Public  Property Let Value(ByVal vNewValue)	'设置类变量Value
		If LocalCacheName<>"" Then 
			CacheData=Application(CacheName&"_"&LocalCacheName)
			If IsArray(CacheData)  Then
				CacheData(0)=vNewValue
				CacheData(1)=Now()
			Else
				ReDim CacheData(2)
				CacheData(0)=vNewValue
				CacheData(1)=Now()
			End If
			SetCache CacheName&"_"&LocalCacheName,CacheData
		Else
			Err.Raise vbObjectError + 1, "CacheServer", "请修改CacheName名称"
		End If		
	End Property
	Public Property Get Value()	'Value取值
		If LocalCacheName<>"" Then 
			CacheData=Application(CacheName&"_"&LocalCacheName)	
			If IsArray(CacheData) Then
				Value=CacheData(0)
			Else
				Err.Raise vbObjectError + 1, "CacheServer", " The CacheData Is Empty."
			End If
		Else
			Err.Raise vbObjectError + 1, "CacheServer", " please change the CacheName."
		End If
	End Property
	Public Function ObjIsEmpty()	'检测是否为空
		ObjIsEmpty=True
		CacheData=Application(CacheName&"_"&LocalCacheName)
		If Not IsArray(CacheData) Then Exit Function
		If Not IsDate(CacheData(1)) Then Exit Function
		If DateDiff("s",CDate(CacheData(1)),Now()) < 60*Reloadtime  Then
			ObjIsEmpty=False
		End If
	End Function
	Public Sub DelCache(MyCaheName)	'删除缓存
		Application.Lock
		Application.Contents.Remove(CacheName&"_"&MyCaheName)
		Application.unLock
	End Sub
End Class
%>