cls_main.asp

网络上经典的图片程序

			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 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 Function GetRandomCode()
		Dim Ran, i, LengthNum
		
		LengthNum = 16
		GetRandomCode = ""
		For i = 1 To LengthNum
			Randomize
			Ran = CInt(Rnd * 2)
			Randomize
			If Ran = 0 Then
				Ran = CInt(Rnd * 25) + 97
				GetRandomCode = GetRandomCode & UCase(Chr(Ran))
			ElseIf Ran = 1 Then
				Ran = CInt(Rnd * 9)
				GetRandomCode = GetRandomCode & Ran
			ElseIf Ran = 2 Then
				Ran = CInt(Rnd * 25) + 97
				GetRandomCode = GetRandomCode & Chr(Ran)
			End If
		Next
	End Function
	'================================================
	' 函数名：CodeIsTrue
	' 作  用：检查验证码是否正确
	'================================================
	Public Function CodeIsTrue()
	    Dim CodeStr
	    CodeStr = Trim(Request("CodeStr"))
	    On Error Resume Next
	    If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
		CodeIsTrue = True
		Session("GetCode") = Empty
	    Else
		CodeIsTrue = False
		Session("GetCode") = Empty
	    End If
	End Function
	Public Function CheckAdmin(ByVal Flag)
		Dim Rs, SQL
		Dim i, TempAdmin, AdminFlag, AdminGrade
		
		CheckAdmin = False
		On Error Resume Next
		SQL = "SELECT AdminGrade,Adminflag FROM NC_Admin WHERE username='" & Replace(Session("AdminName"), "'", "''") & "' And password='" & Replace(Session("AdminPass"), "'", "''") & "' And isLock=0 And id=" & CLng(Session("AdminID"))
		Set Rs = Execute(SQL)
		If Rs.BOF And Rs.EOF Then
			CheckAdmin = False
			Set Rs = Nothing
			Exit Function
		Else
			AdminFlag = Rs("Adminflag")
			AdminGrade = Rs("AdminGrade")
		End If
		Rs.Close: Set Rs = Nothing
		If CInt(AdminGrade) = 999 Then
			CheckAdmin = True
			Exit Function
		Else
			If Trim(Flag) = "" Then Exit Function
			If AdminFlag = "" Then
				CheckAdmin = False
				Exit Function
			Else
				TempAdmin = Split(AdminFlag, ",")
				For i = 0 To UBound(TempAdmin)
					If Trim(LCase(TempAdmin(i))) = Trim(LCase(Flag)) Then
						CheckAdmin = True
						Exit For
					End If
				Next
			End If
		End