ks.rcls.asp

本系统是根据科汛系统编写的程序

			  GetSiteCountAll = GetSiteCountAll & "<li>留言总数： " & GuestBookTotal &" 条</li>" & vbcrlf
			  GetSiteCountAll = GetSiteCountAll & "<li>评论总数： " & CommentTotal & " 条</li>" & vbcrlf
			  GetSiteCountAll = GetSiteCountAll & "<li>在线人数： <script language=""javascript"" src=""" & DomainStr & "KS_Inc/online.asp?ID=1""></script> 人</li>" & vbcrlf
		   GetSiteCountAll = GetSiteCountAll & "</div>" & vbcrlf
		End Function
		'替换RSS标签
		Function ReplaceRssLabel(F_C)
		   IF KS.Setting(83)=0 Then 
				F_C=Replace(F_C,"{$Rss}","")
				F_C=Replace(F_C,"{$RssElite}","")
				F_C=Replace(F_C,"{$RssHot}","")
				ReplaceRssLabel=F_C
			    Exit Function
		   End If
		   Dim CurrentRefreshType:CurrentRefreshType=Application(KS.SiteSN & "RefreshType")
		   Dim CurrentClassID:CurrentClassID=Application(KS.SiteSN & "RefreshFolderID")
		   Dim ChannelID:ChannelID=Application(KS.SiteSN&"ChannelID")
			Select Case Ucase(CurrentRefreshType)
			   Case "INDEX"
			    F_C=Replace(F_C,"{$Rss}",GetRssLink("Rss.asp"))
				F_C=Replace(F_C,"{$RssElite}",GetRssLink("Rss.asp?Elite=1"))
				F_C=Replace(F_C,"{$RssHot}",GetRssLink("Rss.asp?Hot=1"))
			  Case "FOLDER"
			    F_C=Replace(F_C,"{$Rss}",GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & ""))         
				F_C=Replace(F_C,"{$RssElite}",GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & "&Elite=1"))
				F_C=Replace(F_C,"{$RssHot}",GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & "&Hot=1"))
			   Case Else
				F_C=Replace(F_C,"{$Rss}","")
				F_C=Replace(F_C,"{$RssElite}","")
				F_C=Replace(F_C,"{$RssHot}","")
			End Select
		    ReplaceRssLabel = F_C
		End Function
		'取得每个频道的RSS链接，结合ReplaceRssLabel调用
		Function GetRssLink(LinkStr)
		   GetRssLink="<a href=""" & DomainStr & LinkStr & """ target=""_blank""><img src=""" & DomainStr & "Images/Rss.gif" & """ border=""0""></a>"
		End Function
		'*********************************************************************************************************
		'函数名：ReplaceNewsContent
		'作  用：替换文章内容页标签为内容
		'参  数：RS Recordset数据集,FileContent待替换的内容,Content文章内容
		'*********************************************************************************************************
		Function ReplaceNewsContent(ChannelID,RS, F_C, Content)
			 Dim TempStr, N
			 On Error Resume Next
			   If InStr(F_C, "{$GetArticleSize}") <> 0 Then
				   Content = "<span id=""ContentArea"">" & Content & "</span>"
				   TempStr = "<script Language=Javascript>" & _
					  "function ContentSize(size)" & _
					  "{document.all.ContentArea.style.fontSize=size+""px"";}" & _
					  "</script>"
				  TempStr = TempStr & "【字体：<A href=""javascript:ContentSize(16)"">大</A> <A href=""javascript:ContentSize(14)"">中</A> <A href=""javascript:ContentSize(12)"">小</A>】"
				  F_C = Replace(F_C, "{$GetArticleSize}", TempStr)
			  End If
			F_C=ReplaceUserDefine(ChannelID,F_C,RS)
			Content=ReplaceAd(Content,RS("Tid"))

			F_C = Replace(F_C, "{$GetArticleContent}", KS.ReplaceInnerLink(FormatImg(Content)))
			If InStr(F_C, "{$GetArticleAction}") <> 0 Then
				 TempStr = "【<A href=""" & DomainStr & "plus/Comment.asp?ChannelID=" & ChannelID & "&InfoID=" & RS("ID") & """ target=""_blank"">发表评论</A>】【<A href=""" & DomainStr & KS.C_S(ChannelID,10) & "/SendMail.asp?ID=" & RS("ID") & """ target=""_blank"">告诉好友</A>】【<A href=""" & DomainStr & KS.C_S(ChannelID,10) & "/Print.asp?ID=" & RS("ID") & """ target=""_blank"">打印此文</A>】【<A href=""" & DomainStr & "User/index.asp?User_Favorite.asp?Action=Add&ChannelID=" & ChannelID & "&InfoID=" & RS("ID") & """ target=""_blank"">收藏此文</A>】【<A href=""javascript:window.close();"">关闭窗口</A>】"
				 F_C = Replace(F_C, "{$GetArticleAction}", TempStr)
			End If
		 	F_C = Replace(F_C, "{$ChannelID}", ChannelID)
			F_C = Replace(F_C, "{$InfoID}", RS("ID"))
			F_C = Replace(F_C, "{$ItemName}", KS.C_S(ChannelID,3))
			F_C = Replace(F_C, "{$ItemUnit}", KS.C_S(ChannelID,4))
			F_C = Replace(F_C, "{$GetArticleID}", RS("NewsID"))
			F_C = Replace(F_C, "{$GetArticleIntro}", RS("Intro"))
			F_C = Replace(F_C, "{$GetArticleShortTitle}", RS("Title"))
			F_C = Replace(F_C, "{$GetArticleUrl}", KS.GetInfoUrl(ChannelID,RS("Tid"),RS("ID"),RS("Fname"),RS("ReadPoint"),RS("InfoPurview"),RS("Changes")))
			F_C = Replace(F_C, "{$GetArticleKeyWord}", Replace(RS("KeyWords"), "|", ","))
			F_C = Replace(F_C, "{$GetKeyTags}",ReplaceKeyTags(ChannelID,RS("Keywords")))
			F_C = Replace(F_C, "{$GetArticleAuthor}", RS("Author"))
			F_C = Replace(F_C, "{$GetArticleInput}", "<a href='" & DomainStr & "/Space/Space.asp?UserName=" & RS("ArticleInput")&"' target='_blank'>" & rs("articleinput") & "</a>" )

			IF RS("FullTitle")="" Or IsNull(RS("FullTitle")) Then
		     F_C = Replace(F_C, "{$GetArticleTitle}", RS("Title"))
			Else
		     F_C = Replace(F_C, "{$GetArticleTitle}", RS("FullTitle"))
			End IF
			
			If Not IsNull(RS("Origin")) And Trim(RS("Origin")) <> "" Then
				 F_C = Replace(F_C, "{$GetArticleOrigin}", KS.GetOrigin(RS("Origin")))
			Else
				 F_C = Replace(F_C, "{$GetArticleOrigin}", "本站原创")
			End If
			
		   
				If InStr(F_C, "{=GetPhoto") <> 0 Then
				     Dim HtmlLabel: HtmlLabel = KSLabel.GetFunctionLabel(F_C, "{=GetPhoto")
					 Dim Param: Param = KSLabel.GetFunctionLabelParam(HtmlLabel, "{=GetPhoto")
					 Dim PhotoUrl:PhotoUrl=RS("PicUrl")
					 If Not (IsNull(PhotoUrl) Or PhotoUrl = "") Then
					  F_C = Replace(F_C,HtmlLabel, "<div align=""center""><img src=""" & PhotoUrl & """  width=""" & Split(Param, ",")(0) & """ height=""" & Split(Param, ",")(1) & """ border=""0""></div>")
					 Else
					  F_C = Replace(F_C, HtmlLabel, "<div align=""center""><img src=""" & DomainStr & "images/nopic.gif""  width=""" & Split(Param, ",")(0) & """ height=""" & Split(Param, ",")(1) & """ border=""0""></div>")
					 End If
			   End If
			   
		 
		 
		   '属性
		  If InStr(F_C, "{$GetArticleProperty}") <> 0 Then
			  TempStr = ""
			  If CInt(RS("Recommend")) = 1 Then
				 TempStr = TempStr & ("<span title=""推荐"" style=""cursor:default""><font color=""green"">荐</font></span>&nbsp;&nbsp;")
			  End If
			  If CInt(RS("Popular")) = 1 Then
				 TempStr = TempStr & ("<span title=""热门"" style=""cursor:default""><font color=""red"">热</font></span>&nbsp;&nbsp;")
			  End If
			  If CInt(RS("Strip")) = 1 Then
				 TempStr = TempStr & ("<span title=""今日头条"" style=""cursor:default""><font color=""#0000ff"">头</font></span>&nbsp;&nbsp;")
			  End If
			  If CInt(RS("Rolls")) = 1 Then
				 TempStr = TempStr & ("<span title=""滚动"" style=""cursor:default""><font color=""#F709F7"">滚</font></span>&nbsp;&nbsp;")
			  End If
			  If CInt(RS("Slide")) = 1 Then
				 TempStr = TempStr & ("<span title=""幻灯片"" style=""cursor:default""><font color=""black"">幻</font></span>&nbsp;")
			 End If
			 TempStr = TempStr & "   " & Replace(RS("Rank"),"★","<img src=""" & DomainStr & "Images/Star.gif"" border=""0"">")
			 F_C = Replace(F_C, "{$GetArticleProperty}", TempStr)
		   End If
		 
			If InStr(F_C, "{$GetArticleHits}") <> 0 Then
			 F_C = Replace(F_C, "{$GetArticleHits}", "<Script Language=""Javascript"" Src=""" & DomainStr & KS.C_S(ChannelID,10) & "/GetHits.asp?ID=" & RS("ID") & """></Script>")
			End If
		   If InStr(F_C, "{$GetArticleDate}") <> 0 Then
			 F_C = Replace(F_C, "{$GetArticleDate}", KS.DateFormat(RS("AddDate"), 6))
		   End If
		   
		   If InStr(F_C, "{$GetShowComment}") <> 0 And RS("Comment") = 1 Then
			 F_C = Replace(F_C,"{$GetShowComment}","<script src=""" & DomainStr & "ks_inc/Comment.page.js"" language=""javascript""></script><script language=""javascript"" defer>Page(1," & ChannelID & ",'" & RS("ID") & "','Show','"& DomainStr & "');</script><div id=""c_" & RS("ID") & """></div><div id=""p_" & RS("ID") & """ align=""right""></div>")

		   Else
			F_C = Replace(F_C, "{$GetShowComment}", "")
		   End If
		   If InStr(F_C, "{$GetWriteComment}") <> 0 And RS("Comment") = 1 Then
			 F_C = Replace(F_C, "{$GetWriteComment}", "<Script Language=""Javascript"" Src=""" & DomainStr & "plus/Comment.asp?Action=Write&ChannelID=" & ChannelID & "&InfoID=" & RS("ID") & """></Script>")
		   Else
			 F_C = Replace(F_C, "{$GetWriteComment}", "")
		   End If
		   
		     F_C = Replace(F_C, "{$GetPrevArticle}", ReplacePrevNext(ChannelID,RS("Id"), RS("tid"), "<"))
			 F_C = Replace(F_C, "{$GetNextArticle}", ReplacePrevNext(ChannelID,RS("Id"), RS("tid"), ">"))
			ReplaceNewsContent = F_C
		End Function
		'*********************************************************************************************************
		'函数名：ReplacePrevNext
		'作  用：上一篇、下一篇
		'参  数：NowID 现在ID,Tid 目录ID,TypeStr类型
		'*********************************************************************************************************
		Function ReplacePrevNext(ChannelID,NowID, Tid, TypeStr)
		     Dim SqlStr
		     Select Case KS.C_S(ChannelID,6)
			   Case 1:SqlStr="SELECT Top 1 ID,Title,Tid,InfoPurview,ReadPoint,Fname,Changes"
			   Case 2,3,4,7:SqlStr="SELECT Top 1 ID,Title,Tid,InfoPurview,ReadPoint,Fname,0"
			   Case 8:SqlStr="SELECT Top 1 ID,Title,Tid,0,0,Fname,0"
			   Case 5:SqlStr=" SELECT Top 1 ID,Title,Tid,0,0,Fname,0"
			   Case Else :ReplacePrevNext="":Exit Function
			 End Select
			 SqlStr=SqlStr & " From " & KS.C_S(ChannelID,2) & " Where Tid='" & Tid & "' And ID" & TypeStr & NowID & " And Verific=1 and  DelTF=0 Order By ID"
			 If TypeStr=">" Then SqlStr=SqlStr & " asc" else SqlStr=SqlStr & " desc"
			 Dim RS:Set RS=Conn.Execute(SqlStr)
			 If RS.EOF And RS.BOF Then
			  ReplacePrevNext = "没有了"
			 Else
			  ReplacePrevNext = "<a href=""" & KS.GetInfoUrl(KS.C_S(ChannelID,0),RS(2),RS(0),RS(5),RS(4),RS(3),RS(6)) & """ title=""" & RS(1) & """>" & RS(1) & "</a>"
			 End If
			 RS.Close:Set RS = Nothing
		End Function
		'替换自定义字段
		Function ReplaceUserDefine(ChannelID,F_C,RS)
		 Dim D_F_Arr,K
		        D_F_Arr=KSCls.Get_KS_D_F_Arr(ChannelID)
				If IsArray(D_F_Arr) Then
				  For K=0 To Ubound(D_F_Arr,2)
					 If Not IsNull(RS("" &D_F_Arr(0,K) & "")) Then
					  F_C = Replace(F_C,"{$" & D_F_Arr(0,K) & "}",RS("" &D_F_Arr(0,K) & ""))
					 Else
					  F_C = Replace(F_C,"{$" & D_F_Arr(0,K) & "}","")
					 End If
				  Next
				End If
				ReplaceUserDefine=F_C
		End Function
		Function ReplaceKeyTags(ChannelID,KeyStr)
		  On error resume next
		  Dim I,K_Arr:K_Arr=Split(KeyStr,"|")
		  For I=0 To Ubound(K_Arr)
		    ReplaceKeyTags=ReplaceKeyTags & "<a href=""" & KS.Setting(3) & "plus/search.asp?searchtype=5&channelid=" & channelid & "&tags=" & K_Arr(i) & """ target=""_blank"">" & K_Arr(i) & "</a> "
		  Next
		  If Err Then ReplaceKeyTags="":Err.Clear
		End Function
		'替换画中画广告
		Function ReplaceAD(ByVal Content,ClassID)
		 Dim ShowADTF,CLen,Dir,Width,Height,AdUrl,AdLinkUrl,LC,RC,AdStr,ADType
		 Dim ClassBasicInfo:ClassBasicInfo=KS.C_C(ClassID,6)
		 Dim AdP:AdP = Split(Split(ClassBasicInfo,"||||")(4),"%ks%")
		 ShowADTF=KS.ChkClng(Adp(0))
		 If ShowADTF=0 Then ReplaceAD=Content:Exit Function
		 Dim Param:Param=Split(AdP(1),",")

		 CLen=KS.ChkClng(Param(0)):Dir=Param(1):Width=KS.ChkClng(Param(2)):Height=KS.ChkClng(Param(3)):AdUrl=Adp(3):AdLinkUrl=Adp(4):ADType=KS.ChkClng(ADP(2))

		 If CLen<>0 Then LC=InterceptString(Content,Clen)
		 RC=Right(Content,Len(Content)-Len(LC))		 		 
               If ADType=2 Then
			     Adstr="<table border=""0"" width="""& Width & """ height=""" & height & """ align="""&Dir&"""><tr><td>" & AdUrl & "</td></tr></table>"
			   Else
                    If Lcase(Right(AdUrl,3))="swf" Then'判断是否Swf图片
						AdStr="<table width=""0"" border=""0"" align="""&Dir&"""><tr><td><object classid=""clsid:D27CDB6E-AE6D-11cf-96B8-444553540000"" codebase=""http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=6,0,29,0""  height=""" & height & """ width="""&width&""" ><param name=""movie"" value="""&AdUrl&"""><param name=""quality"" value=""high""><embed src="""&AdUrl&""" quality=""high"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" type=""application/x-shockwave-flash"" height=""" & height & """  width="""&Width&"""></embed></object></td></tr></table>"
					Else
						If AdLinkUrl="" Then AdLinkUrl="http://www.flyskying.com"
						AdStr="<table width=""0"" border=""0"" align="""&Dir&"""><tr><td><a href="""&AdLinkUrl&"""><img border=""0"" src="""&AdUrl&""" height=""" & height & """ width="""&Width&""" target=""_blank""></a></td></tr></table>"
					End If
				End If	

		 ReplaceAD=LC & AdStr & RC
	   End Function
	   '截取字符串
		Function InterceptString(ByVal txt,length)
			Dim x,y,ii,c,ischines,isascii,tempStr
			length=Cint(length)
			txt=trim(txt):x = len(txt):y = 0
			if x >= 1 then
				for ii = 1 to x
					c=asc(mid(txt,ii,1))
					if  c< 0 or c >255 then
						y = y + 2:ischines=1:isascii=0
					else
						y = y + 1:ischines=0:isascii=1
					end if
					if y >= length then
						if ischines=1 and StrCount(left(trim(txt),ii),"<a")=StrCount(left(trim(txt),ii),"</a>") then
							txt = left(txt,ii) '"字符串限长
							exit for
						else
							if isascii=1 then x=x+1
						end if
					end if
				next
				InterceptString = txt
			else
				InterceptString = ""
			end if
		End Function
		
		'判断字符串出现的次数
		Public Function StrCount(Str,SubStr)        
			Dim iStrCount,iStrStart,iTemp
			iStrCount = 0:iStrStart = 1:iTemp = 0:Str=LCase(Str):SubStr=LCase(SubStr)
			Do While iStrStart < Len(Str)
				iTemp = Instr(iStrStart,Str,SubStr,vbTextCompare)
				If iTemp <=0 Then
					iStrStart = Len(Str)
				Else
					iStrStart = iTemp + Len(SubStr)
					iStrCount = iStrCount + 1
				End If
			Loop
			StrCount = iStrCount
		End Function