ks.publiccls.asp

本系统是根据科汛系统编写的程序

<!--#include file="KS.Thumbs.asp"-->
<!--#include file="KS.CtoECls.asp"-->
<%

Class PublicCls
	   Private LocalCacheName,Cache_Data,CacheData,Reloadtime
		Public SiteSN,Version
		Public Setting,TbSetting,SSetting
	  Private Sub Class_Initialize()
		if Not Response.IsClientConnected then response.End()
		Call KSInitialize
      End Sub
	 Private Sub Class_Terminate()

	 End Sub
	 '*******************************************************************************************************************
	 '函数名：KSInitialize
	 '作  用: 加载Flysky CMS的必要参数
	 '备  注：以下参数请不要更改。否则系统可能无法正常运行
	 '*******************************************************************************************************************
	 Public Function KSInitialize()
		Call GetConfig()
        Setting=Split(CacheData(0,0),"^%^")
		TbSetting=Split(CacheData(1,0),"^%^")
        SSetting=Split(CacheData(2,0),"^%^")
        
		SiteSN = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME")), "/", ""), ".", "") '--缓存名称
		Reloadtime = 28800
		Version = "FlyskyCMS系统"
		Call IsIPlock()      'IP访问限制
	 End Function
	 
	 '===================服务器缓存部分函数开始===================
	Public Property Let Name(ByVal vNewValue)
		LocalCacheName = LCase(vNewValue)
		Cache_Data = Application(SiteSN & "_" & LocalCacheName)
	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(SiteSN & "_" & LocalCacheName) = Cache_Data
			Application.UnLock
		Else
			Err.Raise vbObjectError + 1, "KesionCacheServer", " please change the CacheName."
		End If
	End Property
	Public Property Get Value()
		If LocalCacheName <> "" Then
			If IsArray(Cache_Data) Then
				Value = Cache_Data(0)
			Else
				'Err.Raise vbObjectError + 1, "KesionCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."
			End If
		Else
			Err.Raise vbObjectError + 1, "KesionCacheServer", " please change the CacheName."
		End If
	End Property
	Public Function ObjIsEmpty()
		ObjIsEmpty = True
		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

	'不提示,批量清除缓存,参数 PreCacheName-前段匹配
	Public Sub DelCaches(PreCacheName)
	    Dim i
		Dim CacheList:CacheList=split(GetCacheList(PreCacheName),",")
		If UBound(CacheList)>1 Then
			For i=0 to UBound(CacheList)-1
				DelCahe CacheList(i)
			Next
		End IF
	End Sub
	'取得缓存列表 参数 PreCacheName-前段匹配
	Public Function GetCacheList(PreCacheName)
		Dim Cacheobj
		For Each Cacheobj in Application.Contents
		If CStr(Left(Cacheobj,Len(PreCacheName)))=CStr(PreCacheName) Then GetCacheList=GetCacheList&Cacheobj&","
		Next
	End Function
	'清除缓存,参数 MyCaheName-缓存名称
	Public Sub DelCahe(MyCaheName)
		Application.Lock
		Application.Contents.Remove(MyCaheName)
		Application.unLock
	End Sub

	'===================服务器缓存部分函数结束===================
	    Public Sub GetSetting()
		  Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
		   RS.Open "SELECT Setting,TbSetting,SpaceSetting from [KS_Config]",conn,1,1
		   value=RS.GetRows(1)
		   RS.Close:Set RS=Nothing
		End Sub

		Public Sub GetConfig()
		Name = "Config"
		If ObjIsEmpty() Then GetSetting
		CacheData = Value
		Name = "Date"
		If ObjIsEmpty() Then
			Value = Date
		Else
			If CStr(Value) <> CStr(Date) Then
				Name = "Config"
				Call GetSetting
				CacheData = Value
			End If
		End If		
		If Len(CacheData(1, 0)) = 0 Then
			Name = "Config"
			Call GetSetting
			CacheData = Value
		End If
	 End Sub
	
	 'xmlroot跟节点名称 row记录行节点名称
	 Public Function RecordsetToxml(RSObj,row,xmlroot)
	  Dim i,node,rs,j,DataArray
	  If xmlroot="" Then xmlroot="xml"
	  If row="" Then row="row"
	  Set RecordsetToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
	  RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot))
	  If Not RSObj.EOF Then
	   DataArray=RSObj.GetRows(-1)
	   For i=0 To UBound(DataArray,2)
		Set Node=RecordsetToxml.createNode(1,row,"")
		j=0
		For Each rs in RSObj.Fields		   
		   node.attributes.setNamedItem(RecordsetToxml.createNode(2,"ks"&j,"")).text= DataArray(j,i)& ""
		   j=j+1
		Next
		RecordsetToxml.documentElement.appendChild(Node)
	   Next
	  End If
	  DataArray=Null
	 End Function
	 
	 Public Function LoadChannelConfig()
	 Application.Lock
	 Dim RS:Set Rs=conn.execute("select ChannelID,ChannelName,ChannelTable,ItemName,ItemUnit,FieldBit,BasicType,FsoHtmlTF,FsoFolder,RefreshFlag,ModelEname,MaxPerPage,VerificCommentTF,CommentVF,CommentLen,CommentTemplate,UserSelectFilesTF,InfoVerificTF,UserAddMoney,UserAddPoint,UserAddScore,ChannelStatus,CollectTF,UpFilesTF,UpFilesDir,UpFilesSize,UserUpFilesTF,UserUpFilesDir,AllowUpPhotoType,AllowUpFlashType,AllowUpMediaType,AllowUpRealType,AllowUpOtherType,SearchTemplate,EditorType From KS_Channel Order by ChannelID")
	 Set Application(SiteSN&"_ChannelConfig")=RecordsetToxml(rs,"channel","ChannelConfig")
	 Set Rs=Nothing
	 Application.unLock
	 End Function
	 
	 Function C_S(sChannelID,FieldID)
	  on error resume next
	  If not IsObject(Application(SiteSN&"_ChannelConfig")) Then LoadChannelConfig()
	   C_S=Application(SiteSN&"_ChannelConfig").documentElement.selectSingleNode("channel[@ks0=" & sChannelID & "]/@ks" & FieldID & "").text
	   if err then C_S=0:err.Clear
	 End Function
	 
	 Public Function LoadClassConfig()
	 Application.Lock
	 Dim RS:Set Rs=conn.execute("select ID,FolderName,Folder,ClassPurview,FolderDomain,TemplateID,ClassBasicInfo,ClassDefineContent,TS From KS_Class Order by ClassID")
	 Set Application(SiteSN&"_class")=RecordsetToxml(rs,"class","classConfig")
	 Set Rs=Nothing
	 Application.unLock
	 End Function

	 Function C_C(ClassID,FieldID)
	  on error resume next
	  If not IsObject(Application(SiteSN&"_class")) Then LoadClassConfig()
	   C_C=Application(SiteSN&"_class").documentElement.selectSingleNode("class[@ks0=" & classID & "]/@ks" & FieldID & "").text
	 End Function
	
	'**************************************************
	'函数名：LoadSelectClass
	'作  用：返回目录树。
	'参  数：ChannelID-----返回频道目录树
	'返回值：整棵树
	'**************************************************
	Public Function LoadSelectClass(ChannelID)
	    On Error resume next
		Dim Node,K,SQL
		If Not IsNumeric(ChannelID) Then Exit Function
		If Not IsObject(Application(SiteSN&"_selectclass")) Then
			Set  Application(SiteSN&"_selectclass")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
		    Application(SiteSN&"_selectclass").appendChild( Application(SiteSN&"_selectclass").createElement("xml"))
            Dim RSC:Set RSC=Conn.Execute("Select ChannelID From KS_Channel Where ChannelStatus=1 order by channelid")
		    Do While Not RSC.Eof
			 Dim ID,RS,TreeStr
			 Set  RS=Conn.Execute("select ID,FolderName from KS_Class Where ChannelID=" & rsc(0) & " AND tj=1 Order BY FolderOrder ASC")
			 If Not RS.Eof Then
				SQL=RS.GetRows(-1):RS.Close:Set RS = Nothing
				For K=0 To Ubound(SQL,2)
				  ID=trim(SQL(0,K))
				  TreeStr = TreeStr & "<option value='" & ID & "' {ClassID=" & ID & "}>" & Trim(SQL(1,K)) & " </option>"
				  TreeStr = TreeStr & ReturnSubList("TN='" & ID & "'")
				Next
			 Set Node=Application(SiteSN&"_selectclass").documentElement.appendChild(Application(SiteSN&"_selectclass").createNode(1,"selectclass",""))
			Node.attributes.setNamedItem(Application(SiteSN&"_selectclass").createNode(2,"channelid","")).text=rsc(0)
			Node.text=TreeStr
			TreeStr=""
		   End If
		  RSC.MoveNext
		 Loop
		 RSC.Close:Set RSC=Nothing
     End If
	LoadSelectClass=Application(SiteSN&"_selectclass").documentElement.selectSingleNode("selectclass[@channelid=" & ChannelID & "]").text
	End Function
	'**************************************************
	'函数名：ReturnSubList
	'作  用：查找并返子树数据。
	'参  数：ParentID ----父节点ID
	'返回值：子树
	'**************************************************
	Public Function ReturnSubList(Param)
	  Dim SubTypeList, RS, SpaceStr, k, Total, Num,ID,TJ,SQL,n
	  Set RS=Conn.Execute("Select ID,FolderName,TJ from KS_Class Where " & Param & " Order BY FolderOrder ASC")
	  Num = 0
	  If RS.Eof Then ReturnSubList="":RS.Close:Set RS=Nothing:Exit Function
	  SQL=RS.GetRows(-1):Total=Ubound(SQL,2)
	  For n=0 To Total
	   Num = Num + 1:SpaceStr = "":TJ = CInt(SQL(2,N))
		For k = 1 To TJ - 1
		  If k = 1 And k <> TJ - 1 Then
		  SpaceStr = SpaceStr & "　│"
		  ElseIf k = TJ - 1 Then
			If Num = Total+1 Then
				 SpaceStr = SpaceStr & "　└ "
			Else
				 SpaceStr = SpaceStr & "　├ "
			End If
		  Else
		   SpaceStr = SpaceStr & "　│"
		  End If
		Next
	  ID = Trim(SQL(0,N))
	   SubTypeList = SubTypeList & "<option value='" & ID & "' {ClassID=" & ID & "}>" & SpaceStr & Trim(SQL(1,N)) & "</option>"
	   SubTypeList = SubTypeList & ReturnSubList("TN='" & ID & "'")
	 Next
	  ReturnSubList = SubTypeList
	End Function 
	
	 
	 Sub IsIPlock()
	   On Error Resume Next
	    If Setting(100)=0 Then Exit Sub
		If session("KS_IPlock") = "" Then
			session("KS_IPlock") = CheckIPlock(Setting(100), Setting(101), GetIP)
		End If
		If session("KS_IPlock") = True Then
			Response.Write "对不起！您的IP（" &GetIP & "）被系统限定。您可以和站长联系。"
			Response.End
		End If
	End Sub
	Function EncodeIP(Sip)
		Dim strIP:strIP = Split(Sip, ".")
		If UBound(strIP) < 3 Then
			EncodeIP = 0:Exit Function
		End If
		If IsNumeric(strIP(0)) = 0 Or IsNumeric(strIP(1)) = 0 Or IsNumeric(strIP(2)) = 0 Or IsNumeric(strIP(3)) = 0 Then
			Sip = 0
		Else
			Sip = CInt(strIP(0)) * 256 * 256 * 256 + CInt(strIP(1)) * 256 * 256 + CInt(strIP(2)) * 256 + CInt(strIP(3)) - 1
		End If
		EncodeIP = Sip
	End Function
	Function CStrIP(ByVal anNewIP)
	Dim lsResults ' Results To be returned
	Dim lnTemp ' Temporary value being parsed
	Dim lnIndex ' Position of number being parsed
	For lnIndex = 3 To 0 Step-1
	lnTemp = Int(anNewIP / (256 ^ lnIndex))
	lsResults = lsResults & lnTemp & "."
	anNewIP = anNewIP - (lnTemp * (256 ^ lnIndex))
	Next
	lsResults = Left(lsResults, Len(lsResults) - 1)
	lsResults=Split(lsResults,".")
	Dim IPStr,i:For I=0 To Ubound(lsResults)
	 if i=3 then 
	  IPStr=IPStr & "." &lsResults(3)+1
	 elseif i=0 then 
	   IPStr=lsResults(0) 
	 else 
	  IPStr=IPStr & "." & lsResults(i)
	 end if
	Next
	CStrIP = IPStr
	End Function 
	'白名单的端点可以访问和黑名单的端点将不允许访问。
	Function ChecKIPlock(ByVal sLockType, ByVal sLockList, ByVal sUserIP)
		Dim IPlock, rsLockIP
		Dim arrLockIPW, arrLockIPB, arrLockIPWCut, arrLockIPBCut
		IPlock = False
		ChecKIPlock = IPlock
		Dim i, sKillIP
		If sLockType = "" Or IsNull(sLockType) Then Exit Function
		If sLockList = "" Or IsNull(sLockList) Then Exit Function
		If sUserIP = "" Or IsNull(sUserIP) Then Exit Function
		sUserIP = CDbl(EncodeIP(sUserIP))
		rsLockIP = Split(sLockList, "|||")
		If sLockType = 4 Then
			arrLockIPB = Split(Trim(rsLockIP(1)), "$$$")
			For i = 0 To UBound(arrLockIPB)
				If arrLockIPB(i) <> "" Then
					arrLockIPBCut = Split(Trim(arrLockIPB(i)), "----")
					IPlock = True
					If CDbl(arrLockIPBCut(0)) > sUserIP Or sUserIP > CDbl(arrLockIPBCut(1)) Then IPlock = False