newschannel.asp

网络上经典的图片程序

<%
Dim NewCloud
Set NewCloud = New NewsChannel_Cls

Class NewsChannel_Cls
	Private ChannelID, CreateHtml, keyword
	Private Rs, SQL, ChannelRootDir, HtmlContent, strIndexName
	Private ArticleID, ArticleContent, skinid, ClassID
	Private maxperpage, TotalNumber, TotalPageNum, CurrentPage, i, totalrec
	Private strFileDir, ParentID, strParent, strClassName, ChildStr, Child
	Private ListContent, TempListContent, HtmlTemplate, HtmlFilePath
	Private SpecialID, SpecialName, SpecialDir, PageType, ForbidEssay, strInstallDir
	Private IsShowFlush, j, UserArticle,maxstrlen
	Private FoundErr,strlen

	Private Sub Class_Initialize()
		On Error Resume Next
		FoundErr = False
		UserArticle = False
		ChannelID = 1
		IsShowFlush = 0
		strlen = 0
	End Sub
	Private Sub Class_Terminate()
		'Set HTML = Nothing
	End Sub
	Public Property Let Channel(chanid)
		ChannelID = chanid
	End Property
	Public Property Let ShowFlush(para)
		IsShowFlush = para
	End Property
	Public Sub ChannelMain()
		Newasp.ReadChannel (ChannelID)
		CreateHtml = CInt(Newasp.IsCreateHtml)
		ChannelRootDir = Newasp.InstallDir & Newasp.ChannelDir
		strInstallDir = Newasp.InstallDir
		strIndexName = "<a href='" & ChannelRootDir & "'>" & Newasp.ChannelName & "</a>"
	End Sub
	'#############################\\执行文章首页开始//#############################
	'=================================================
	'过程名：ShowArticleIndex
	'作  用：显示文章首页
	'=================================================
	Public Sub ShowArticleIndex()
		On Error Resume Next
		LoadArticleIndex
		If CreateHtml <> 0 Then
			Response.Write "<meta http-equiv=refresh content=0;url=index" & Newasp.HtmlExtName & ">"
		Else
			Response.Write HtmlContent
		End If
	End Sub
	'=================================================
	'过程名：CreateArticleIndex
	'作  用：生成文章首页的HTML
	'=================================================
	Public Sub CreateArticleIndex()
		On Error Resume Next
		LoadArticleIndex
		Dim FilePath
		FilePath = Newasp.InstallDir & Newasp.ChannelDir & "index" & Newasp.HtmlExtName
		Newasp.CreatedTextFile FilePath, HtmlContent
		If IsShowFlush = 1 Then Response.Write "<li style=""font-size: 12px;"">生成" & Newasp.ModuleName & "首页HTML完成... <a href=" & FilePath & " target=_blank>" & Server.MapPath(FilePath) & "</a></li>" & vbNewLine
		Response.Flush
	End Sub
	'=================================================
	'过程名：LoadArticleIndex
	'作  用：装载文章首页
	'=================================================
	Private Sub LoadArticleIndex()
		On Error Resume Next

		Newasp.LoadTemplates ChannelID, 1, Newasp.ChannelSkin
		HtmlContent = Newasp.HtmlContent
		HtmlContent = Replace(HtmlContent, "{$ChannelRootDir}", ChannelRootDir)
		HtmlContent = Replace(HtmlContent, "{$InstallDir}", strInstallDir)
		HtmlContent = Replace(HtmlContent, "{$ChannelID}", ChannelID)
		If Len(Newasp.HtmlSetting(1)) < 2 Then
			HtmlContent = Replace(HtmlContent, "{$PageTitle}", Newasp.ChannelName)
		Else
			HtmlContent = Replace(HtmlContent, "{$PageTitle}", Newasp.ChannelName & Newasp.HtmlSetting(1))
		End If
		HtmlContent = Replace(HtmlContent, "{$ChannelName}", Newasp.ChannelName)
		HtmlContent = Replace(HtmlContent, "{$ModuleName}", Newasp.ModuleName)
		HtmlContent = Replace(HtmlContent, "{$ArticleIndex}", strIndexName)
		HtmlContent = HTML.ReadAnnounceContent(HtmlContent, ChannelID)
		HtmlContent = ReadClassMenu(HtmlContent)
		HtmlContent = ReadClassMenubar(HtmlContent)
		HtmlContent = HTML.ReadArticlePic(HtmlContent)
		HtmlContent = HTML.ReadSoftPic(HtmlContent)
		HtmlContent = HTML.ReadArticleList(HtmlContent)
		HtmlContent = HTML.ReadSoftList(HtmlContent)
		HtmlContent = HTML.ReadFlashList(HtmlContent)
		HtmlContent = HTML.ReadFlashPic(HtmlContent)
		HtmlContent = HTML.ReadFriendLink(HtmlContent)
		HtmlContent = HTML.ReadNewsPicAndText(HtmlContent)
		HtmlContent = HTML.ReadSoftPicAndText(HtmlContent)
		HtmlContent = HTML.ReadGuestList(HtmlContent)
		HtmlContent = HTML.ReadAnnounceList(HtmlContent)
		HtmlContent = HTML.ReadPopularArticle(HtmlContent)
		HtmlContent = HTML.ReadPopularSoft(HtmlContent)
		HtmlContent = HTML.ReadPopularFlash(HtmlContent)
		HtmlContent = HTML.ReadSoftType(HtmlContent)
		HtmlContent = HTML.ReadStatistic(HtmlContent)
		HtmlContent = HTML.ReadUserRank(HtmlContent)
		HtmlContent = Replace(HtmlContent, "{$SkinPath}", Newasp.SkinPath)
		HtmlContent = Replace(HtmlContent, "{$InstallDir}", strInstallDir)
		HtmlContent = Replace(HtmlContent, "{$ChannelID}", ChannelID)
		HtmlContent = HtmlContent
	End Sub
	'##############################################################################
	'#############################\\执行文章内容开始//#############################
	'=================================================
	'过程名：ShowArticleInfo
	'作  用：显示文章内容页面
	'=================================================
	Public Sub ShowArticleInfo()
		If CreateHtml <> 0 Then
			Response.Redirect (ChannelRootDir & "index" & Newasp.HtmlExtName)
			Exit Sub
		Else
			Newasp.PreventInfuse
			ArticleID = Newasp.ChkNumeric(Request("id"))
			CurrentPage = Newasp.ChkNumeric(Request("Page"))
			Response.Write ReadArticleContent(ArticleID, CurrentPage)
		End If
	End Sub

	Private Function CheckUserRead(ByVal ArticleID, ByVal PointNum, ByVal UserGroup, ByVal User_Group)
		Dim Message, CookiesID
		Dim GroupSetting, GroupName, gradeid
		
		If CInt(Newasp.membergrade) = 999 Then Exit Function
		If CInt(Newasp.membergrade) <> 0 Then
			gradeid = CInt(Newasp.membergrade)
		Else
			gradeid = 0
		End If
		GroupSetting = Split(Newasp.UserGroupSetting(gradeid), "|||")
		GroupName = GroupSetting(UBound(GroupSetting))
		If CInt(User_Group) > CInt(gradeid) Or CInt(UserGroup) > CInt(gradeid) Then
			Message = "<li>您没有登录或者你的会员级别不够，不能阅览此文章！</li><li>如果你是本站会员, 请先<a href=""../user/"">登陆</a></li>"
			Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
			Response.end
		End If
		On Error Resume Next
		Dim rsMember
		If CInt(Newasp.memberclass) > 0 Then
			Set rsMember = CreateObject("ADODB.Recordset")
			SQL = "SELECT userid,UserGrade,UserClass,ExpireTime FROM NC_User WHERE UserClass>0 And username='" & Newasp.membername & "' And userid=" & CLng(Newasp.memberid)
			rsMember.Open SQL, Conn, 1, 3
			If rsMember.BOF And rsMember.EOF Then
				Message = "<li>非法操作~！</li>"
				Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
				Set rsMember = Nothing
				Response.end
			Else
				If DateDiff("D", CDate(rsMember("ExpireTime")), Now()) > 0 Or CInt(rsMember("UserClass")) = 999 Then
					Message = "<li>对不起！您的会员已到期，不能阅览此文章；</li><li>如果你要阅览此文章请联系管理员。</li>"
					Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
					Set rsMember = Nothing
					Response.end
				Else
					Set rsMember = Nothing
					Exit Function
				End If
			End If
			rsMember.Close: Set rsMember = Nothing
			Exit Function
		End If
		CookiesID = "ArticleID_" & ArticleID
		If Trim(Request.Cookies("ReadArticle")) = "" Then
			Response.Cookies("ReadArticle")("userip") = Newasp.GetUserip
			Response.Cookies("ReadArticle").Expires = Date + 1
		End If
		
		If CLng(Request.Cookies("ReadArticle")(CookiesID)) <> CLng(ArticleID) And CInt(UserGroup) > 0 Then
			Set rsMember = CreateObject("ADODB.Recordset")
			SQL = "SELECT userid,UserGrade,userpoint,ExpireTime FROM NC_User WHERE username='" & Newasp.membername & "' And userid=" & CLng(Newasp.memberid)
			rsMember.Open SQL, Conn, 1, 3
			If rsMember.BOF And rsMember.EOF Then
				Message = "<li>非法操作~！</li>"
				Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
				Set rsMember = Nothing
				Response.end
			Else
				If CInt(rsMember("UserGrade")) < CInt(UserGroup) Then
					Message = "<li>您的级别不够，阅览此文章需要<font color=blue>" & GroupName & "</font>以上级别的会员；</li><li>如果你要阅览此文章请联系管理员。</li>"
					Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
					Set rsMember = Nothing
					Response.end
				End If
				
				If CLng(rsMember("userpoint")) < CLng(PointNum) Then
					Message = "<li>对不起!您的点数不足。不能阅览此文章</li><li>阅览此文章所需的点数：" & PointNum & "</li><li>如果你确实要阅览此文章请到<a href=""../user/"">会员中心</a>充值。</li>"
					Response.Redirect (strInstallDir & "showerr.asp?action=error&Message=" & Server.URLEncode(Message))
					Set rsMember = Nothing
					Response.end
				End If
				rsMember("userpoint") = CLng(rsMember("userpoint") - PointNum)
				rsMember.Update
				Response.Cookies("ReadArticle")(CookiesID) = ArticleID
			End If
			rsMember.Close: Set rsMember = Nothing
		End If
		UserArticle = False
	End Function

	'=================================================
	'函数名：ReadArticleContent
	'作  用：读取文章内容
	'参  数：ArticleID ----文章ID
	'=================================================
	Private Function ReadArticleContent(ArticleID, CurrentPage)
		On Error Resume Next
		Dim ThisUrl
		If Not IsNumeric(ArticleID) Then
			Exit Function
		Else
			ArticleID = CLng(ArticleID)
		End If
		If CurrentPage = 0 Then CurrentPage = 1
		SQL = "SELECT A.ArticleID,A.ClassID,A.title,A.content,A.Related,A.Author,A.ComeFrom,A.isTop,A.username,A.star,A.isBest,A.WriteTime,A.Allhits,A.HtmlFileDate,A.UserGroup,A.PointNum,C.ClassName,C.ParentID,C.ParentStr,C.skinid,C.HtmlFileDir,C.ChildStr,C.UserGroup As User_Group,C.UseHtml,C.AdsCode,C.stopad FROM [NC_Article] A INNER JOIN [NC_Classify] C On A.ClassID=C.ClassID WHERE A.ChannelID=" & ChannelID & " And A.isAccept > 0 And A.ArticleID=" & ArticleID
		Set Rs = Newasp.Execute(SQL)
		If Rs.BOF And Rs.EOF Then
			ReadArticleContent = ""
			Set Rs = Nothing
			If CreateHtml = 0 Then
				Response.Write "<meta http-equiv=""refresh"" content=""2;url='/"">" & vbNewLine
				Response.Write "<p align=""center"" style=""font-size: 16px;color: red;"">对不起，该页面发生了错误，无法访问! 系统两秒后自动转到网站首页......</p>" & vbNewLine
			End If
			Exit Function
		End If
		If Rs("UserGroup") > 0 Or Rs("User_Group") >0 Then
			UserArticle = True
		Else
			UserArticle = False
		End If
		
		If Rs("skinid") <> 0 Then
			skinid = Rs("skinid")
		Else
			skinid = Newasp.ChannelSkin
		End If
		Newasp.LoadTemplates ChannelID, 3, skinid
		'-- 限制会员文章显示字符数
		maxstrlen = CInt(Newasp.ChkNumeric(Newasp.HtmlSetting(8)))
		If maxstrlen < 5 Then maxstrlen = 300
		
		If CreateHtml <> 0 Then
			ArticleContent = HtmlPagination(CurrentPage)
			ThisUrl = ShowChannelPath(ChannelRootDir,Rs("HtmlFileDir")) & Newasp.ShowDatePath(Rs("HtmlFileDate"), Newasp.HtmlPath) & Newasp.ReadFileName(Rs("HtmlFileDate"), Rs("ArticleID"), Newasp.HtmlExtName, Newasp.HtmlPrefix, Newasp.HtmlForm, "")
		Else
			CheckUserRead Rs("ArticleID"), Rs("PointNum"), Rs("UserGroup"), Rs("User_Group")
			Call ContentPagination
			ThisUrl = "show.asp?id=" & Rs("ArticleID")
		End If
		
		HtmlContent = Newasp.HtmlContent
		'-- 新增分类广告代码
		HtmlContent = AdsReplace(HtmlContent,Rs("AdsCode"),Rs("stopad"))
		HtmlContent = Replace(HtmlContent, "{$ChannelRootDir}", ChannelRootDir)
		HtmlContent = Replace(HtmlContent, "{$InstallDir}", strInstallDir)
		HtmlContent = Replace(HtmlContent, "{$ChannelID}", ChannelID)
		HtmlContent = Replace(HtmlContent, "{$ArticleIndex}", strIndexName)
		HtmlContent = Replace(HtmlContent, "{$ModuleName}", Newasp.ModuleName)
		HtmlContent = Replace(HtmlContent, "{$MemberName}", Newasp.membername)
		HtmlContent = Replace(HtmlContent, "{$PageTitle}", Rs("title"))
		HtmlContent = Replace(HtmlContent, "{$ClassID}", Rs("ClassID"))
		HtmlContent = Replace(HtmlContent, "{$ArticleID}", ArticleID)
		HtmlContent = Replace(HtmlContent, "{$CurrentPage}", CurrentPage)
		HtmlContent = Replace(HtmlContent, "{$ArticleTitle}", Rs("title"))
		HtmlContent = Replace(HtmlContent, "{$ArticleContent}", ArticleContent)
		If UserArticle = True Then
			HtmlContent = Replace(HtmlContent, "{$ScriptContent}", "<script src=""" & ChannelRootDir & "content.asp?ArticleID=" & ArticleID & "&page=" & CurrentPage & """></script>")
		Else
			HtmlContent = Replace(HtmlContent, "{$ScriptContent}", "")
		End If
		HtmlContent = Replace(HtmlContent, "{$Author}", Newasp.ChkNull(Rs("Author")))
		HtmlContent = Replace(HtmlContent, "{$ComeFrom}", Rs("ComeFrom"))
		HtmlContent = Replace(HtmlContent, "{$WriteTime}", Rs("WriteTime"))
		HtmlContent = Replace(HtmlContent, "{$UserName}", Rs("username"))
		HtmlContent = Replace(HtmlContent, "{$Star}", Rs("star"))
		HtmlContent = Replace(HtmlContent, "{$Best}", Rs("isBest"))
		HtmlContent = Replace(HtmlContent, "{$ClassName}", Rs("ClassName"))
		HtmlContent = Replace(HtmlContent, "{$ThisUrl}", ThisUrl)
		HtmlContent = Replace(HtmlContent, "{$HeadTitle}", Rs("title"))