ks.publiccls.asp

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

	'**************************************************
	Public Function R(strChar)
		If strChar = "" Or IsNull(strChar) Then R = "":Exit Function
		Dim strBadChar, arrBadChar, tempChar, I
		'strBadChar = "$,#,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ""
		strBadChar = "+,',--,%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ""
		arrBadChar = Split(strBadChar, ",")
		tempChar = strChar
		For I = 0 To UBound(arrBadChar)
			tempChar = Replace(tempChar, arrBadChar(I), "")
		Next
		tempChar = Replace(tempChar, "@@", "@")
		R = tempChar
	End Function
	
	Function FilterIDs(byval strIDs)
	Dim arrIDs,i,strReturn
	strIDs=Trim(strIDs)
	If Len(strIDs)=0  Then Exit Function
	arrIDs=Split(strIDs,",")
	For i=0 To Ubound(arrIds)
		If ChkClng(Trim(arrIDs(i)))<>0 Then
			strReturn=strReturn & "," & Int(arrIDs(i))
		End If
	Next
	If Left(strReturn,1)="," Then strReturn=Right(strReturn,Len(strReturn)-1)
	FilterIDs=strReturn
	End Function
	'********************************************
	'函数名：IsValidEmail
	'作  用：检查Email地址合法性
	'参  数：email ----要检查的Email地址
	'返回值：True  ----Email地址合法
	'       False ----Email地址不合法
	'********************************************
	Public Function IsValidEmail(Email)
		Dim names, name, I, c
		IsValidEmail = True
		names = Split(Email, "@")
		If UBound(names) <> 1 Then IsValidEmail = False: Exit Function
		For Each name In names
			If Len(name) <= 0 Then IsValidEmail = False:Exit Function
			For I = 1 To Len(name)
				c = LCase(Mid(name, I, 1))
				If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then IsValidEmail = False:Exit Function
		   Next
		   If Left(name, 1) = "." Or Right(name, 1) = "." Then IsValidEmail = False:Exit Function
		Next
		If InStr(names(1), ".") <= 0 Then IsValidEmail = False:Exit Function
		I = Len(names(1)) - InStrRev(names(1), ".")
		If I <> 2 And I <> 3 Then IsValidEmail = False:Exit Function
		If InStr(Email, "..") > 0 Then IsValidEmail = False
	End Function
	'**************************************************
	'函数名：strLength
	'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
	'参  数：str  ----要求长度的字符串
	'返回值：字符串长度
	'**************************************************
	Public Function strLength(Str)
		On Error Resume Next
		Dim WINNT_CHINESE:WINNT_CHINESE = (Len("中国") = 2)
		If WINNT_CHINESE Then
			Dim l, T, c,I
			l = Len(Str)
			T = l
			For I = 1 To l
				c = Asc(Mid(Str, I, 1))
				If c < 0 Then c = c + 65536
				If c > 255 Then
					T = T + 1
				End If
			Next
			strLength = T
		Else
			strLength = Len(Str)
		End If
		If Err.Number <> 0 Then Err.Clear
	End Function

	'**************************************************
	'函数名: GetFolderPath
	'功 能:取得目录Url
	'参 数: FolderID目录的ID
	'**************************************************
	Public Function GetFolderPath(FolderID)
	        on error resume next
			If Not IsObject(Application(SiteSN&"_classpath")) Then
		     Dim Folder,ClassPurview,ChannelFsoHtmlTF,Node,K,SQL,RS
			 Set  Application(SiteSN&"_classpath")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
		     Application(SiteSN&"_classpath").appendChild( Application(SiteSN&"_classpath").createElement("xml"))
              Set RS=Server.CreateObject("ADODB.RECORDSET")
			  RS.Open "Select C.ClassID,C.ChannelID,TN,Folder,FolderDomain,ClassPurview,FsoHtmlTF,ModelEName,C.ID From KS_Class C inner join KS_Channel M On C.ChannelID=M.ChannelID Order BY FolderOrder", Conn, 1, 1
			  If RS.Eof And RS.Bof Then RS.Close:Set RS=Nothing:Exit Function
			  SQL=RS.GetRows(-1):RS.Close:Set RS=Nothing
			  For K=0 To Ubound(SQL,2)
					       ClassPurview=SQL(5,K)
						   ChannelFsoHtmlTF=SQL(6,K)	
						   If Trim(SQL(4,K)) <> "" And SQL(2,K) = "0" Then
							   IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetFolderPath= GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
							   Else
								 GetFolderPath=Trim(SQL(4,K))
							   End If
						   ElseIf Trim(SQL(4,K)) <> "" Then
							  Folder = Trim(SQL(3,K))
							  Folder = Right(Mid(Folder, InStr(Folder, "/")), Len(Mid(Folder, InStr(Folder, "/"))) - 1)
							  IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetFolderPath= Trim(SQL(4,K)) & GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
							   Else
								 GetFolderPath= Trim(SQL(4,K)) & Folder
							   End If
						  Else
							   IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetFolderPath= GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
							   Else
								 GetFolderPath= GetChannelDomain(SQL(1,K)) & SQL(3,K)
							   End If
						  End If
		            Set Node=Application(SiteSN&"_classpath").documentElement.appendChild(Application(SiteSN&"_classpath").createNode(1,"classpath",""))
			        Node.attributes.setNamedItem(Application(SiteSN&"_classpath").createNode(2,"classid","")).text=SQL(8,K)
			        Node.text=GetFolderPath
               Next			
     End If
	 GetFolderPath=Application(SiteSN&"_classpath").documentElement.selectSingleNode("classpath[@classid=" & FolderID & "]").text
	End Function
		'************************************************************************
		'函数名: GetClassNP
		'功 能: 取得目录名称并加上链接
		'参 数: FolderID目录的ID	          
		'*************************************************************************
		Function GetClassNP(FolderID)
		 on error resume next
		If Not IsObject(Application(SiteSN&"_classnamepath")) Then
		    Dim Folder,ClassPurview,ChannelFsoHtmlTF,Node,K,SQL,RS
		    Dim FolderCss:FolderCss=""
			Dim OpenTypeStr:OpenTypeStr=" target=""_blank"""
			Set  Application(SiteSN&"_classnamepath")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
		    Application(SiteSN&"_classnamepath").appendChild( Application(SiteSN&"_classnamepath").createElement("xml"))
              Set RS=Server.CreateObject("ADODB.RECORDSET")
			  RS.Open "Select C.ClassID,C.ChannelID,FolderName,Folder,FolderDomain,TN,ClassPurview,FolderFsoIndex,FsoHtmlTF,ModelEname,C.ID From KS_Class C inner join KS_Channel M On C.ChannelID=M.ChannelID Order BY FolderOrder", Conn, 1, 1
			  If RS.Eof And RS.Bof Then RS.Close:Set RS=Nothing:Exit Function
			  SQL=RS.GetRows(-1):RS.Close:Set RS=Nothing
			  For K=0 To Ubound(SQL,2)
					 	  ClassPurview=SQL(6,K)
					      ChannelFsoHtmlTF=SQL(8,K)
					      If Trim(SQL(4,K)) <> "" And SQL(5,K) = "0" Then   '判断根目录是否有绑定二级域名
							  IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetClassNP = "<a " & FolderCss & " href=""" & GetChannelNoHtmlUrl(SQL(9,K),SQL(0,K)) & """" & OpenTypeStr & ">"
							   Else
								 GetClassNP = "<a " & FolderCss & " href=""" & Trim(SQL(4,K)) & Trim(SQL(7,K)) & """" & OpenTypeStr & ">"
							   End If
						   ElseIf Trim(SQL(4,K)) <> "" Then
							  Folder = Trim(SQL(3,K))
							  Folder = Right(Mid(Folder, InStr(Folder, "/")), Len(Mid(Folder, InStr(Folder, "/"))) - 1)
							  IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetClassNP = "<a " & FolderCss & " href=""" & Trim(SQL(4,K)) & GetChannelNoHtmlUrl(SQL(9,K),SQL(0,K)) & """" & OpenTypeStr & ">"
							   Else
								  GetClassNP = "<a " & FolderCss & " href=""" & Trim(SQL(4,K)) & Folder & Trim(SQL(7,K)) & """" & OpenTypeStr & ">"
							   End If
						  Else
							   IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
								 GetClassNP = "<a " & FolderCss & " href=""" & GetChannelNoHtmlUrl(SQL(9,K),SQL(0,K)) & """" & OpenTypeStr & ">"
							   Else
								 GetClassNP = "<a " & FolderCss & " href=""" & (GetChannelDomain(CInt(SQL(1,K))) & SQL(3,K) & Trim(SQL(7,K))) & """" & OpenTypeStr & ">"
							   End If
						  End If
					  GetClassNP = GetClassNP & Trim(SQL(2,K)) & "</a>"
		            Set Node=Application(SiteSN&"_classnamepath").documentElement.appendChild(Application(SiteSN&"_classnamepath").createNode(1,"classnamepath",""))
			        Node.attributes.setNamedItem(Application(SiteSN&"_classnamepath").createNode(2,"classid","")).text=SQL(10,K)
			        Node.text=GetClassNP
               Next			
     End If
	GetClassNP=Application(SiteSN&"_classnamepath").documentElement.selectSingleNode("classnamepath[@classid=" & FolderID & "]").text
	End Function
		'----------------------------------------------------------------------------------------------------------------------
		'函数名: GetSpecialPath
		'功 能: 取得专题目录Url
		'参 数: SpecialrRS
		'-----------------------------------------------------------------------------------------------------------------------
		Public Function GetSpecialPath(SpecialID,SpecialEname,FsoSpecialIndex,ChannelID)
		      Dim SpecialDir:SpecialDir = Setting(95)
			  If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
			  If C_S(ChannelID,7)=0 Then
				GetSpecialPath=GetDomain & C_S(ChannelID,10) & "/Special.asp?ID=" & SpecialID
			  Else
				 GetSpecialPath = GetDomain & SpecialDir & SpecialEname & "/" & FsoSpecialIndex
              End iF
		End Function
		'----------------------------------------------------------------------------------------------------------------------
		'函数名: GetFolderSpecialPath
		'功 能: 取得栏目专题汇总Url
		'参 数: FolderID目录的ID,FullPathFlag是否完整路径(取栏目首页与否),包括专题首页
		'-----------------------------------------------------------------------------------------------------------------------
		Function GetFolderSpecialPath(FolderID, FullPathFlag)
		   Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
		   Dim SpecialDir:SpecialDir =Setting(95)
		   If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
		   RS.Open "Select Folder,FolderFsoIndex,ChannelID,id From KS_Class Where ID='" & FolderID & "'", Conn, 1, 1
		   If Not RS.EOF Then
		     If Conn.Execute("Select FsoHtmlTF From KS_Channel Where ChannelID=" & RS("ChannelID"))(0)=0 Then
			     GetFolderSpecialPath = GetDomain &"SpecialList.asp?ClassID="&RS(3)
			 Else
			  If FullPathFlag = True Then
				 GetFolderSpecialPath = GetDomain & SpecialDir & RS(0) & RS(1)
			  Else
				 GetFolderSpecialPath = GetDomain & SpecialDir & RS(0)
			  End If
			 End IF
			  RS.Close:Set RS = Nothing
		   Else
			  RS.Close:Set RS = Nothing:GetFolderSpecialPath = ""
		   End If
		End Function
		'取得栏目的链接URL
		Public Function GetChannelNoHtmlUrl(ModelEname,ClassID)
		     GetChannelNoHtmlUrl=GetDomain & ModelEname & "/ShowClass.asp?ID=" & ClassID
		End Function
		'***************************************************************************
		'函数名: GetInfoUrl
		'功 能: 取得每篇文章、图片等的Url链接
		'参 数: RSObj--信息的recordset对象  
		'调用该函数前先初始化    
		'****************************************************************************
        Public Function GetInfoUrl(ByVal ChannelID,ByVal Tid,ByVal InfoID,ByVal Fname,ByVal ReadPoint,ByVal InfoPurview,ByVal Changes)
		  On error resume next
		  IF Not Isnumeric(ChannelID) Then GetInfoUrl="#":Exit Function
		  Dim ClassPurview:ClassPurview=C_C(Tid,3)
		  Select Case C_S(ChannelID,6)
		   Case 1
				 '当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
				 If Changes=1 Then
				  GetInfoUrl=Fname
				 ElseIf  ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2  Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 2
				 '当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
				 If  ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2  Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 3
				 '当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
				 If  C_S(ChannelID,7)=0 Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 4
				 '当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
				 If  ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2  Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 5
				 '判断是否生成
				 If  C_S(ChannelID,7)=0 Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 7
				 '当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
				 If  ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2  Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		   Case 8
				 If  C_S(ChannelID,7)=0 Then 
				   GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
				 Else
				   GetInfoUrl=GetFolderPath(Tid) & Fname
				 End If
		  End Select
		End Function
		'取消HTML
		Public Function LoseHtml(ContentStr)
		    On Error Resume Next
			Dim TempLoseStr, regEx
			If ContentStr="" Or ContentStr=Null Then Exit Function
			TempLoseStr = CStr(ContentStr)
			Set regEx = New RegExp
			regEx.Pattern = "<\/*[^<>]*>"
			regEx.IgnoreCase = True
			regEx.Global = True
			TempLoseStr = regEx.Replace(TempLoseStr, "")
			LoseHtml = TempLoseStr
		End Function
				                 '---------------------------------------------------------------------------------------------------
		'函数名: G_O_T_S
		'功 能:取得打开类型
		'参 数: OpenType 取true时,新窗口打开
		'--------------------------------------------------------------------------------------------
		Function G_O_T_S(OpenType)
			  If OpenType = "" Or OpenType = False Then
				G_O_T_S = ""
			  ElseIf OpenType = True Then
				G_O_T_S = " target=""_blank"""
			  Else