📄 ok22yl.asp

📁 小俊家园新闻采集器小俊家园新闻采集器小俊家园新闻采集器
💻 ASP
字号:
<%@ LANGUAGE = VBScript %>
<%Admin="news"%>
<!--#include file="check.asp"-->
<!--#include file="inc/config.asp"-->
<!--#include file="ok22_xwcj_inc.asp"-->
<html>
<head>
<title>新浪娱乐新闻采集插件</title>
<META http-equiv=Content-Type content="text/html; charset=gb2312">
<LINK href="inc/admin.css" type=text/css rel=StyleSheet>
<META content="MSHTML 6.00.2800.1126" name=GENERATOR>
</HEAD>
<body onkeydown=return(!(event.keyCode==78&&event.ctrlKey))>
<%
if session("adminlogin")<>sessionvar then
  Response.Write("<script language=javascript>alert('你尚未登录，或者超时了！请重新登录');this.top.location.href='admin.asp';</script>")
  response.end
else
Dim Action,StartDate,EndDate,Conn,DbPath,tmpConn,Url,Html,Sqlstr,Rs
DbPath = "#ok22xw.mdb"  
DataConn
Action = trim(Request("Action"))
If Action = "" Then 
	Call Default()
ElseIf Action = "Get_List" Then 
	response.write "<br><center><font color=#0000F0>新浪娱乐新闻采集插件</font><br>"
	response.write "<br>正在搜集新闻列表......<br>"
	Call Main()
ElseIf Action = "Save" Then
	response.write "<br><center><font color=#0000F0>新浪娱乐新闻采集插件</font><br>"
	response.write "<br>正在将搜集到的文章入库......<br>"
	response.write "<br>未看到完成提示，请不要刷新本页面。<br><br>"
	Call WriteData()
End If    
End if

sub Default()
%>
<form name="form1" method="post" action="ok22yl.asp?Action=Get_List">
<table align="center" width="98%" align="center" border="1" cellspacing="0" cellpadding="4" class=Hxcmsbk style="border-collapse: collapse">
<tr> 
<td colspan="4" class=Hxcmsss>新浪娱乐新闻采集插件</font></td>
</tr>
      <tr>
       <td class=Hxcmsqs height=26 align="center">1、采集从当前时间起24小时内新浪娱乐新闻浏览量最高的10-20条。</a></td>
      </tr>
      <tr>
       <td height=26 class=Hxcmsqs><div align="center">
        <input type="submit" name="Submit" value="开始采集娱乐新闻" class=button>
       </div></td>
      </tr>
      <tr> 
        <td class=Hxcmsqs align="center"><a href=".ok22xwcj.asp"><font color=red>返回新闻采集首页</font></a></td>
      </tr>
<tr> 
<td colspan="4" class=Hxcmsss>本插件抓取从当前时间起24小时内新浪新闻各栏目分类浏览量最高的10-20条新闻</font></td>
</tr>
      <tr>
       <td class=Hxcmsds height=26>1、自动采集新浪新闻浏览量最高的新闻分类入库，将新浪新闻变成你自己站点的新闻。<BR>2、抓取从当前时间起24小时内新浪娱乐新闻浏览量最高的10-20条。建议用此法每天采集一次。<BR>3、自动过滤广告以及无用代码。<BR>4、采集过程较占资源，建议你在每天访客少时进行，且每次采集间隔时间要超过一天。
<BR>5、本插件部分代码参考其他小偷类程序由lanxuan重新制作完成，如侵犯到版权问题，请联系本人更正。</td>
      </tr>
  </table>
</form>
<p align="center"><a href="http://www.ah-lanxuan.com"><font color=red>欣蓝网维</font></a> lanxuan QQ：3454625 <p><%
end sub

Function Main()
	StartDate = Trim(Request("StartDate"))
	EndDate = Trim(Request("EndDate"))

	If StartDate = "" Or EndDate = "" Then
		Call GetList(Date)
		Response.Write("<b><font color=""#FF0000"">收集数据完毕，读取数据开始......</font></b>")
		Response.Write"<meta http-equiv=""refresh"" content=""1;url='ok22yl.asp?Action=Save'"">"
	Else
		If IsDate(StartDate) And IsDate(EndDate) Then
			StartDate = Cdate(StartDate)
			EndDate = Cdate(EndDate)
			If DateDiff("d",StartDate, EndDate) >= 0 Then
				Response.Write"<b><font color=""#FF0000"">正在收集" & StartDate & "的数据,请等待......</font></b>"
				Call GetList(Cdate(StartDate))
				StartDate = DateAdd("d", 1, StartDate)
				Response.Write"<meta http-equiv=""refresh"" content=""1;url='ok22yl.asp?Action=Get_List&StartDate="&StartDate&"&EndDate="&EndDate&"'"">"
			Else
				Response.Write("<b><font color=""#FF0000"">收集数据完毕，读取数据开始......</font></b>")
				Response.Write"<meta http-equiv=""refresh"" content=""1;url='ok22yl.asp?Action=Save'"">"
			End If
		Else
			Response.Write("时间格式错误！")
		End If
	End If
End Function

Function WriteData()
	Dim ID,Rs1
	ID = Request("ID")
	If ID = "" Then
		ID = 1
	Else
		ID = ID + 1
	End If
	Response.Write("<b><font color=""#FF0000"">正在生成记录！</font></b>")
		
	Sqlstr = "Select Top 30 * From SinaNews Where IsRead = 0"
	Set Rs1 = Server.CreateObject("Adodb.RecordSet")
	Rs1.Open Sqlstr,tmpConn,1,3
	dim num
	num=0
	If Not Rs1.Eof Then
		Do While Not Rs1.Eof
			Rs1("IsRead") = 1
			Rs1.Update
			Call GetDetail(Rs1("sName"))
			Rs1.MoveNext
			num=num+1
			if num>=GetNum then exit do end if
		Loop
		if num>=GetNum then
			Response.Write("<b><font color=""#FF0000"">生成数据结束！</font></b>")
		Response.Write("<br><br><b><a href=ok22xwcj.asp>返回新闻采集首页</font></a></b>")
			Response.end
		end if
		Response.Write"<meta http-equiv=""refresh"" content=""1;url='ok22yl.asp?Action=Save&ID="&ID&"'"">"
	Else
		Response.Write("<b><font color=""#FF0000"">生成数据结束！</font></b>")
		Response.Write("<br><br><b><a href=ok22xwcj.asp>返回新闻采集首页</font></a></b>")
	End If
	Rs1.Close
	Set Rs1 = Nothing
End Function

Function GetList(strDate)
	strDate = DateAdd("d", -1, strDate)
	Sqlstr = "Delete From SinaNews Where IsRead = 0 And sDate = #"& strDate &"#"
	Url = "http://news.sina.com.cn/hotnews/index.shtml"
	Html = getHTTPPage(Url)
	If instr(Html,"<!--标准尾-->") > 0 Then
		ImportHtml = Split(Html,"<!--标准尾-->")
		Html = ImportHtml(0)
	End If 
	Set objRegExp = New Regexp'设置配置对象 
	objRegExp.IgnoreCase = True'忽略大小写 
	objRegExp.Global = True'设置为全文搜索 
	
	objRegExp.Pattern = "a href=http://ent.sina.com.cn/.+?html"  '搜索字符串
	Set Matches=objRegExp.Execute(Html)'开始执行搜索 
	
	For Each Match in Matches 
		Result = replace(Match.Value,"a href=","")
		Sqlstr = "Select sName From SinaNews Where sName = '"&Result&"'"
		Set Rs1 = tmpConn.Execute(Sqlstr)
		If Rs1.Bof Or Rs1.Eof Then
			Rs1.Close
			Set Rs1 =Nothing
			Sqlstr = "Insert Into SinaNews (sName,sDate,IsRead) Values('"&Result&"','"&Cdate(strDate)&"',0)"
			tmpConn.Execute(Sqlstr)
		Else
			Rs1.Close
			Set Rs1 =Nothing
		End If
	Next 
End Function

Function GetDetail(ID)
	On Error Resume Next
	Dim Title,BigClass,SmallClass,Content
	Dim Tag,arrTag
	Url = "" & ID
	Html = getHTTPPage(Url)
	ArrHtml = Split(Html,"</head>")
	Tag = "||<!--位置导航开始-->||<!--位置导航结束-->||<!--正文内容开始-->||<!--正文内容结束-->"
	arrTag = Split(Tag,"||")
	For j = 1 To Ubound(arrTag)
		If Instr(ArrHtml(1),arrTag(j)) = 0 Then
			Exit Function
		End If
	Next
	betw = instr(ArrHtml(1),"<!--位置导航开始-->")-instr(ArrHtml(1),"<!--位置导航结束-->") 
	first = instr(ArrHtml(1),"<!--位置导航开始-->")
	ClassHtml = Mid(ArrHtml(1),first,abs(betw))
	ArrClass = Split(ClassHtml,"</a>")
	Set objRegExp = New Regexp'设置配置对象 
	objRegExp.IgnoreCase = True'忽略大小写 
	objRegExp.Global = True'设置为全文搜索 
	
	objRegExp.Pattern = "<h1>.+?</h1>"  '搜索字符串
	Set Matches=objRegExp.Execute(ArrHtml(1))'开始执行搜索 
	
	For Each Match in Matches 
		Title = Match.Value
		Title = replace(Title,"<h1>","")
		Title = replace(Title,"</h1>","")
		Exit For
	Next
	
	betw = instr(ArrHtml(1),"<!--正文内容开始-->")-instr(ArrHtml(1),"<!--正文内容结束-->") 
	first = instr(ArrHtml(1),"<!--正文内容开始-->")
	Content = Mid(ArrHtml(1),first,abs(betw))
	Content = Replace(Content,"<!--正文内容开始-->","")
	Content = Replace(Content,"<p>","")
	Content = Replace(Content,"</P>","")
	Content = Replace(Content,"<CENTER>","")
	Content = Replace(Content,"</CENTER>","")
	Content = Replace(Content,"<B>","")
	Content = Replace(Content,"</B>","")
	Content = Replace(Content,"<TD></TR>","<TD></TD></TR>")
	Content = "<font class=f14>"&Content
	Content = Content&"</font>"
	If ArrClass(2) = "" Or Err Then
		Err.Clear
		Exit Function
	End	If
	
	Set rs=Server.Createobject("Adodb.Recordset")
	Sqlstr="Select * FROM news"
	rs.Open Sqlstr,Conn,1,3
	rs.Addnew
	rs("cat_id")=ok22_yl_id
	rs("news_title")=Title
	rs("news_Content")=Content
	rs("news_keyword")=ok22yl
	rs("news_author")="佚名"
	rs("news_ahome")=ok22ahome
	rs("news_count")=ok22count
	rs.Update
	rs.Close
	Set rs=Nothing
	
End Function

Sub DataConn
	'On Error Resume Next
	Dim strConn
		If EnableDataBaseCache = 1 Then	'ACCESS数据库使用数据库缓冲
			If IsObject(Application("Conn"))=False Then
				Set Conn = Server.Createobject("Adodb.Connection")
				strConn="Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & Server.Mappath(DataBaseName)
				Conn.Open strConn
				Application.Lock
				Set Application("Conn") = Conn
				Application.UnLock
			Else
				Set Conn = Application("Conn")
			End If
			If IsObject(Application("Conn"))=False Then
				Set tmpConn = Server.Createobject("Adodb.Connection")
				strConn="Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & Server.Mappath(DbPath)
				tmpConn.Open strConn
				Application.Lock
				Set Application("tmpConn") = tmpConn
				Application.UnLock
			Else
				Set tmpConn = Application("tmpConn")
			End If
		Else	'ACCESS数据库不使用数据库缓冲
			Set Conn = Server.Createobject("Adodb.Connection")
			strConn="Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & Server.Mappath(DataBaseName)
			Conn.Open strConn
			Set tmpConn = Server.Createobject("Adodb.Connection")
			strConn="Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & Server.Mappath(DbPath)
			tmpConn.Open strConn
		End If

	If Err Then
		Err.Clear
		Set Conn=Nothing
		Set tmpConn = Nothing
		Response.Write "数据库连接错误!"
		Response.End
	End	If
End Sub

Function getHTTPPage(url)
	Set Http=server.createobject("MSXML2.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
%>
</body></html>
💿 文件大小 59 K
👤 上传用户 wjm197811
📂 所属分类其他
🏷️ 相关标签

#家 #新闻 #采集器
⌨️ 快捷键说明

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