cl_function_article.asp

正版创力4.1SQL商业版!!!ASP版。

'							---- 6(2004年10月01日)
'							---- 7(10-01)
'							---- 8(20041001234545)
'	ShowHits		------  是否显示文章点击数(True为显示，False为不显示)
'	ShowHot			------  是否显示热门文章标志(True为显示，False为不显示)
'	IsHot			------  是否热门(True为是，False为否)
'	IsElite			------  是否推荐(True为是，False为否)
'	UserName		------  指定某用户(不指定请留空值或0)
'	CssClassName        ------  CSS样式
'====================================================================================================
Function ShowArticle(Byval sChannelID,Byval sClassID,Byval sSpecialID, _
	Byval TopNum,Byval TitleLen,Byval ShowClassName,Byval ShowProperty, _
	Byval ShowPrefix,Byval ShowAuthor,Byval ShowDateType,Byval ShowHits, _
	Byval ShowHot,Byval IsHot,Byval IsElite,Byval sUserName,Byval CssClassName)
	On Error ReSume Next
	sChannelID		= Clng(sChannelID)		: sClassID		= Clng(sClassID)
	sSpecialID		= Clng(sSpecialID)		: TopNum		= Clng(TopNum)
	TitleLen		= Clng(TitleLen)		: ShowClassName	= CBool(ShowClassName)
	ShowProperty	= CBool(ShowProperty)	: ShowPrefix	= CBool(ShowPrefix)
	ShowAuthor		= CBool(ShowAuthor)		: ShowDateType	= Clng(ShowDateType)
	ShowHits		= CBool(ShowHits)		: ShowHot		= CBool(ShowHot)
	IsHot			= CBool(IsHot)			: IsElite		= CBool(IsElite)
	sUserName		= Trim(sUserName)		: CssClassName	= Trim(CssClassName)
	if Err then Err.Clear : ShowArticle="ShowArticle参数错误。" : Exit Function
	On Error GoTo 0
	Dim rsInfo,SQLInfo,WhereStr
	if TopNum<=0 then
		SqlInfo="Select "
	else
		SqlInfo="Select Top "&TopNum&" "
	end if
	SqlInfo = SqlInfo & "InfoID, ChannelID, ChannelDir, ClassID, Prefixion, Title, FontColor, FontType, Author, CopyFrom, Editor, UpdateTime, Censor, Stars, OnTop, Hot, Elite, Hits, InfoPoint, InfoMoney, IsLink, IsHtml, HtmlFileUrl, LastHitTime, CommentCount from Cl_Article "
	WhereStr=" where Deleted="&FalseType&" and Status=1 "
	if sChannelID>0 then WhereStr = WhereStr & " and ChannelID="&sChannelID&" "
	if sClassID>0 then
		Dim tClass
		Set tClass=Cl.Execute("select Child,arrChildID from Cl_Class where ClassID=" & sClassID)
		if not(tClass.bof and tClass.eof) then
			if tClass(0)>0 then
				WhereStr=WhereStr & " and ClassID in (" & tClass(1) & ")"
			else
				WhereStr=WhereStr & " and ClassID=" & sClassID
			end if
		else
			WhereStr=WhereStr & " and ClassID=" & sClassID
		end if
		Set tClass=Nothing
	end if
	if sSpecialID>0 then WhereStr=WhereStr & " and SpecialID Like '%," & SpecialID & ",%'"
	if IsElite=True then WhereStr=WhereStr & " and Elite="&TrueType
	if IsHot=True then WhereStr=WhereStr & " and Hot="&TrueType
	if sUserName<>"" and sUserName<>"0" then WhereStr=WhereStr & " and Editor='" & sUserName & "'"
	'Response.write WhereStr
	'Response.end
	if IsSqlDataBase=1 then
	SqlInfo=SqlInfo & WhereStr & " order by OnTop Desc,UpdateTime desc,InfoID desc"
	Else
	SqlInfo=SqlInfo & WhereStr & " order by OnTop Asc,UpdateTime desc,InfoID desc"
	End if
	Set rsInfo=Cl.Execute(SqlInfo)
	if rsInfo.bof and  rsInfo.eof then
		ShowArticle="<br /><li>当前没有记录！</li>"
		rsInfo.close:set rsInfo=Nothing : Exit Function
	End If
	if TopNum<=0 or TopNum>=50 then
		Dim rsTotalPut
		Set rsTotalPut= Cl.Execute("Select count(InfoID) from Cl_Article " & WhereStr)
		TotalPut = rsTotalPut(0)
		rsTotalPut.Close : Set rsTotalPut=Nothing
		if (TotalPut mod PageSize)=0 then
			TotalPages = TotalPut \ PageSize
		else
			TotalPages = TotalPut \ PageSize + 1
		end if
		if CurrentPage > TotalPages then CurrentPage=TotalPages
		if CurrentPage < 1 then CurrentPage=1
		rsInfo.move (CurrentPage-1)*PageSize
		SqlInfo=rsInfo.GetRows(PageSize)
	else
		SqlInfo=rsInfo.GetRows(-1)
	end if
	rsInfo.close:set rsInfo=Nothing
	Dim sTemp,Linkurl,i,tClassName
	Dim TitleStr,Author,AuthorName,AuthorEmail,sTitleLen
	sTemp = "<ul class="""&CssClassName&""">" & VbCrlf
	For i=0 to Ubound(SqlInfo,2)
		sTitleLen = TitleLen
		sTemp = sTemp & "<li>"'&nbsp;
		if ShowProperty=True Then
			sTemp = sTemp & "<span class=""property"">"
			if SqlInfo(14,i)=True then
				sTemp = sTemp & "<img src=""" & InstallDir & "Images/ArticleOntop.gif"" alt=""固顶"" />&nbsp;"
			elseif SqlInfo(16,i)=True then
				sTemp = sTemp & "<img src=""" & InstallDir & "Images/ArticleElite.gif"" alt=""推荐"" />&nbsp;"
			else
				sTemp = sTemp & "<img src=""" & InstallDir & "Images/ArticleCommon.gif"" alt=""普通"" />&nbsp;"
			end If
			sTemp = sTemp & "</span>"
		end if
		if ShowClassName=True and SqlInfo(3,i)<>sClassID Then
			tClassName = Cl.GetClassName(SqlInfo(3,i))
			sTemp=sTemp & "<span class=""classname"">[<a href=""" & Cl.WebDir & SqlInfo(2,i) & "/ShowClass.asp?ClassID="&SqlInfo(3,i)&""">" & tClassName & "</a>]&nbsp;</span>"
			sTitleLen=sTitleLen-Cl.strLength(tClassName)-1
		end if
		if ShowPrefix=True and SqlInfo(4,i)<>"" then
			sTemp = sTemp & "<span class=""prefix"">"&SqlInfo(4,i)&"</span>"
			sTitleLen=sTitleLen-Cl.strLength(SqlInfo(4,i))-2
		end if
		if CBool(SqlInfo(21,i)) then
			LinkUrl=Cl.WebDir & SqlInfo(22,i)
		else
			LinkUrl=Cl.WebDir & SqlInfo(2,i) & "/ShowInfo.asp?InfoID="&SqlInfo(0,i)
		end if
		sTemp = sTemp & "<span class=""title""><a href=""" & LinkUrl & """ title=""" & SqlInfo(5,i) & """ target=""_blank"">"
		TitleStr=Cl.GotTopic(SqlInfo(5,i),sTitleLen)
		TitleStr=Cl.GetTitleFont(TitleStr,SqlInfo(7,i))
		TitleStr=Cl.FormatColor(TitleStr,SqlInfo(6,i))
		sTemp=sTemp & TitleStr & "</a></span>"
		if ShowHot=True then
			if CDate(FormatDateTime(SqlInfo(11,i),2))=Date() then
				sTemp= sTemp & "<span class=""new""><img src=""" & InstallDir & "Images/news.gif"" alt=""最新"" /></span>"
			elseif SqlInfo(17,i)>=Clng(Cl.Web_Setting(14)) then
				sTemp= sTemp & "<span class=""hot""><img src=""" & InstallDir & "Images/hot.gif"" alt=""热门"" /></span>"
			end if
		end If
		'InfoID, ChannelID, ChannelDir, ClassID, Prefixion, Title=5, FontColor, FontType, Author, CopyFrom, Editor=10, UpdateTime, Censor, Stars, OnTop=14, Hot, Elite=16, Hits=17, InfoPoint, InfoMoney, IsLink=20, IsHtml, HtmlFileUrl=22, LastHitTime, CommentCount
		if ShowAuthor=True or ShowHits=True or ShowDateType>0 then
			sTemp = sTemp & "<span class=""other"">("
			if ShowAuthor=True Then
			if InStr(SqlInfo(8,i),"|")>0 then
				Author=Split(SqlInfo(8,i),"|")
				AuthorName=Author(0)
				AuthorEmail=Author(1)
			else
				AuthorName=SqlInfo(8,i)
				AuthorEmail="[e-mail]"
			end if
				sTemp=sTemp & "<a href=""mailto:" & AuthorEmail & """>" & AuthorName & "</a>"
			end if
			if ShowHits=True then
				if ShowAuthor=True then
					sTemp=sTemp & ","
				end if
				sTemp=sTemp &  "<span style=""color:#ff0033;"">"&SqlInfo(17,i)&"</span>" 'Cl.FormatColor(SqlInfo(16,i),"#ff0033")
			end if
			if ShowDateType>0 then
				if ShowHits=True or ShowAuthor=True then
					sTemp=sTemp & ","
				end if
				if CDate(FormatDateTime(SqlInfo(11,i),2))=date() then
					sTemp = sTemp & "<span style=""color:#ff0033;"">"
				else
					sTemp = sTemp & "<span style=""color:#999999;"">"
				end if
				sTemp = sTemp & Cl.Format_Time(SqlInfo(11,i),ShowDateType) & "</span>"
			end if
			sTemp = sTemp & ")</span>"
		end if
		sTemp = sTemp & "</li>" & VbCrlf
	Next
	ShowArticle=sTemp & "</ul>"
	SqlInfo=Empty
end Function
'================================================================
'过程名：ShowTopArticle(sChannelID,sClassID,TopNum,TitleLen,ShowType,ShowHits)
'		sChannelID	----频道ID
'		sClassID	----栏目ID
'		TopNum		----下载TOP
'		TitleLen	----标题最多字符数，一个汉字=两个英文字符
'		ShowType	----- 1(本日)，2(本周),3(本月),4(累计)
'		ShowHits	------	(是否显示点击数，True为是)
'================================================================
Function ShowTopArticle(Byval sChannelID,Byval sClassID,Byval TopNum, _
	Byval TitleLen,Byval ShowType,Byval ShowHits)
	dim sqlTop,rsTop,LinkUrl
	On Error ReSume Next
	sChannelID	= Clng(sChannelID)	: sClassID = Clng(sClassID)
	TopNum		= Clng(TopNum)		: TitleLen = Clng(TitleLen)
	ShowType	= Clng(ShowType)	: ShowHits = CBool(ShowHits)
	if Err then Err.Clear : ShowTopArticle="ShowTopArticle参数错误。" : Exit Function
	On Error GoTo 0
	if TopNum>0 then
		sqlTop="select top " & TopNum & " "
	else
		sqlTop="select top 10 "
	end if
	sqlTop=sqlTop & " InfoID,ChannelID,ChannelDir,ClassID,Title,Prefixion,Author,UpdateTime,Editor,FontColor,FontType,OnTop,Hot,Elite,Stars,Hits,IsHtml,HtmlFileUrl from Cl_Article where Deleted="&FalseType&" and Status=1 and ChannelID="&sChannelID&" "
	if sClassID>0 then
		Dim tClass
		Set tClass=Cl.Execute("select ClassID,Child,ParentPath,arrChildID from Cl_Class where ChannelID="&sChannelID&" and ClassID=" & sClassID)
		if not(tClass.bof and tClass.eof) then
			if tClass(1)>0 then
				sqlTop=sqlTop & " and ClassID in (" & tClass(3) & ")"
			else
				sqlTop=sqlTop & " and ClassID=" & sClassID
			end if
		else
			sqlTop=sqlTop & " and ClassID=" & sClassID
		end if
		Set tClass=Nothing
	end if
	Select Case ShowType
	Case 1
		if IsSqlDataBase=1 then
		sqlTop=sqlTop & " And datediff(D,LastHitTime,getdate())<=0 order by DayHits desc,InfoID desc"
		else
		sqlTop=sqlTop & " And datediff('D',LastHitTime,now())<=0 order by DayHits desc,InfoID desc"
		end if
	Case 2
		if IsSqlDataBase=1 then
		sqlTop=sqlTop & " And datediff(ww,LastHitTime,getdate())<=0 order by WeekHits desc,InfoID desc"
		else
		sqlTop=sqlTop & " And datediff('ww',LastHitTime,now())<=0 order by WeekHits desc,InfoID desc"
		end if
	Case 3
		if IsSqlDataBase=1 then
		sqlTop=sqlTop & " And datediff(m,LastHitTime,getdate())<=0 order by MonthHits desc,InfoID desc"
		else
		sqlTop=sqlTop & " And datediff('m',LastHitTime,now())<=0 order by MonthHits desc,InfoID desc"
		end if
	Case Else
		sqlTop=sqlTop & " order by Hits desc,InfoID desc"
	end Select
	Set rsTop= Cl.Execute(sqlTop)
	if rsTop.bof and rsTop.eof then 
		ShowTopArticle = "<li>当前没有记录！</li>"
		rsTop.Close:Set rsTop=Nothing:Exit Function
	End if
	Dim sTemp
	sqlTop=rsTop.GetRows(-1)
	rsTop.Close:Set rsTop=Nothing
	'sTemp = "<ul>"
	For i=0 to Ubound(sqlTop,2)
		if sqlTop(16,i)=True then
			LinkUrl=Cl.WebDir & sqlTop(17,i)
		else
			LinkUrl=Cl.WebDir & sqlTop(2,i) & "/ShowInfo.asp?InfoID=" & sqlTop(0,i)
		end if
		sTemp = sTemp & "<li><span class='title'><a href='" & LinkUrl & "' title='" & sqlTop(4,i) & "' target='_blank'>" & Cl.gotTopic(sqlTop(5,i) & sqlTop(4,i),TitleLen) & "</a></span>"
		if ShowHits=True then
			sTemp=sTemp & "(<span class='hits'>" & sqlTop(15,i) & "</span>)"
		end if
		sTemp = sTemp & "</li>"
	Next
	ShowTopArticle=sTemp' & "</ul>"
	sqlTop=Empty
End Function

'===================================================================
'显示上一条或下一条文章
'过程名：ShowNearArticle(sChannelID,sClassID,sInfoID,TitleLen,sType)
'参  数：
'sChannelID		------ sChannelID(频道ID)
'sClassID		------ sClassID(栏目ID)
'sInfoID		------ sInfoID(文章ID)
'TitleLen		------ TitleLen(标题最多字符数)
'sType			------ sType(n为下一条文章)
'===================================================================
Function ShowNearArticle(Byval sChannelID,Byval sClassID,Byval sInfoID,Byval TitleLen,Byval sType)
	dim rsNear,sqlNear
	On Error Resume Next
	sChannelID	=Clng(sChannelID) : sInfoID	= Clng(sInfoID)
	sClassID	=Clng(sClassID)	: TitleLen	= Clng(TitleLen)
	if Err then Err.Clear : ShowNearArticle="ShowNearArticle参数错误。" : Exit Function
	On Error GoTo 0
	sqlNear="Select Top 1 InfoID,ChannelID,ChannelDir,ClassID,Title,Author,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Article Where Deleted="&FalseType&" and Status=1 and ChannelID="&sChannelID&" and ClassID=" & sClassID & " "
	if Lcase(sType)="n" then
		sqlNear=sqlNear & " and InfoID>" & sInfoID & " order by UpdateTime Asc,InfoID Asc"
	else
		sqlNear=sqlNear & " and InfoID<" & sInfoID & " order by UpdateTime Desc,InfoID Desc"
	end if
	Set rsNear= Cl.Execute(sqlNear)
	if rsNear.Eof then
		ShowNearArticle="没有了"
	else
		Dim LinkUrl
		sqlNear = rsNear.GetRows(-1)
		if sqlNear(8,0)=True then
			LinkUrl=Cl.WebDir & sqlNear(9,0)
		elseif CreateHtmlIng=True then
			LinkUrl=Cl.WebDir & Cl.GetItemPath(Cl.CreatePathType,Cl.HtmlDir,Cl.ChannelDir,ParentPath,ClassID,ParentDir,ClassDir) & Cl.GetItemFileName(Cl.CreateFileType,sqlNear(3,0),sqlNear(0,0),sqlNear(6,0)) &"."&Cl.CreateFileExt
		else
			LinkUrl=Cl.WebDir & sqlNear(2,0) & "/ShowInfo.asp?InfoID="&sqlNear(0,0)
		end if
		ShowNearArticle = "<a href='" & LinkUrl & "' title='标题：" & sqlNear(4,0) & vbcrlf & "作者：" & sqlNear(5,0) & vbcrlf & "更新：" & sqlNear(6,0) & vbcrlf & "点击：" & sqlNear(7,0) &"'>" & Cl.GotTopic(sqlNear(4,0),TitleLen) & "</a>"
	end if
	rsNear.Close : Set rsNear=Nothing
	sqlNear = Empty
End Function

'显示文章具体的内容：ShowArticleContent
Function ShowArticleContent()
	if (Cl.ChkUserGroupID(rs("InfoGroup"),5)=False or rs("Receive")=True) and CreateHtmlIng=True then
		ShowArticleContent="<script type='text/Javascript' src='"&Cl.WebDir&"GetContent.asp?InfoID="&rs("InfoID")&"'></script>"
		Exit Function
	end if
	if Not ChkTrueRead Then
		ErrMsg = Cl.Language.selectSingleNode("//ContentPreview").text & ErrMsg
		ErrMsg = Replace(ErrMsg,"{$content}",Cl.NoHtml(rs("Intro")))
		ShowArticleContent = ErrMsg
		Exit Function
	end if