⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 function.asp

📁 都市新闻系统 v1.0(新浪小偷)
💻 ASP
字号:
🔍 
<%
Dim wstr,str,url,start,over,NewsClass,i,Count,NewsType
Dim n0,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10
Dim jczs,TiYu,GuoNei,KeJi,CaiJing,SheHui,QiChe,GuoJi,YingYin,WenJiao,NvXing,News,NewsImg,NewsTitle,ArrayNewsImg,ArrayNewsTitle
n0=0
n1=0
n2=0
n3=0
n4=0
n5=0
n6=0
n7=0
n8=0
n9=0
n10=0

on error resume next

	Function getHTTPPage(url) 
	'	on error resume next 
		dim http 
		set http=Server.createobject("Microsoft.XMLHTTP") 
		Http.open "GET",url,false 
		Http.send() 
		if Http.readystate<>4 then
			exit function 
		end if 
		getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
		set http=nothing
		if err.number<>0 then err.Clear  
	End function
		
	Function BytesToBstr(body,Cset)
		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 = Cset
		BytesToBstr = objstream.ReadText 
		objstream.Close
		set objstream = nothing
	End Function
	
	Function Newstring(wstr,strng)
		Newstring=Instr(wstr,strng)
	End Function
	
	Function LeftNews(strng,NewsLength,NewsTime)
		If NewsTime<>True then
			Left_0=Instr(strng,"</a>")+3
			TheRed=Instr(strng,"<font color=#ff0000>")
			If TheRed>0 then
				Left_1=Instr(strng,"<font color=#ff0000>")+20
				Left_2=Instr(strng,"</font>")
				If Left_1+NewsLength>=Left_2 then
					LeftNews=Left(strng,Left_0)
				Else
					LeftNews=Left(strng,Left_1+NewsLength)&NewsPoints&"</font></a>"
				End if
			Else
				Left_1=Instr(strng,"_blank>")+7
				Left_2=Instr(strng,"</a>")
				If Left_1+NewsLength>=Left_2 then
					LeftNews=Left(strng,Left_0)
				Else
					LeftNews=Left(strng,Left_1+NewsLength)&NewsPoints&"</a>"
				End if
			End if
		Else
			LeftNews=strng
		End if
	End Function
	
	Function FormatDate(theDate,n)
		FormatDate=Year(theDate)&n&AddZero(Month(theDate),2)&n&AddZero(Day(theDate),2)
	End Function
	
	Function AddZero(m,n)		'添加0
		If Len(m)<n then
		AddZero=string(n-Len(m),"0")&m
		Else
		AddZero=m
		End if
	End function
		
	Function LL(strng)
	LL=Left(strng,Instr(strng,"</a>")+3)
	End function
	
	Function FormatDate11(theDateaaa,n)
		FormatDate11=Year(theDateaaa)&n&AddZero(Month(theDateaaa),2)&n&AddZero(Day(theDateaaa),2)
	End Function

	
	Function HiddenURL(url)
		dim re
		set re = New RegExp	
		re.IgnoreCase = True
		re.Global = True
			re.Pattern = "news"	
			strContent = re.Replace(strContent,"NewsNews")						'去掉画中画广告
		HiddenURL=Replace(url,"http://tech.sina.com.cn","TechNews")
		HiddenURL=Replace(url,"http://sports.sina.com.cn/","SportsNews")
		HiddenURL=Replace(url,"http://ent.sina.com.cn/","EntNews")
		HiddenURL=Replace(url,"http://eladies.sina.com.cn/","EladiesNews")
		HiddenURL=Replace(url,"http://jczs.sina.com.cn/","jczs")
	End function
		
Sub NewsList(NewsClass)
		theDateaaa=Date()
      url="http://news.sina.com.cn/old1000/news1000_"&FormatDate11(theDateaaa,"")&".shtml"	'新闻内容所在的页面，不要改。

	wstr=getHTTPPage(url) 											'取得页面内容
		start=Newstring(wstr,"<!--新闻开始-->")
		over=Newstring(wstr,"<!--新闻结束-->")
		wstr=mid(wstr,start+11,over-start-11)
		wstr=replace(wstr,"href=""","href=""show.asp?url=")
		wstr=replace(wstr,"<ul>","")
		wstr=trim(replace(wstr,"</ul>",""))							'完成对页面内容的截取加工
		wstr=Replace(wstr,"http://news.sina.com.cn","NewsNews")
		wstr=Replace(wstr,"http://tech.sina.com.cn","TechNews")
		wstr=Replace(wstr,"http://sports.sina.com.cn","SportsNews")
		wstr=Replace(wstr,"http://ent.sina.com.cn","EntNews")
		wstr=Replace(wstr,"http://eladies.sina.com.cn","EladiesNews")
		wstr=Replace(wstr,"http://jczs.sina.com.cn","jczs")
		wstr=Replace(wstr,"http://auto.sina.com.cn","AutoNews")
		wstr=Replace(wstr,"http://finance.sina.com.cn","FinanceNews")
		wstr=Replace(wstr,"http://www.eladies.com.cn","wwwEladies")
'		Set fs = CreateObject("Scripting.FileSystemObject") 
'		Set f = fs.CreateTextFile(server.mappath("mynews.htm"))		
'		f.writeLine wstr 
'		f.close 
'		set f = nothing 
'		set fs = nothing
		str=split(wstr,"<li>")
		If NewsClass<>"" then										'对分类新闻的截取
			for i=1 to Ubound(str)
				If Left(str(i),4)="["&NewsClass&"]" then
					News=News&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
				End if
			next
		Else														'对所有新闻进行分类
			for i=1 to Ubound(str)
				If     Left(str(i),4)="[军事]" then
					If n0<NewsMax then jczs=jczs&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n0=n0+1
				Elseif Left(str(i),4)="[体育]" then
					If n1<NewsMax then TiYu=TiYu&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n1=n1+1
				Elseif Left(str(i),4)="[国内]" then
					If n2<NewsMax then GuoNei=GuoNei&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n2=n2+1
				Elseif Left(str(i),4)="[科技]" then
					If n3<NewsMax then KeJi=KeJi&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n3=n3+1
				Elseif Left(str(i),4)="[财经]" then
					If n4<NewsMax then CaiJing=CaiJing&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n4=n4+1
				Elseif Left(str(i),4)="[社会]" then
					If n5<NewsMax then SheHui=SheHui&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n5=n5+1
				Elseif Left(str(i),4)="[汽车]" then
					If n6<NewsMax then QiChe=QiChe&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n6=n6+1
				Elseif Left(str(i),4)="[国际]" then
					If n7<NewsMax then GuoJi=GuoJi&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n7=n7+1
				Elseif Left(str(i),4)="[影音]" then
					If n8<NewsMax then YingYin=YingYin&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n8=n8+1
				Elseif Left(str(i),4)="[文教]" then
					If n9<NewsMax then WenJiao=WenJiao&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n9=n9+1
				Elseif Left(str(i),4)="[女性]" then
					If n10<NewsMax then NvXing=NvXing&"<li>"&LeftNews(str(i),NewsLength,NewsTime)
					n10=n10+1
				End if
				If Instr(str(i),"图文")>0 then
					TuWen=TuWen&"<li>"&LeftNews(str(i),8,False)
				End if
			next
		End if
		Erase str
End sub

Sub NewsImage()
	If Hour(Now())>17 then
		theDate=Date()
	Else
		theDate=DateAdd("d", -1, Date() )
	End if
	url="http://news.sina.com.cn/photo/imp/"&FormatDate(theDate,"-")&"/index.shtml"
	wstr=getHTTPPage(url) 
		start=newstring(wstr,"<!-- 图片列表 begin -->")
		over=newstring(wstr,"<!-- 图片列表 end -->")
		wstr=mid(wstr,start+20,over-start-20)
		wstr=Replace(wstr,"href=http://news.sina.com.cn","href=show.asp?url=NewsNews")
		wstr=Replace(wstr,"href=http://tech.sina.com.cn","href=show.asp?url=TechNews")
		wstr=Replace(wstr,"href=http://sports.sina.com.cn","href=show.asp?url=SportsNews")
		wstr=Replace(wstr,"href=http://ent.sina.com.cn","href=show.asp?url=EntNews")
		wstr=Replace(wstr,"href=http://eladies.sina.com.cn","href=show.asp?url=EladiesNews")
		wstr=Replace(wstr,"href=http://auto.sina.com.cn","href=show.asp?url=AutoNews")
		wstr=Replace(wstr,"href=http://finance.sina.com.cn","href=show.asp?url=FinanceNews")
		wstr=Replace(wstr,"href=http://www.eladies.com.cn","href=show.asp?url=wwwEladies")
		wstr=replace(wstr,"border=2","border=1")
		wstr=replace(wstr,"src=/","src=http://news.sina.com.cn/")
		
		str=split(wstr,"<a")
		Count=Ubound(str)
		for i=1 to Count
			If Instr(str(i),"更多图片>>")<=0 then
				If Instr(LL(str(i)),"<img")>0 then
				NewsImg=NewsImg&"⊙<a"&LL(str(i))
				Else
				NewsTitle=NewsTitle&"⊙<a"&LL(str(i))
				End if
			End if
		next
		Erase str
'		Set fs = CreateObject("Scripting.FileSystemObject") 
'		Set f = fs.CreateTextFile(server.mappath("mynews.htm"))		
'		f.writeLine wstr 
'		f.close 
'		set f = nothing 	
	ArrayNewsImg=split(NewsImg,"⊙")
	ArrayNewsTitle=split(NewsTitle,"⊙")
End sub

Function Autolink(strContent,url)
	dim re
	set re = New RegExp	
	re.IgnoreCase = True
	re.Global = True
	If Instr(url,"http://ent.")>0 then		'影音和娱乐新闻的界面
		start=Newstring(strContent,"<table width=604")				'截取的起点
		over=Newstring(strContent,"<center></center>")				'截取的终点
		strContent=mid(strContent,start,over-start)					'截取新闻
		re.Pattern = "\<table border=0(.[^\[]*)\<\/table>"	
		strContent = re.Replace(strContent,"")						'去掉画中画广告
		strContent = Replace(strContent,"?/p>","")					'去掉页面中一个奇怪的错误
		strContent = Replace(strContent,"<table width=604 border=0 cellpadding=0 cellspacing=0>","")
		strContent = Replace(strContent,"</table></table>","")
		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 = "<table width=100% border=0 cellspacing=0 cellpadding=10 align=center >"&strContent&"</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
			start=Newstring(strContent,"<tr valign=top><td width=602>")+30			'截取的起点
			over=Newstring(strContent,"</td><td width=10></td></tr>")				'截取的终点
			strContent=mid(strContent,start,over-start)	
			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
			start=Newstring(strContent,"<tr><td class=f21")			'截取的起点
			over=Newstring(strContent,"</td><td width=15></td></tr>")+29				'截取的终点
			strContent=mid(strContent,start,over-start)	
			re.Pattern = "\<!--PipAD:start-->(.[^\[]*)\<!--PipAD:end-->"	
			strContent = re.Replace(strContent,"")						'去掉画中画广告
			strContent="<table>"&strContent&"</table>"
		End if
	Else									'其他分类新闻的界面
		start=Newstring(strContent,"<th class=f24>")				'截取的起点
		over=Newstring(strContent,"<br clear=all>")					'截取的终点
		strContent=mid(strContent,start,over-start)					'截取新闻
		re.Pattern = "\<table border=0(.[^\[]*)\<\/table>"
		strContent = re.Replace(strContent,"")						'去掉画中画广告
		strContent = Replace(strContent,"?/p>","")					'去掉页面中一个奇怪的错误
		strContent = "<table width=100% border=0 cellspacing=0 cellpadding=10 align=center >"&strContent&"</td></tr></table>"						'修补HTML的结构错误
	End if
	re.Pattern = "src=([0-9])"	
	strContent = re.Replace(strContent,"src="&Left(url,InstrRev(url,"/"))&"$1")	'将相对路径的连接变成绝对路径
	re.Pattern = "src=\/"	
	strContent = re.Replace(strContent,"src="&NewsType&"/")						'将虚拟路径的连接变成绝对路径(不带 " 的)
	re.Pattern = "src=""\/"	
	strContent = re.Replace(strContent,"src="""&NewsType&"/")					'将虚拟路径的连接变成绝对路径(带 " 的)
	Autolink=strContent
End Function

Function urldns(url)
	If Instr(url,"NewsNews")>0 then
		urldns=Replace(url,"NewsNews","http://news.sina.com.cn")
		NewsType="http://news.sina.com.cn"
	End if
	If Instr(url,"TechNews")>0 then
		urldns=Replace(url,"TechNews","http://tech.sina.com.cn")
		NewsType="http://tech.sina.com.cn"
	End if
	If Instr(url,"SportsNews")>0 then
		urldns=Replace(url,"SportsNews","http://sports.sina.com.cn")
		NewsType="http://sports.sina.com.cn"
	End if
	If Instr(url,"EntNews")>0 then
		urldns=Replace(url,"EntNews","http://ent.sina.com.cn")
		NewsType="http://ent.sina.com.cn"
	End if
	If Instr(url,"EladiesNews")>0 then
		urldns=Replace(url,"EladiesNews","http://eladies.sina.com.cn")
		NewsType="http://eladies.sina.com.cn"
	End if
	If Instr(url,"AutoNews")>0 then
		urldns=Replace(url,"AutoNews","http://auto.sina.com.cn")
		NewsType="http://auto.sina.com.cn"
	End if
	If Instr(url,"FinanceNews")>0 then
		urldns=Replace(url,"FinanceNews","http://finance.sina.com.cn")
		NewsType="http://finance.sina.com.cn"
	End if
	If Instr(url,"wwwEladies")>0 then
		urldns=Replace(url,"wwwEladies","http://www.eladies.com.cn")
		NewsType="http://www.eladies.com.cn"
	End if
	If Instr(url,"jczs")>0 then
		urldns=Replace(url,"jczs","http://jczs.sina.com.cn")
		NewsType="http://jczs.sina.com.cn"
	End if

End function
%>

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -