cls_main.asp

网络上经典的图片程序

		Next
		IsValidStr = True
	End Function
	'================================================
	'函数名：IsValidPassword
	'作  用：判断密码中是否含有非法字符
	'参  数：str   ----原字符串
	'返回值：False,True -----布尔值
	'================================================
	Public Function IsValidPassword(ByVal str)
		IsValidPassword = False
		On Error Resume Next
		If IsNull(str) Then Exit Function
		If Trim(str) = Empty Then Exit Function
		Dim ForbidStr, i
		ForbidStr = "*|^|;|,|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
		ForbidStr = Split(ForbidStr, "|")
		For i = 0 To UBound(ForbidStr)
			If InStr(1, str, ForbidStr(i), 1) > 0 Then
				IsValidPassword = False
				Exit Function
			End If
		Next
		IsValidPassword = True
	End Function
	'================================================
	'函数名：IsValidChar
	'作  用：判断字符串中是否含有非法字符和中文
	'参  数：str   ----原字符串
	'返回值：False,True -----布尔值
	'================================================
	Public Function IsValidChar(ByVal str)
		IsValidChar = False
		On Error Resume Next
		
		If IsNull(str) Then Exit Function
		If Trim(str) = Empty Then Exit Function
		Dim ValidStr
		Dim i, l, s, c
		
		ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789"
		l = Len(str)
		s = UCase(str)
		For i = 1 To l
			c = Mid(s, i, 1)
			If InStr(ValidStr, c) = 0 Then
				IsValidChar = False
				Exit Function
			End If
		Next
		IsValidChar = True
	End Function
	'================================================
	'函数名：FormatDate
	'作  用：格式化日期
	'参  数：DateAndTime   ----原日期和时间
	'        para   ----日期格式
	'返回值：格式化后的日期
	'================================================
	Public Function FormatDate(DateAndTime, para)
		On Error Resume Next
		Dim y, m, d, h, mi, s, strDateTime
		FormatDate = DateAndTime
		If Not IsNumeric(para) Then Exit Function
		If Not IsDate(DateAndTime) Then Exit Function
		y = CStr(Year(DateAndTime))
		m = CStr(Month(DateAndTime))
		If Len(m) = 1 Then m = "0" & m
		d = CStr(Day(DateAndTime))
		If Len(d) = 1 Then d = "0" & d
		h = CStr(Hour(DateAndTime))
		If Len(h) = 1 Then h = "0" & h
		mi = CStr(Minute(DateAndTime))
		If Len(mi) = 1 Then mi = "0" & mi
		s = CStr(Second(DateAndTime))
		If Len(s) = 1 Then s = "0" & s
		Select Case para
		Case "1":strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
		Case "2":strDateTime = y & "-" & m & "-" & d
		Case "3":strDateTime = y & "/" & m & "/" & d
		Case "4":strDateTime = y & "年" & m & "月" & d & "日"
		Case "5":strDateTime = m & "-" & d
		Case "6":strDateTime = m & "/" & d
		Case "7":strDateTime = m & "月" & d & "日"
		Case "8":strDateTime = y & "年" & m & "月"
		Case "9":strDateTime = y & "-" & m
		Case "10":strDateTime = y & "/" & m
		Case Else
			strDateTime = DateAndTime
		End Select
		FormatDate = strDateTime
	End Function
	'================================================
	'函数名：ReadFontMode
	'作  用：读取字体模式
	'参  数：str   ----原字符串
	'        vColor   -----颜色的值
	'        vFont   -----字体的值
	'返回值：新字符串
	'================================================
	Public Function ReadFontMode(str, vColor, vFont)
		Dim FontStr, tColor
		Dim ColorStr, arrColor
		
		If IsNull(str) Then
			ReadFontMode = ""
			Exit Function
		End If
		ReadFontMode = str
		On Error Resume Next
		If Not IsNumeric(vColor) Then Exit Function
		If Not IsNumeric(vFont) Then Exit Function
		
		Select Case CInt(vFont)
			Case 1
				FontStr = "<b>" & str & "</b>"
			Case 2
				FontStr = "<em>" & str & "</em>"
			Case 3
				FontStr = "<u>" & str & "</u>"
			Case 4
				FontStr = "<b><em>" & str & "</em></b>"
			Case 5
				FontStr = "<b><u>" & str & "</u></b>"
			Case 6
				FontStr = "<em><u>" & str & "</u></em>"
			Case 7
				FontStr = "<b><em><u>" & str & "</u></em></b>"
		Case Else
			FontStr = str
		End Select
		ReadFontMode = FontStr
		
		If vColor = "" Or vColor = 0 Then Exit Function
		ColorStr = "," & InitTitleColor
		arrColor = Split(ColorStr, ",")
		If vColor > UBound(arrColor) Then Exit Function
		tColor = Trim(arrColor(vColor))
		ReadFontMode = "<font color=" & tColor & ">" & FontStr & "</font>"
	End Function
	'=============================================================
	'函数名：ShowDateTime
	'作  用：读取日期格式
	'参  数：DateAndTime ---- 当前时间
	'        para ---- 时间格式
	'=============================================================
	Public Function ShowDateTime(DateAndTime, para)
		ShowDateTime = ""
		Dim strDate
		If Not IsDate(DateAndTime) Then Exit Function
		If DateAndTime >= Date Then
			strDate = "<font color='" & Main_Setting(1) & "'>"
			strDate = strDate & FormatDate(DateAndTime, para)
			strDate = strDate & "</font>"
		Else
			strDate = "<font color='" & Main_Setting(2) & "'>"
			strDate = strDate & FormatDate(DateAndTime, para)
			strDate = strDate & "</font>"
		End If
		ShowDateTime = strDate
	End Function
	Public Function ShowDatePath(strval, n)
		ShowDatePath = ""
		If Trim(strval) = "" Then Exit Function
		Dim strTempPath, strTime
		Dim y, m, d
		
		strTime = Left(strval, 8)
		y = Left(strTime, 4)
		m = Mid(strTime, 5, 2)
		d = Right(strTime, 2)
		Select Case CInt(n)
			Case 1
				strTempPath = y & "/" & m & "/" & d & "/"
			Case 2
				strTempPath = y & "/" & m & "/"
			Case 3
				strTempPath = y & m & "/"
			Case 4
				strTempPath = y & "/"
			Case 5
				strTempPath = y & "-" & m & "-" & d & "/"
			Case 6
				strTempPath = y & "-" & m & "/"
			Case 7
				strTempPath = "html/"
			Case 8
				strTempPath = "show/"
		Case Else
			strTempPath = ""
		End Select
		strTempPath = Replace(strTempPath, " ", "")
		ShowDatePath = CStr(strTempPath)
	End Function
	'=============================================================
	'函数名：ReadBriefTopicffd
	'作  用：读取简短标题
	'参  数：para
	'返回值：简短标题
	'=============================================================
	Public Function ReadBriefTopic(ByVal para)
		Dim sBriefTopic
		
		ReadBriefTopic = ""
		If Not IsNumeric(para) Then Exit Function
		If para = 0 Then Exit Function
		Select Case para
		Case "1"
			sBriefTopic = "<font color='blue'>[组图]</font>"
		Case "2"
			sBriefTopic = "<font color='red'>[图文]</font>"
		Case "3"
			sBriefTopic = "<font color='green'>[新闻]</font>"
		Case "4"
			sBriefTopic = "<font color='blue'>[推荐]</font>"
		Case "5"
			sBriefTopic = "<font color='red'>[注意]</font>"
		Case "6"
			sBriefTopic = "<font color='green'>[转载]</font>"
		Case Else
			sBriefTopic = ""
		End Select
		ReadBriefTopic = sBriefTopic
	End Function
	'=============================================================
	'函数名：ReadPicTopic
	'作  用：读取简短标题
	'参  数：para
	'返回值：简短标题
	'=============================================================
	Public Function ReadPicTopic(ByVal para)
		Dim sBriefTopic
		ReadPicTopic = ""
		If Not IsNumeric(para) Then Exit Function
		If para = 0 Then Exit Function
		Select Case para
		Case "1"
			sBriefTopic = "<font color='" & Main_Setting(4) & "'>[组图]</font>"
		Case "2"
			sBriefTopic = "<font color='" & Main_Setting(5) & "'>[图文]</font>"
		Case "3"
			sBriefTopic = "<font color='" & Main_Setting(6) & "'>[新闻]</font>"
		Case "4"
			sBriefTopic = "<font color='" & Main_Setting(4) & "'>[推荐]</font>"
		Case "5"
			sBriefTopic = "<font color='" & Main_Setting(5) & "'>[注意]</font>"
		Case "6"
			sBriefTopic = "<font color='" & Main_Setting(6) & "'>[转载]</font>"
		Case Else
			sBriefTopic = ""
		End Select
		ReadPicTopic = sBriefTopic
	End Function
	'=============================================================
	'函数名：ReadPayMoney
	'作  用：读取要支付的金钱
	'参  数：money   ----实际金钱
	'返回值：加上手续费后的金钱
	'=============================================================
	Public Function ReadPayMoney(ByVal money, ByVal Reduce)
		On Error Resume Next
		If money = 0 Then
			ReadPayMoney = 0
			Exit Function
		End If
		Dim arrChinaeBank, valPercent, Percents
		
		arrChinaeBank = Split(ChinaeBank, "|||")
		Percents = CCur(arrChinaeBank(2) / 100)
		
		If Percents = 0 Then
			ReadPayMoney = CCur(money)
		Else
			If CBool(Reduce) = True Then
				valPercent = Round(CCur(money) / (1 + 1 * Percents), 2)
				ReadPayMoney = CCur(valPercent)
			Else
				valPercent = Round(CCur(money) * Percents, 2)
				ReadPayMoney = CCur(money + valPercent)
			End If
		End If
	End Function
	'=============================================================
	'函数名：RebateMoney
	'作  用：读取打折的后金钱
	'参  数：money   ----实际金钱
	'        Discount   ----折扣
	'=============================================================
	Public Function RebateMoney(ByVal money, ByVal Discount)
		On Error Resume Next
		Dim Rebate
		
		money = CheckNumeric(money)
		Discount = CheckNumeric(Discount)
		If Discount > 0 And Discount < 10 Then
			Rebate = Round(money * (Discount / 10), 2)
			RebateMoney = CCur(Rebate)
		Else
			RebateMoney = CCur(money)
		End If
	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