cls_main.asp

采用的是新云内核

	End Function
	'================================================
	'函数名：Supplemental
	'作  用：补足参数
	'参  数：para ----原参数
	'        n ----增补的位数
	'================================================
	Public Function Supplemental(para, n)
		Supplemental = ""
		If Not IsNumeric(para) Then Exit Function
		If Len(para) < n Then
			Supplemental = String(n - Len(para), "0") & para
		Else
			Supplemental = para
		End If
	End Function
	'-----------------------------------------------------------------
	Public Function GetChannelDir(ByVal chanid)
		On Error Resume Next
		If Not IsNumeric(chanid) Then chanid = 1
		Name = "Channel" & chanid
		If ObjIsEmpty() Then ReloadChannel (chanid)
		CacheChannel = Value
		GetChannelDir = InstallDir & CacheChannel(2,0)
	End Function
	
	'================================================
	'函数名：GetImageUrl
	'作  用：获取图片URL
	'================================================
	Public Function GetImageUrl(ByVal url, ByVal ChannelDir)
		On Error Resume Next
		Dim strTempUrl, strImageUrl
		
		If Not IsNull(url) And Trim(url) <> "" And LCase(url) <> "http://" Then
			strTempUrl = InstallDir & ChannelDir
			If CheckUrl(url) = 1 Then
				strImageUrl = Trim(url)
			ElseIf CheckUrl(url) = 2 Then
				strImageUrl = url
			Else
				strImageUrl = Replace(url, "../", "")
				strImageUrl = Trim(strTempUrl & strImageUrl)
			End If
		Else
			strImageUrl = InstallDir & "images/no_pic.gif"
		End If
		GetImageUrl = strImageUrl
	End Function
	'-----------------------------------------------------------------
	'================================================
	'作  用：读取图片或者FLASH
	'参  数：url ----文件URL
	'        height ----高度
	'        width ----宽度
	'================================================
	Function GetFlashAndPic(ByVal url, ByVal height, ByVal width)
		On Error Resume Next
		Dim sExtName, ExtName, strTemp
		Dim strHeight, strWidth
		
		If Not IsNumeric(height) Or height < 1 Then
			strHeight = ""
		Else
			strHeight = " height=" & height
		End If
		If Not IsNumeric(width) Or width < 1 Then
			strWidth = ""
		Else
			strWidth = " width=" & width
		End If
		sExtName = Split(url, ".")
		ExtName = sExtName(UBound(sExtName))
		If LCase(ExtName) = "swf" Then
			strTemp = "<embed src=""" & url & """" & strWidth & strHeight & ">"
		Else
			strTemp = "<img src=""" & url & """" & strWidth & strHeight & " border=0>"
		End If
		GetFlashAndPic = strTemp
	End Function
	'================================================
	'函数名：ReadFileUrl
	'作  用：读取文件URL
	'================================================
	Public Function ReadFileUrl(url)
		On Error Resume Next
		ReadFileUrl = ""
		If url = "" Then Exit Function
		Dim strTemp
		If CheckUrl(url) = 1 Then
			strTemp = Trim(url)
		ElseIf CheckUrl(url) = 2 Then
			strTemp = Trim(url)
		Else
			strTemp = Replace(url, "../", "")
			strTemp = Trim(InstallDir & strTemp)
		End If
		ReadFileUrl = strTemp
	End Function
	Public Function CheckUrl(ByVal url)
		Dim strUrl
		If Left(url, 1) = "/" Then
			CheckUrl = 1
			Exit Function
		End If
		strUrl = LCase(Left(url, 6))
		Select Case Trim(strUrl)
		Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
			CheckUrl = 2
			Exit Function
		Case Else
			CheckUrl = 0
		End Select
	End Function
	'================================================
	'函数名：ReadFileName
	'作  用：读取HTML文件名
	'参  数：strname ----文件名称
	'        id ----数据ID
	'        ExtName ----HTML扩展名
	'        PrefixStr ----HTML名称前缀
	'        HtmlForm ----HTML文件格式
	'        n ----HTML分页
	'================================================
	Public Function ReadFileName(ByVal strname, ByVal id, ByVal ExtName, ByVal PrefixStr, ByVal HtmlForm, ByVal n)
		
		Dim strFileName, strExtName, CurrentPage
		If Trim(strname) = "" Then Exit Function
		If Trim(ExtName) = "" Then ExtName = ".html"
		If Not IsNumeric(n) Then n = 0
		On Error Resume Next
		If CInt(n) <= 1 Then
			CurrentPage = ""
		Else
			CurrentPage = "_" & n
		End If
		If Left(ExtName, 1) <> "." Then
			strExtName = "." & Trim(ExtName)
		Else
			strExtName = Trim(ExtName)
		End If
		Select Case Trim(HtmlForm)
			Case "1"
				strFileName = Trim(id)
			Case "2"
				strFileName = Trim(PrefixStr) & Trim(Supplemental(id, 3))
			Case "3"
				strFileName = Left(strname, 8)
				strFileName = strFileName & Trim(Supplemental(id, 3))
			Case "4"
				strFileName = Right(strname, 7)
				strFileName = strFileName & Trim(Supplemental(id, 3))
			Case Else
				strFileName = strname
		End Select
		strFileName = Replace(strFileName & CurrentPage & strExtName, " ", "")
		ReadFileName = CStr(strFileName)
	End Function
	'================================================
	'过程名：HtmlRndFileName
	'作  用：取HTML的随机文件名
	'================================================
	Function HtmlRndFileName()
		Dim sRnd
		Randomize
		sRnd = Int(90 * Rnd) + 10
		HtmlRndFileName = Replace(Replace(Replace(FormatDate(Now(), 1), "-", ""), ":", ""), " ", "") & sRnd
	End Function
	'================================================
	'函数名：ClassFileName
	'作  用：读取HTML文件列表名
	'参  数：ClassID ----分类ID
	'================================================
	Public Function ClassFileName(ByVal ClassID, ByVal ExtName, ByVal PrefixStr, ByVal n)
		Dim strFileName, strExtName, strClassID
		
		If Trim(ExtName) = "" Then ExtName = ".html"
		If Not IsNumeric(n) Then n = 0
		If Left(ExtName, 1) <> "." Then
			strExtName = "." & Trim(ExtName)
		Else
			strExtName = Trim(ExtName)
		End If
		If CInt(n) <= 1 Then
			strFileName = "index" & strExtName
		Else
			strClassID = Supplemental(ClassID, 3)
			strFileName = PrefixStr & strClassID & "_" & n & strExtName
		End If
		strFileName = Replace(strFileName, " ", "")
		ClassFileName = CStr(strFileName)
	End Function
	'================================================
	'函数名：SpecialFileName
	'作  用：读取专题HTML文件名
	'参  数：specid ----专题ID
	'================================================
	Public Function SpecialFileName(ByVal specid, ByVal ExtName, ByVal n)
		Dim strFileName, strExtName, strSpecialID
		
		If Trim(ExtName) = "" Then ExtName = ".html"
		If Not IsNumeric(n) Then n = 0
		If Left(ExtName, 1) <> "." Then
			strExtName = "." & Trim(ExtName)
		Else
			strExtName = Trim(ExtName)
		End If
		If CInt(n) <= 1 Then
			strFileName = "index" & strExtName
		Else
			strSpecialID = Supplemental(specid, 3)
			strFileName = "Special" & strSpecialID & "_" & n & strExtName
		End If
		strFileName = Replace(strFileName, " ", "")
		SpecialFileName = CStr(strFileName)
	End Function
	'================================================
	'函数名：ChannelMenu
	'作  用：显示频道菜单
	'================================================
	Public Function ChannelMenu()
		Dim SQL, Rs, i, TotalNumber,strTop
		Dim strContent, LinkTarget, ChannelName
		Dim ChannelUrl, HtmlContent, sCaption
		
		
		Name = "ChannelMenu"
		If ObjIsEmpty() Then
			If ChkNumeric(Main_Setting(7)) = 0 Then
				strTop = vbNullString
			Else
				strTop = "TOP " & CInt(Main_Setting(7))
			End If
			SQL = "SELECT " & strTop & " ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl,IsHidden FROM [NC_Channel] WHERE ChannelID<>3 And IsHidden=0 Order By orders"
			Set Rs = Execute(SQL)
			If Rs.BOF And Rs.EOF Then
				strContent = ""
			Else
			i = 0
			TotalNumber = Rs.RecordCount
			Do While Not Rs.EOF
				i = i + 1
				If Rs("LinkTarget") <> 0 Then
					LinkTarget = " target=""_blank"""
				Else
					LinkTarget = ""
				End If
				HtmlContent = HtmlContent & Main_Setting(9)
				ChannelName = ReadFontMode(Rs("ChannelName"), Rs("ColorModes"), Rs("FontModes"))
				If Rs("ChannelType") < 2 Then
					ChannelUrl = InstallDir & Rs("ChannelDir")
				Else
					ChannelUrl = Rs("ChannelUrl")
				End If
				If Rs("StopChannel") <> 0 Then
					sCaption = "此频道暂时关闭,不能访问！"
				Else
					sCaption = Rs("Caption")
				End If
				strContent = "<a href=""" & ChannelUrl & """" & LinkTarget & " title=""" & sCaption & """ class=navmenu>" & ChannelName & "</a>"
				If i Mod CInt(Main_Setting(8)) = 0 Then strContent = strContent & "<br>"
				HtmlContent = Replace(HtmlContent, "{$ChannelMenu}", strContent)	
			Rs.MoveNext
			Loop
			End If
			Rs.Close: Set Rs = Nothing
			'Value = strContent
		End If
		'strContent = Value
		
		ChannelMenu = HtmlContent
	End Function
	'=============================================================
	'函数名：LoadSelectClass
	'作  用：载入缓存下拉分类列表
	'参  数：ChannelID   ----频道ID
	'返回值：下拉分类列表
	'=============================================================
	Public Function LoadSelectClass(ChannelID)
		Dim CacheSelClass, SQL, Rs1, i
		
		Name = "SelectClass" & ChannelID
		If ObjIsEmpty() Then
			SQL = "select ClassID,ClassName,depth,TurnLink,child from NC_Classify where ChannelID = " & ChannelID & " order by rootid,orders"
			Set Rs1 = Execute(SQL)
			If Rs1.BOF And Rs1.EOF Then
				CacheSelClass = CacheSelClass & "<option>没有添加分类</option>"
			End If
			Do While Not Rs1.EOF
				If Rs1("TurnLink") <> 0 Then
					CacheSelClass = CacheSelClass & "<option value=""0"""
				Else
					If Rs1("depth") = 0 And Rs1("child") <> 0 Then
						CacheSelClass = CacheSelClass & "<option"
					Else
						CacheSelClass = CacheSelClass & "<option value=""" & Rs1("ClassID") & """"
					End If
				End If
				CacheSelClass = CacheSelClass & " {ClassID=" & Rs1("ClassID") & "}>"
				If Rs1("depth") = 1 Then CacheSelClass = CacheSelClass & "　├ "
				If Rs1("depth") > 1 Then
					For i = 2 To Rs1("depth")
						CacheSelClass = CacheSelClass & "　"
					Next
					CacheSelClass = CacheSelClass & "　├ "
				End If
				CacheSelClass = CacheSelClass & Rs1("ClassName") & "</option>" & vbCrLf
				Rs1.MoveNext
			Loop
			Rs1.Close
			Set Rs1 = Nothing
			Value = CacheSelClass
		End If
		LoadSelectClass = Value
	End Function
	Public Function ClassJumpMenu(ChannelID)
		Dim CacheJumpMenu
		Dim Rs1
		Dim i
		Name = "ClassJumpMenu" & ChannelID
		If ObjIsEmpty() Then
			Set Rs1 = Execute("select ClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrl from [NC_Classify] where ChannelID = " & ChannelID & " order by rootid,orders")
			Do While Not Rs1.EOF
				If Rs1("TurnLink") <> 0 Then
					CacheJumpMenu = CacheJumpMenu & "<option value=""" & Rs1("TurnLinkUrl") & """ {ClassID=" & Rs1("classid") & "}"
				Else
					CacheJumpMenu = CacheJumpMenu & "<option value=""?ChannelID=" & Rs1("ChannelID") & "&sortid=" & Rs1("classid") & """ {ClassID=" & Rs1("classid") & "}"
				End If
				If Trim(Request("sortid")) <> "" Then
					If CLng(Request("sortid")) = Rs1("classid") Then CacheJumpMenu = CacheJumpMenu & " selected"
				End If
				CacheJumpMenu = CacheJumpMenu & ">"
				If Rs1("depth") = 1 Then CacheJumpMenu = CacheJumpMenu & "　├ "
				If Rs1("depth") > 1 Then
					For i = 2 To Rs1("depth")
						CacheJumpMenu = CacheJumpMenu & "　"
					Next
					CacheJumpMenu = CacheJumpMenu & "　├ "
				End If
				CacheJumpMenu = CacheJumpMenu & Rs1("ClassName") & "</option>" & vbCrLf
				Rs1.MoveNext
			Loop
			Rs1.Close
			Set Rs1 = Nothing
			Value = CacheJumpMenu
		End If
		ClassJumpMenu = Value
	End Function
	'================================================
	'函数名：GetRandomCode
	'作  用：系统分配随机代码
	'================================================
	Public