collectinfo.asp

这个就是受到众人喜爱的许愿墙了

            FoundErr=True
            ErrMsg=ErrMsg & "<br>在截取：" & ListUrl & "的信息列表时发生错误！"
        End If
    End If
	
	If FoundErr<>True Then
   		Arr_InfoListCode=GetArray(ListCode,LinkStartStr,LinkEndStr,False,False)
   		If Arr_InfoListCode="$False$" Then
      		FoundErr=True
      		ErrMsg=ErrMsg & "<br>在分析：" & ListUrl & "信息列表时发生错误！"
   		Else
      		Arr_InfoList=Split(Arr_InfoListCode,"$Array$")
      		For Arr_i=0 to Ubound(Arr_InfoList)
            	Arr_InfoList(Arr_i)=Trim(DefiniteUrl(Arr_InfoList(Arr_i),ListUrl))           
         		Arr_InfoList(Arr_i)=CheckUrl(Arr_InfoList(Arr_i))
      		Next
     	 End If
   	End If
	
	if FoundErr<>True then
		call CollectionInfo()
		CollectInfoAllNum=0
		For Arr_i=0 to Ubound(Arr_InfoList)
			FoundErr = False
			ErrMsg = ""
			CollectInfoAllNum=CollectInfoAllNum+1
			
			IsCollect=False
      		InfoUrl=Arr_InfoList(Arr_i)
			
		    If Response.IsClientConnected Then 
         		Response.Flush 
      		Else 
         		Response.End 
      		End If
			
			'检测是否以采集
         	IsCollect=CheckCollect(InfoUrl)
      		If IsCollect=True Then
        		 FoundErr=True
      		End If
			
			If FoundErr<>True Then
         		InfoCode=GetHttpPage(InfoUrl)
         		If InfoCode="$False$" Then
            		FoundErr=True
            		ErrMsg=ErrMsg & "<br>在获取：" & InfoUrl & "信息源码时发生错误！"
            		Title="获取网页源码失败"
         		End If
      		End If
			
			If FoundErr<>True Then
         		Title=GetBody(InfoCode,TitleStartStr,TitleEndStr,False,False)
         		If Title="$False$" or Title="" then
            		FoundErr=True
            		ErrMsg=ErrMsg & "<br>在分析：" & InfoUrl & "的信息标题时发生错误"
            		Title="<br>标题分析错误" 
         		End If
         		If FoundErr<>True Then
            		Content=GetBody(InfoCode,ContentStartStr,ContentEndStr,False,False)
            		If Content="$False$" or Content="" Then
               			FoundErr=True
               			ErrMsg=ErrMsg & "<br>在分析：" & InfoUrl & "的信息正文时发生错误"
               			Title=Title & "<br>正文分析错误" 
            		End If
         		End If
				
				UpDateTime=Now()
				Author=UserName
				Rank=Rank
			End if
			
			If FoundErr<>True Then
				Call SaveInfo()
				Call SaveHistroy(1)
				
				InfoSuccessNum=InfoSuccessNum+1
         		ErrMsg=ErrMsg & "No:<font color=red>" & InfoSuccessNum+InfoFalseNum & "</font><br>"
         		ErrMsg=ErrMsg & "信息标题："
         		ErrMsg=ErrMsg & "<font color=red>" & Title & "</font><br>"
         		ErrMsg=ErrMsg & "更新时间：" & UpDateTime & "<br>"
        		ErrMsg=ErrMsg & "信息作者：" & Author & "<br>"
         		ErrMsg=ErrMsg & "采集页面：<a href=" & InfoUrl & " target=_blank>" & InfoUrl & "</a><br>"
			Else
         		InfoFalseNum=InfoFalseNum+1
         		If IsCollect=True Then
            		ErrMsg=ErrMsg & "No:<font color=red>" & InfoSuccessNum+InfoFalseNum & "</font><br>"
            		ErrMsg=ErrMsg & "目标信息：<font color=red>"
            		If IsCollect=True Then
               			ErrMsg=ErrMsg & His_Title
            		Else
               			ErrMsg=ErrMsg & InfoUrl
            		End If
            		ErrMsg=ErrMsg & "</font> 的记录已存在，不给予采集。<br>"
            		ErrMsg=ErrMsg & "采集时间：" & His_CollectionTime & "<br>"
            		ErrMsg=ErrMsg & "信息来源：<a href='" & InfoUrl & "' target=_blank>"&InfoUrl&"</a><br>"
            		ErrMsg=ErrMsg & "采集结果："
            		If His_Result=False Then
               			ErrMsg=ErrMsg & "失败"
               			ErrMsg=ErrMsg & "<br>失败原因：" & Title
            		Else
              			ErrMsg=ErrMsg & "成功"
            		End If            
            		ErrMsg=ErrMsg & "<br>提示信息：如想再次采集，请先将该信息的历史记录<font color=red>删除</font><br>"
				End If
				If IsCollect=False Then
            		Call SaveHistroy(0)
         		End If
      		End If
      		Call ShowMsg(ErrMsg)
      		Response.Flush()'刷新	
		Next
	Else
		Call ShowMsg(ErrMsg)
	End If
	
	Session("ListNum")=ListNum
	Session("InfoSuccessNum")=InfoSuccessNum
	Session("InfoFalseNum")=InfoFalseNum
	Session("ArticleID")=ArticleID
	
	Response.Write "<table width=""97%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""TableBorder"">"
	Response.Write "<tr><td height=""22"" colspan=""2"" align=""left"">"
   	Response.Write "数据整理中......<br>"
	Response.Write "</td></tr></table>"
End Sub

Sub SetHistroyCache()
   SqlHistroy ="select NewsUrl,Title,CollectionTime,Result from Histroy"
   Set RsHistroy=Server.CreateObject("adodb.recordset")
   RsHistroy.Open SqlHistroy,ConnHistroy,1,1
   If Not RsHistroy.Eof Then
      Arr_Histroy=RsHistroy.GetRows()
   End If
   RsHistroy.Close
   Set RsHistroy=Nothing

   Dim HistroyCache
   Set HistroyCache=new clsCache
   HistroyCache.name=CacheTemp & "histroy"
   Call HistroyCache.clean()
   If IsArray(Arr_Histroy)=True Then   
      HistroyCache.add Arr_Histroy,Dateadd("n",1000,now)
   End If
End Sub

Sub CollectionInfo()%>
<table width="97%" border="0" align="center" cellpadding="0" cellspacing="1" class="TableBorder">
    <tr>
      <td height="22" colspan="2" aling="left">本次运行：正在采集第1 个项目  <font color=red><%=ProjectName%></font>  的第   <font color=red><%=ListNum-1%></font> 页列表,该列表待采集信息  <font color=red><%=Ubound(Arr_InfoList)+1%></font> 条。
      <br>采集统计：成功采集--<%=InfoSuccessNum%>  条信息，失败--<%=InfoFalseNum%>  条。<a href="collectmanage.asp">停止采集</a>
      </td>
    </tr>
</table>
<%StartTime=Timer()	
End Sub

'==================================================
'过程名：CheckCollect
'作  用：判断是否重复
'参  数：strUrl
'==================================================
Function CheckCollect(strUrl)
    CheckCollect=False
    If IsArray(Arr_Histroy)=True then
        For His_i=0 to Ubound(Arr_Histroy,2)
            If Arr_Histroy(0,His_i)=strUrl Then
                CheckCollect=True
            	His_Title=Arr_Histroy(1,His_i)
            	His_CollectionTime=Arr_Histroy(2,His_i)
            	His_Result=Arr_Histroy(3,His_i)
            	Exit For
         	End If
       Next
   End If
End Function

'==================================================
'过程名：SaveInfo
'作  用：保存文章
'参  数：无
'==================================================
Sub SaveInfo()
   If ArticleID=0 Then
      set rs=server.createobject("adodb.recordset")
      sql="select top 1 ArticleID from Info order by ArticleID desc" 
      rs.open sql,conn,1,1
      If rs.eof and rs.bof then
         ArticleID=1
      Else
         ArticleID=rs("ArticleID")+1
      End If
      rs.close
      set rs=nothing
   Else
      ArticleID=ArticleID+1
   End If
   set rs=server.createobject("adodb.recordset")
   sql="select top 1 * from Info" 
   rs.open sql,conn,1,3
   rs.addnew
   rs("ArticleID")=ArticleID
   rs("ChannelID")=ChannelID
   rs("ClassID")=ClassID
   rs("Title")=Title
   rs("Content")=Content
   rs("Author")=Author
   rs("Rank")=Rank
   rs("UpdateTime")=UpDateTime
   rs.update
   rs.close
   set rs=nothing
End Sub

'==================================================
'过程名：SaveHistroy
'作  用：保存历史记录
'参  数：isStr 采集是否成功
'==================================================
Sub SaveHistroy(isStr)
	SqlHistroy="INSERT INTO Histroy(ProjectID,ChannelID,ClassID,ArticleID,Title,CollectionTime,NewsUrl,Result) VALUES ('" & ProjectID & "','" & ChannelID & "','" & ClassID & "','" & ArticleID & "','" & Title & "','" & UpDateTime & "','" & InfoUrl & "'," & isStr& ")"
    ConnHistroy.Execute(SqlHistroy)
End Sub

'==================================================
'过程名：ShowMsg
'作  用：显示信息
'参  数：Msg 信息内容
'==================================================
Sub ShowMsg(Msg)
   Dim strTemp
   strTemp= "<table width=""97%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" Class=""TableBorder"">"       
   strTemp=strTemp & "<tr><td height=""22"" colspan=""2"" align=""left"" id=""msg"">"
   strTemp=strTemp & Msg
   strTemp=strTemp & "</td></tr></table>"
   Response.Write StrTemp     
End Sub
%>