function.asp

商务世纪新闻asp源代码

<%
Server.ScriptTimeout=10

Function GetPage(url) 
	Set Retrieval = CreateObject("Microsoft.XMLHTTP") 
	With Retrieval 
	.Open "Get", url, False, "", "" 
	.Send 
	GetPage = BytesToBstr(.ResponseBody)
	End With 
	Set Retrieval = Nothing 
End Function

Function BytesToBstr(body)
	dim objstream
	set objstream = Server.CreateObject("adodb.stream")
	objstream.Type = 1
	objstream.Mode =3
	objstream.Open
	objstream.Write body
	objstream.Position = 0
	objstream.Type = 2
	objstream.Charset = "GB2312"
	BytesToBstr = objstream.ReadText 
	objstream.Close
	set objstream = nothing
End Function

Function GetContent(str,start,last,n)
	If Instr(lcase(str),lcase(start))>0 then
		select case n
		case 0	'左右都截取（都取前面）（去处关键字）
		GetContent=Right(str,Len(str)-Instr(lcase(str),lcase(start))-Len(start)+1)
		GetContent=Left(GetContent,Instr(lcase(GetContent),lcase(last))-1)
		case 1	'左右都截取（都取前面）（保留关键字）
		GetContent=Right(str,Len(str)-Instr(lcase(str),lcase(start))+1)
		GetContent=Left(GetContent,Instr(lcase(GetContent),lcase(last))+Len(last)-1)
		case 2	'只往右截取（取前面的）（去除关键字）
		GetContent=Right(str,Len(str)-Instr(lcase(str),lcase(start))-Len(start)+1)
		case 3	'只往右截取（取前面的）（包含关键字）
		GetContent=Right(str,Len(str)-Instr(lcase(str),lcase(start))+1)
		case 4	'只往左截取（取后面的）（包含关键字）
		GetContent=Left(str,InstrRev(lcase(str),lcase(start))+Len(start)-1)
		case 5	'只往左截取（取后面的）（去除关键字）
		GetContent=Left(str,InstrRev(lcase(str),lcase(start))-1)
		case 6	'只往左截取（取前面的）（包含关键字）
		GetContent=Left(str,Instr(lcase(str),lcase(start))+Len(start)-1)
		case 7	'只往右截取（取后面的）（包含关键字）
		GetContent=Right(str,Len(str)-InstrRev(lcase(str),lcase(start))+1)
		case 8	'只往左截取（取前面的）（去除关键字）
		GetContent=Left(str,Instr(lcase(str),lcase(start))-1)
		case 9	'只往右截取（取后面的）（包含关键字）
		GetContent=Right(str,Len(str)-InstrRev(lcase(str),lcase(start)))
		end select
	Else
		GetContent=""
	End if
End function

Function GetRefreshUrl(str)

End function

Function DeHttpdata(strContent,filterstr)
	Dim re
	set re = New RegExp	
	re.IgnoreCase = True
	re.Global = True
	s = split(filterstr,"|")
	For each key in s
	re.Pattern=key
	strContent=re.Replace(strContent,"")
	Next
	DeHttpdata=strContent
	'例子 <body.+?>
End Function

Function GetUrl(theDate,theType)
	If not IsDate(theDate) then theDate=Date()
	select case theType
	case "sports"
		GetUrl="http://sports.sina.com.cn/date_"&Year(theDate)&"/"&Month(theDate)&"."&AddZero(Day(theDate),2)&".shtml"
	case "china"
		GetUrl="http://news.sina.com.cn/china/"&Year(theDate)&"-"&Month(theDate)&"-"&AddZero(Day(theDate),2)&"/index.shtml"
	case "world"
		GetUrl="http://news.sina.com.cn/world/"&Year(theDate)&"-"&Month(theDate)&"-"&AddZero(Day(theDate),2)&"/index.shtml"
	case "society"
		GetUrl="http://news.sina.com.cn/society/"&Year(theDate)&"-"&Month(theDate)&"-"&AddZero(Day(theDate),2)&"/index.shtml"
	case "tech"
		GetUrl="http://tech.sina.com.cn/oldnews/"&Year(theDate)&"-"&AddZero(Month(theDate),2)&"-"&AddZero(Day(theDate),2)&".shtml"
	case "finance"
		GetUrl="http://finance.sina.com.cn/oldnews/"&Year(theDate)&"-"&AddZero(Month(theDate),2)&"-"&AddZero(Day(theDate),2)&".html"
	case "ent"
		If theDate=Date() then theDate=Date()-1
		GetUrl="http://ent.sina.com.cn/news/"&Year(theDate)&AddZero(Month(theDate),2)&AddZero(Day(theDate),2)&".shtml"
	case "jczs"
		GetUrl="http://jczs.sina.com.cn/"
	case "jczswaijun"
		GetUrl="http://jczs.sina.com.cn/waijun/index.shtml"
	case "jczsxingshi"
		GetUrl="http://jczs.sina.com.cn/xingshi/index.shtml"
	case "jczsxinwen"
		GetUrl="http://jczs.sina.com.cn/xinwen/index.shtml"
	case "jczszonghe"
		GetUrl="http://jczs.sina.com.cn/zonghe/index.shtml"
	case "jczspingshu"
		GetUrl="http://jczs.sina.com.cn/pingshu/index.shtml"
	case "jczsjiyu"
		GetUrl="http://jczs.sina.com.cn/jiyu/index.shtml"
	case "jczsjunshi"
		GetUrl="http://jczs.sina.com.cn/junshi/index.shtml"
	case "jczszongheng"
		GetUrl="http://jczs.sina.com.cn/zongheng/index.shtml"
	case "jczsjunqing"
		GetUrl="http://jczs.sina.com.cn/junqing/index.shtml"
	case "jczsshijiao"
		GetUrl="http://jczs.sina.com.cn/shijiao/index.shtml"
	case "jczsjunli"
		GetUrl="http://jczs.sina.com.cn/junli/index.shtml"
	case "eladies"
		If theDate=Date() then theDate=Date()-1
		GetUrl="http://www.eladies.com.cn/news/"&Year(theDate)&AddZero(Month(theDate),2)&AddZero(Day(theDate),2)&".shtml"
	case "new"
		GetUrl="http://news.sina.com.cn/news1000/"
	case "newall"
		GetUrl="http://news.sina.com.cn/old1000/news1000_"&Year(theDate)&AddZero(Month(theDate),2)&AddZero(Day(theDate),2)&".shtml"
	end select
End function

Function VirtualURL(str,n)
	str = Replace(str,"http://news.sina.com.cn"    , n&"NewsNews"    )
	str = Replace(str,"http://tech.sina.com.cn"    , n&"TechNews"    )
	str = Replace(str,"http://sports.sina.com.cn"  , n&"SportsNews"  )
	str = Replace(str,"http://ent.sina.com.cn"     , n&"EntNews"     )
	str = Replace(str,"http://eladies.sina.com.cn" , n&"EladiesNews" )
	str = Replace(str,"http://auto.sina.com.cn"    , n&"AutoNews"    )
	str = Replace(str,"http://finance.sina.com.cn" , n&"FinanceNews" )
	str = Replace(str,"http://www.eladies.com.cn"  , n&"wwwEladies"  )
	str = Replace(str,"http://edu.sina.com.cn"     , n&"EduNews"     )
	str = Replace(str,"http://jczs.sina.com.cn"    , n&"JczsNews"    )
	str = Replace(str,"http://newbbs0.sina.com.cn" , n&"NewBBS0"     )
	str = Replace(str,"http://astro.sina.com.cn"   , n&"AstroNews"   )
	VirtualURL = str
End function

Function Urldns(url)
	If Instr(url,"NewsNews")>0 then
		urldns=Replace(url,"NewsNews","http://news.sina.com.cn")
	Elseif Instr(url,"TechNews")>0 then
		urldns=Replace(url,"TechNews","http://tech.sina.com.cn")
	Elseif Instr(url,"SportsNews")>0 then
		urldns=Replace(url,"SportsNews","http://sports.sina.com.cn")
	Elseif Instr(url,"EntNews")>0 then
		urldns=Replace(url,"EntNews","http://ent.sina.com.cn")
	Elseif Instr(url,"EladiesNews")>0 then
		urldns=Replace(url,"EladiesNews","http://eladies.sina.com.cn")
	Elseif Instr(url,"AutoNews")>0 then
		urldns=Replace(url,"AutoNews","http://auto.sina.com.cn")
	Elseif Instr(url,"FinanceNews")>0 then
		urldns=Replace(url,"FinanceNews","http://finance.sina.com.cn")
	Elseif Instr(url,"wwwEladies")>0 then
		urldns=Replace(url,"wwwEladies","http://www.eladies.com.cn")
	Elseif Instr(url,"EduNews")>0 then
		urldns=Replace(url,"EduNews","http://edu.sina.com.cn")
	Elseif Instr(url,"JczsNews")>0 then
		urldns=Replace(url,"JczsNews","http://jczs.sina.com.cn")
	Elseif Instr(url,"NewBBS0")>0 then
		urldns=Replace(url,"NewBBS0","http://newbbs0.sina.com.cn")
	Elseif Instr(url,"AstroNews")>0 then
		urldns=Replace(url,"AstroNews","http://astro.sina.com.cn")
	End if
End function

Function Autolink(strContent,url)
	dim re ,Article
	set re = New RegExp	
	re.IgnoreCase = True
	re.Global = True
	Article = GetContent(strContent,"<div id=article>","</div>",0)
	If Instr(Article,"<br clear=all>")>0 then
	Article = GetContent(Article,"<br clear=all>","",8)
	Article = Article & "</td></tr>"
	End if
	If Instr(Article,"<!--画中画广告开始-->")>0 and Instr(Article,"<!--画中画广告结束-->")>0 then
	Article = Left(Article,Instr(Article,"<!--画中画广告开始-->")-1)&"<table align=left><tr><td>"& AdsURL &"</td></tr></table>"&Right(Article,Len(Article)-Instr(Article,"<!--画中画广告结束-->")-14)
	End if
	Article = Article & "</table>"
	If Instr(url,"http://ent.")>0 then
		Article = Replace(Article,"<table width=604 border=0 cellpadding=0 cellspacing=0>","<table width=100% border=0 cellpadding=0 cellspacing=0>")
		Article = Replace(Article,"<img src=http://image2.sina.com.cn/ent/news_rou.gif width=30 height=53>","")
		Article = Replace(Article,"<img src=http://image2.sina.com.cn/ent/images/c.gif width=1 height=1>","<hr size=1 bgcolor=#d9d9d9>")
		Article = Replace(Article,"bgcolor=#fff3ff","")											'去掉背景颜色
		Article = Replace(Article,"bgcolor=#bd6bff","")											'去掉背景颜色
		Article = Replace(Article,"width=603","width=100% ")										'把一个定义了大小的表格放到最大
		Article = Replace(Article,"width=554","width=100% ")										'把一个定义了大小的表格放到最大
		Article = Replace(Article,"width=472","")													'把一个定义了大小的表格放到最大
		Article = Replace(Article,"width=102","")													'把一个定义了大小的表格放到最大
		Article = Replace(Article,"src=/","src=http://ent.sina.com.cn/")							'修改图片的连接地址
		Article = Replace(Article,"src=""/","src=""http://ent.sina.com.cn/")						'修改图片的连接地址
		Article = Replace(Article,"href=/","href=show.asp?url=EntNews/")							'修改图片的连接地址
		Article = Replace(Article,"href=http://ent.sina.com.cn/","href=show.asp?url=EntNews/")	'修改图片的连接地址
		Article = Replace(Article,"href=""/","href=""show.asp?url=EntNews/")						'修改图片的连接地址
		Article = Replace(Article,"href=""http://ent.sina.com.cn/","href=""show.asp?url=EntNews/")'修改图片的连接地址
		Article = Article&"</td></tr></table>"											'修补HTML的结构错误
	End if
	re.Pattern = "\<OBJECT(.[^\[]*)\<\/OBJECT>"
	Article = re.Replace(Article,"")						'去掉画中画广告
	Article = Replace(Article,"<a href=http://news.sina.com.cn/photo/>点击此处查看其它图片</a>","")
	
	NewsType = GetContent(url,".com.cn","",6)

	
	If Instr(url,"http://ent.")<=0 then
		link = GetContent(strContent,"<div id=links>","</div>",0)
		link = GetContent(link,"相关链接","",2)
		link = GetContent(link,"<a","",3)
		link = GetContent(link,"</td>","",8)
		link = Replace(link,"href=""/","href="""&NewsType&"/")
		link = Replace(link,"href=/","href="&NewsType&"/")
		link = VirtualURL(link,"show.asp?url=")
		slink= split(link,"</a>")
		link = ""
		For i = 0 to ubound(slink)-1
			tmp = GetContent(slink(i),".shtml","",5)
			tmp = GetContent(tmp,"/","",9)
			If IsNumeric(left(tmp,4)) then
			link = link & slink(i)&"</a>"
			End if
		Next
		If link <> "" then
		link = "<p><table width=100% border=0 cellpadding=5 cellspacing=1 bgcolor=bbbbbb ><tr><td bgcolor=eeeeee class=title12 >相关链接</td></tr><tr><td bgcolor=eeeeee class=title14>"&link&"</td></tr></table>"
		End if 
	End if
	
	Autolink = Article & "<br><div align=right>| <a href=""javascript:doZoom(16)""><u>大</u></a> <a href=""javascript:doZoom(14)""><u>中</u></a> <a href=""javascript:doZoom(12)""><u>小</u></a> | <a href=""javascript:print()""><u>打印</u></a> | <a href=""javascript:window.close()""><u>关闭</u></a> |</div><br>" & AdsPlus & link
	
	Exit function

	
	
	
	
	
	
	If Instr(url,"http://ent.")>0 then		'影音和娱乐新闻的界面
		strContent = GetContent(strContent,"<div id=article>","</div>",0)
		strContent = GetContent(strContent,"<center></center>","",8)
		strContent = Replace(strContent,"<table width=604 border=0 cellpadding=0 cellspacing=0>","<table width=100% border=0 cellpadding=0 cellspacing=0>")
		strContent = Replace(strContent,"<img src=http://image2.sina.com.cn/ent/news_rou.gif width=30 height=53>","")
		strContent = Replace(strContent,"<img src=http://image2.sina.com.cn/ent/images/c.gif width=1 height=1>","<hr size=1 bgcolor=#d9d9d9>")
		strContent = Replace(strContent,"bgcolor=#fff3ff","")											'去掉背景颜色
		strContent = Replace(strContent,"bgcolor=#bd6bff","")											'去掉背景颜色
		strContent = Replace(strContent,"width=603","width=100% ")										'把一个定义了大小的表格放到最大
		strContent = Replace(strContent,"width=554","width=100% ")										'把一个定义了大小的表格放到最大
		strContent = Replace(strContent,"width=472","")													'把一个定义了大小的表格放到最大
		strContent = Replace(strContent,"width=102","")													'把一个定义了大小的表格放到最大
		strContent = Replace(strContent,"src=/","src=http://ent.sina.com.cn/")							'修改图片的连接地址
		strContent = Replace(strContent,"src=""/","src=""http://ent.sina.com.cn/")						'修改图片的连接地址
		strContent = Replace(strContent,"href=/","href=show.asp?url=EntNews/")							'修改图片的连接地址
		strContent = Replace(strContent,"href=http://ent.sina.com.cn/","href=show.asp?url=EntNews/")	'修改图片的连接地址
		strContent = Replace(strContent,"href=""/","href=""show.asp?url=EntNews/")						'修改图片的连接地址
		strContent = Replace(strContent,"href=""http://ent.sina.com.cn/","href=""show.asp?url=EntNews/")'修改图片的连接地址
		strContent = strContent&"</table></td></tr></table>"											'修补HTML的结构错误
	Elseif Instr(url,"http://eladies.")>0 or Instr(url,"http://www.eladies.")>0 then
		If Instr(strContent,"<tr valign=top><td width=602>")>0 then
			strContent = GetContent(strContent,"<tr valign=top><td width=602>","</td><td width=10></td></tr>",1)
			re.Pattern = "\<!--PipAD:start-->(.[^\[]*)\<!--PipAD:end-->"	
			strContent = re.Replace(strContent,"")						'去掉画中画广告
			strContent=Replace(strContent,"width=470","width=100% ")
			strContent=strContent&"</td></tr></table></table>"
		End if
		If Instr(strContent,"<tr><td class=f21")>0 then
			strContent = GetContent(strContent,"<tr><td class=f21","</td><td width=15></td></tr>",1)
			re.Pattern = "\<!--PipAD:start-->(.[^\[]*)\<!--PipAD:end-->"	
			strContent = re.Replace(strContent,"")						'去掉画中画广告
			strContent="<table>"&strContent&"</table>"
		End if
	Elseif Instr(url,"newbbs0.sina.com.cn")>0 then
		strContent = GetContent(strContent,"<div id=article>","</div>",0)
	Else									'其他分类新闻的界面
		strContent = GetContent(strContent,"<th class=f24>","<br clear=all>",1)
		strContent = "<table width=100% border=0 cellspacing=0 cellpadding=10 align=center ><tr>"&strContent&"</td></tr></table>"						'修补HTML的结构错误
	End if
	strContent = Replace(strContent,GetContent(strContent,"<!--NEWSZW_HZH_BEGIN-->","<!--NEWSZW_HZH_END-->",1),"")
	If Instr(strContent,"<!--画中画广告开始-->")>0 and Instr(strContent,"<!--画中画广告结束-->")>0 then
	strContent = Left(strContent,Instr(strContent,"<!--画中画广告开始-->"))&Right(strContent,Len(strContent)-Instr(strContent,"<!--画中画广告结束-->"))
	End if
	strContent = Replace(strContent,"