cls_main.asp

网络上经典的图片程序

	'=============================================================
	'过程名：ReadChannel
	'作  用：读取频道设置
	'参  数：ChannelID   ----频道ID
	'=============================================================
	Public Sub ReadChannel(ChannelID)
		On Error Resume Next
		If Not IsNumeric(ChannelID) Then ChannelID = 1
		ChannelID = Clng(ChannelID)
		Name = "Channel" & ChannelID
		If ObjIsEmpty() Then Call ReloadChannel(ChannelID)
		CacheChannel = Value
		If CLng(CacheChannel(0, 0)) <> ChannelID Then
			Call ReloadChannel(ChannelID)
			CacheChannel = Value
		End If
		ChannelName = CacheChannel(1, 0): ChannelDir = CacheChannel(2, 0): StopChannel = CacheChannel(3, 0): ChannelType = CacheChannel(4, 0): modules = CacheChannel(5, 0): ModuleName = CacheChannel(6, 0): BindDomain = CacheChannel(7, 0): DomainName = CacheChannel(8, 0): ChannelSkin = CacheChannel(9, 0): HtmlPath = CacheChannel(10, 0)
		HtmlForm = CacheChannel(11, 0): IsCreateHtml = CacheChannel(12, 0): HtmlExtName = CacheChannel(13, 0): HtmlPrefix = CacheChannel(14, 0): StopUpload = CacheChannel(15, 0): MaxFileSize = CacheChannel(16, 0): UpFileType = CacheChannel(17, 0): IsAuditing = CacheChannel(18, 0): AppearGrade = CacheChannel(19, 0)
		PostGrade = CacheChannel(20, 0): LeastString = CacheChannel(21, 0): MaxString = CacheChannel(22, 0): PaginalNum = CacheChannel(23, 0): LeastHotHist = CacheChannel(24, 0): Channel_Setting = CacheChannel(25, 0)
		If CInt(StopChannel) = 1 And Not Admin_Page Then Response.Redirect (InstallDir & "showerr.asp?action=ChanStop")
	End Sub
	Public Sub LoadChannel(chanid)
		On Error Resume Next
		Dim Rs,SQL,tmpdata
		chanid = CLng(chanid)
		Name = "MyChannel" & chanid
		If ObjIsEmpty() Then
			SQL = "SELECT ChannelName,ChannelDir,ModuleName,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,LeastString,MaxString,LeastHotHist FROM NC_Channel WHERE ChannelType<=1 And ChannelID= " & Clng(chanid)
			Set Rs = Execute(SQL)
			tmpdata = Rs.GetString(, , "|||", "@@@", "")
			tmpdata = Left(tmpdata, Len(tmpdata) - 3)
			Set Rs = Nothing
			Value = tmpdata
		End If
		
		ChannelData = Split(Value, "|||")
		ChannelPath = InstallDir & ChannelData(1)
		ChannelModule = ChannelData(2)
		ChannelHtmlPath = ChannelData(3)
		ChannelHtmlForm = ChannelData(4)
		ChannelUseHtml = ChannelData(5)
		ChannelHtmlExt = ChannelData(6)
		ChannelPrefix = ChannelData(7)
		
	End Sub
	'=============================================================
	'过程名：LoadTemplates
	'作  用：载入模板
	'参  数：Page_Mark   ----StyleID
	'=============================================================
	Public Sub LoadTemplates(ChannelID, pageid, StyleID)
		Dim rstmp, TempSkinID
		On Error Resume Next
		ChannelID = CLng(ChannelID)
		ThisChannelID = ChannelID
		pageid = CInt(pageid)
		Name = "DefaultSkinID"
		If ObjIsEmpty() Then
			Set rstmp = Execute("SELECT skinid FROM [NC_Template] WHERE pageid=0 And isDefault=1")
			Value = rstmp(0)
			Set rstmp = Nothing
		End If
		TempSkinID = Value
		If StyleID = 0 Or StyleID = "" Then
			skinid = TempSkinID
		Else
			Set rstmp = Execute("SELECT skinid FROM [NC_Template] WHERE pageid=0 And skinid=" & StyleID)
			If Not rstmp.EOF Then
				skinid = rstmp(0)
			Else
				skinid = TempSkinID
			End If
			Set rstmp = Nothing
		End If
		skinid = CLng(skinid)
		Name = "MainStyle" & skinid
		If ObjIsEmpty() Then TemplatesMainCache (skinid)
		Main_Style = Value
		SkinPath = Main_Style(0, 0)
		Main_Setting = Split(Main_Style(2, 0), "|||")
		MainStyle = Main_Style(1, 0)
		'MainStyle = Replace(MainStyle, "{$InstallDir}", ReadInstallDir(BindDomain))
		MainStyle = Replace(MainStyle, "{$SkinPath}", SkinPath)
		MainStyle = Replace(MainStyle, "|||","")
		
		If pageid <> 0 Then
			Name = "Templates" & ChannelID & skinid & pageid
			If ObjIsEmpty() Then
				TemplatesToCache ChannelID, pageid
			End If
			ByValue = Value
		End If
	End Sub
	Private Sub TemplatesToCache(ChannelID, pageid)
		On Error Resume Next
		Dim Rs, SQL, rstmp
		SQL = "SELECT skinid,page_content,page_setting FROM [NC_Template] WHERE ChannelID=" & ChannelID & " And skinid=" & skinid & " And pageid=" & pageid
		Set Rs = Execute(SQL)
		If Not Rs.EOF Then
			Value = Rs.GetRows(1)
			Response.Write Value
		Else
			Set rstmp = Execute("SELECT skinid,page_content,page_setting FROM [NC_Template] WHERE ChannelID=" & ChannelID & " And isDefault=1 And pageid=" & pageid)
			Value = rstmp.GetRows(1)
			Set rstmp = Nothing
		End If
		Set Rs = Nothing
	End Sub
	Private Sub TemplatesMainCache(skinid)
		On Error Resume Next
		Dim Rs, SQL, rstmp
		SQL = "SELECT TemplateDir,page_content,page_setting FROM [NC_Template] WHERE pageid=0 And skinid=" & skinid & " And ChannelID=0"
		Set Rs = Execute(SQL)
		If Not Rs.EOF Then
			Value = Rs.GetRows(1)
		Else
			Set rstmp = Execute("SELECT TemplateDir,page_content,page_setting FROM [NC_Template] WHERE pageid=0 And isDefault=1 And ChannelID=0")
			Value = rstmp.GetRows(1)
			Set rstmp = Nothing
		End If
		Set Rs = Nothing
	End Sub
	Public Property Let ByValue(ByVal vNewValue)
		Dim tmpstr
		tmpstr = vNewValue
		Html_Setting = tmpstr(2, 0)
		Html_Setting = Split(Html_Setting, "|||")
		HtmlContent = tmpstr(1, 0)
		
		HtmlContent = TemplateCustom(HtmlContent)
		HtmlContent = Replace(HtmlContent, "{$Style_CSS}", MainStyle)
		HtmlContent = Replace(HtmlContent, "{$SkinPath}", SkinPath)
		HtmlContent = Replace(HtmlContent, "{$Width}", Main_Setting(0))
		HtmlContent = Replace(HtmlContent, "{$ChannelMenu}", ChannelMenu)
		HtmlContent = Replace(HtmlContent, "{$WebSiteName}", SiteName)
		HtmlContent = Replace(HtmlContent, "{$WebSiteUrl}", SiteUrl)
		HtmlContent = Replace(HtmlContent, "{$MasterMail}", MasterMail)
		HtmlContent = Replace(HtmlContent, "{$Keyword}", keywords)
		HtmlContent = Replace(HtmlContent, "{$Copyright}", Copyright)
		HtmlContent = Replace(HtmlContent, "{$IndexName}", IndexName)
		HtmlContent = Replace(HtmlContent, "{$Version}", Version)
		HtmlContent = HtmlContent
	End Property
	Public Property Get ByValue()
		ByValue = HtmlContent
	End Property
	Public Property Let HTMLValue(ByVal vNewValue)
		Dim TempStr
		TempStr = TemplateCustom(vNewValue)
		TempStr = Replace(TempStr, "{$Style_CSS}", MainStyle)
		TempStr = Replace(TempStr, "{$SkinPath}", SkinPath)
		TempStr = Replace(TempStr, "{$Width}", Main_Setting(0))
		TempStr = Replace(TempStr, "{$ChannelMenu}", ChannelMenu)
		TempStr = Replace(TempStr, "{$WebSiteName}", SiteName)
		TempStr = Replace(TempStr, "{$WebSiteUrl}", SiteUrl)
		TempStr = Replace(TempStr, "{$MasterMail}", MasterMail)
		TempStr = Replace(TempStr, "{$Keyword}", keywords)
		TempStr = Replace(TempStr, "{$Copyright}", Copyright)
		TempStr = Replace(TempStr, "{$IndexName}", IndexName)
		TempStr = Replace(TempStr, "{$Version}", Version)
		sHtmlContent = TempStr
	End Property
	Public Property Get HTMLValue()
		HTMLValue = sHtmlContent
	End Property
	Public Property Get HtmlSetting(n)
		HtmlSetting = Html_Setting(n)
	End Property
	Public Property Get MainSetting(n)
		MainSetting = Main_Setting(n)
	End Property
	Public Function TemplateCustom(ByVal strHTML)
		Dim Custom,strContent
		strContent = strHTML
		Set Custom = New LabelCustom_Cls
		Custom.Template = strContent
		Custom.Channel = ThisChannelID
		Custom.Execute
		strContent = Custom.Template
		Set Custom = Nothing
		TemplateCustom = strContent
	End Function
	'================================================
	'过程名：GetSiteUrl
	'作  用：取得带端口的URL
	'================================================
	Public Property Get GetSiteUrl()
		If Request.ServerVariables("SERVER_PORT") = "80" Then
			GetSiteUrl = "http://" & Request.ServerVariables("server_name")
		Else
			GetSiteUrl = "http://" & Request.ServerVariables("server_name") & ":" & Request.ServerVariables("SERVER_PORT")
		End If
	End Property
	'================================================
	'函数名：FormEncode
	'作  用：过虑提交的表单数据
	'参  数：str ----原字符串  n ----字符长度
	'================================================
	Public Function FormEncode(ByVal str, ByVal n)
		If Not IsNull(str) And Trim(str) <> "" Then
			str = Left(str, n)
			str = Replace(str, ">", "&gt;")
			str = Replace(str, "<", "&lt;")
			str = Replace(str, "&#62;", "&gt;")
			str = Replace(str, "&#60;", "&lt;")
			str = Replace(str, "'", "&#39;")
			str = Replace(str, Chr(34), "&quot;")
			str = Replace(str, "%", "％")
			str = Replace(str, vbNewLine, "")
			FormEncode = Trim(str)
		Else
			FormEncode = ""
		End If
	End Function
	'================================================
	'函数名：ChkKeyWord
	'作  用：过滤关键字
	'参  数：keyword ----关键字
	'================================================
	Public Function ChkKeyWord(ByVal keyword)
		Dim FobWords, i
		On Error Resume Next
		FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65339, 65340)
		For i = 1 To UBound(FobWords, 1)
			If InStr(keyword, ChrW(FobWords(i))) > 0 Then
				keyword = Replace(keyword, ChrW(FobWords(i)), "")
			End If
		Next
		keyword = Left(keyword, 100)
		FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", ",", "<", ">", ".", "/", "\", "?", "_")
		For i = 0 To UBound(FobWords, 1)
			If InStr(keyword, FobWords(i)) > 0 Then
				keyword = Replace(keyword, FobWords(i), "")
			End If
		Next
		ChkKeyWord = keyword
	End Function
	'================================================
	'函数名：JAPEncode
	'作  用：日文片假名编码
	'参  数：str ----原字符
	'================================================
	Public Function JAPEncode(ByVal str)
		Dim FobWords, i
		On Error Resume Next
		If IsNull(str) Or Trim(str) = "" Then
			JAPEncode = ""
			Exit Function
		End If
		FobWords = Array(92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65340)
		For i = 1 To UBound(FobWords, 1)
			If InStr(str, ChrW(FobWords(i))) > 0 Then
				str = Replace(str, ChrW(FobWords(i)), "&#" & FobWords(i) & ";")
			End If
		Next
		JAPEncode = str
	End Function
	'================================================
	'函数名：JAPUncode
	'作  用：日文片假名解码
	'参  数：str ----原字符
	'================================================
	Public Function JAPUncode(ByVal str)
		Dim FobWords, i
		On Error Resume Next
		If IsNull(str) Or Trim(str) = "" Then
			JAPUncode = ""
			Exit Function
		End If
		FobWords = Array(92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65340)
		For i = 1 To UBound(FobWords, 1)
			If InStr(str, "&#" & FobWords(i) & ";") > 0 Then
				str = Replace(str, "&#" & FobWords(i) & ";", ChrW(FobWords(i)))
			End If
		Next
		str = Replace(str, Chr(0), "")
		str = Replace(str, "'", "''")
		JAPUncode = str
	End Function
	'=============================================================
	'函数作用：带脏话过滤
	'=============================================================
	Public Function ChkBadWords(ByVal str)
		If IsNull(str) Then Exit Function
		Dim i, Bwords, Bwordr
		Bwords = Split(Badwords, "|")
		Bwordr = Split(Badwordr, "|")
		For i = 0 To UBound(Bwords)
			If i > UBound(Bwordr) Then
				str = Replace(str, Bwords(i), "*")
			Else
				str = Replace(str, Bwords(i), Bwordr(i))
			End If
		Next
		ChkBadWords = str
	End Function
	'=============================================================
	'函数作用：过滤HTML代码，带脏话过滤
	'=============================================================
	Public Function HTMLEncode(ByVal fString)
		If Not IsNull(fString) Then
			fString = Replace(fString, ">", "&gt;")
			fString = Replace(fString, "<", "&lt;")
			fString = Replace(fString, Chr(32), " ")
			fString = Replace(fString, Chr(9), " ")
			fString = Replace(fString, Chr(34), "&quot;")
			fString = Replace(fString, Chr(39), "&#39;")
			fString = Replace(fString, Chr(13), "")
			fString = Replace(fString, " ", "&nbsp;")
			fString = Replace(fString, Chr(10), "<br /> ")
			fString = ChkBadWords(fString)
			HTMLEncode = fString
		End If
	End Function
	'=============================================================
	'函数作用：过滤HTML代码，不带脏话过滤
	'=============================================================
	Public Function HTMLEncodes(ByVal fString)
		If Not IsNull(fString) Then
			fString = Replace(fString, "'", "&#39;")
			fString = Replace(fString, ">", "&gt;")
			fString = Replace(fString, "<", "&lt;")
			fString = Replace(fString, Chr(32), " ")
			fString = Replace(fString, Chr(9), " ")
			fString = Replace(fString, Chr(34), "&quot;")
			fString = Replace(fString, Chr(39), "&#39;")
			fString = Replace(fString, Chr(13), "")
			fString = Replace(fString, Chr(10), "<br /> ")
			fString = Replace(fString, " ", "&nbsp;")
			HTMLEncodes = fString
		End If
	End Function
	'=============================================================
	'函数作用：判断发言是否来自外部
	'=============================================================
	Public Function CheckPost()
		On Error Resume Next
		Dim server_v1, server_v2
		CheckPost = False
		server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
		server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
		If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then
			CheckPost = True
		End If
	End Function
	'=============================================================
	'函数作用：判断来源URL是否来自外部
	'=============================================================
	Public Function CheckOuterUrl()
		On Error Resume Next
		Dim server_v1, server_v2
		server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
		server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
		If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
			CheckOuterUrl = False
		Else
			CheckOuterUrl = True
		End If
	End Function
	'================================================
	'函数名：GotTopic
	'作  用：显示字符串长度