📄 collecting.asp
字号:
Exit Function
end if
Dim BLinkHeadSetting,BLinkFootSetting
BLinkHeadSetting = False
BLinkFootSetting = False
If Instr(LinkHeadSetting,"[变量]")<=0 Then
BLinkHeadSetting = True
elseif Instr(LinkFootSetting,"[变量]")<=0 Then
BLinkFootSetting = True
End If
If InStr(ResponseAllStr,ListHeadSetting)>0 And InStr(ResponseAllStr,ListFootSetting) Then
NewsListStr = GetOtherContent(ResponseAllStr,ListHeadSetting,ListFootSetting)
Else
NewsListStr = ResponseAllStr
End If
If BLinkHeadSetting Then
NewsListStr = Mid(NewsListStr,Instr(NewsListStr,LinkHeadSetting)+len(LinkHeadSetting))
NewsListStrArray = Split(NewsListStr,LinkHeadSetting)
elseif BLinkFootSetting Then
NewsListStr = Left(NewsListStr,InstrRev(NewsListStr,LinkFootSetting))
NewsListStrArray = Split(NewsListStr,LinkFootSetting)
End If
For n = 0 to UBound(NewsListStrArray)
Dim tempURL
tempURL=LoseHtml(FormatUrl(GetOtherContent(LinkHeadSetting&NewsListStrArray(n),LinkHeadSetting,LinkFootSetting),CollectObjURL))
If ResumeNewsURL = tempURL Then
Exit For
ElseIf n>=UBound(NewsListStrArray) Then
AllNewsNumber = AllNewsNumber+n
CollectPageNumber = CollectPageNumber + 1
CollectStartLocation = 0
CollectedPageURL = ObjURL
Exit Function
End If
Next
CollectStartLocation = n+1
If IsReverse="1" then '倒序采集
Dim TempArr,j
TempArr=NewsListStrArray
For j =0 to UBound(NewsListStrArray)
NewsListStrArray(j)=TempArr(UBound(NewsListStrArray)-j)
Next
End If
For i = CollectStartLocation to CollectStartLocation + CollectMaxOfOnePage - 1
if i > UBound(NewsListStrArray) Then
CollectPageNumber = CollectPageNumber + 1
CollectStartLocation = 0
CollectedPageURL = ObjURL
Exit Function
end If
AllNewsNumber = AllNewsNumber + 1
If BLinkHeadSetting Then
TempArray = GetOtherContent(LinkHeadSetting&NewsListStrArray(i),LinkHeadSetting,LinkFootSetting)
elseif BLinkFootSetting Then
TempArray = GetOtherContent(NewsListStrArray(i)&LinkFootSetting,LinkHeadSetting,LinkFootSetting)
End If
if TempArray <> "" Then
NewsLinkStr = LoseHtml(FormatUrl(TempArray,CollectObjURL))
Set RsCheckNewsObj = CollectConn.Execute("Select * from FS_News where Links='" & NewsLinkStr & "'")
if RsCheckNewsObj.Eof then
NewsPageStr = GetPageContent(NewsLinkStr)
if NewsPageStr <> False then
TitleStr = LoseHtml(GetOtherContent(NewsPageStr,PageTitleHeadSetting,PageTitleFootSetting))
Set RsCheckNewsObj = CollectConn.Execute("Select * from FS_News where Links='" & NewsLinkStr & "'")
ContentStr = GetOneNewsContent(NewsPageStr,NewsLinkStr)
ContentStr = ReplaceContentStr(ContentStr)
ContentStr = ReplaceIMGRemoteUrl(ContentStr,SaveIMGPath,AvailableDoMain,DummyDir,NewsLinkStr,SaveRemotePic)
if TitleStr = "" then
ReturnValue = GetOneNewsReturnValue(2,i + 1,"","",NewsLinkStr) & ReturnValue
elseif ContentStr = "" then
ReturnValue = GetOneNewsReturnValue(3,i + 1,TitleStr,"",NewsLinkStr) & ReturnValue
else
ReturnValue = GetOneNewsReturnValue(4,i + 1,TitleStr,ContentStr,NewsLinkStr) & ReturnValue
if IsNull(HandSetAuthor) OR (HandSetAuthor = "") then
AuthorStr = LoseHtml(GetOtherContent(NewsPageStr,AuthorHeadSetting,AuthorFootSetting))
else
AuthorStr = HandSetAuthor
end if
if IsNull(HandSetSource) OR (HandSetSource = "") then
SourceStr = LoseHtml(GetOtherContent(NewsPageStr,SourceHeadSetting,SourceFootSetting))
else
SourceStr = HandSetSource
end if
if IsNull(HandSetAddDate) OR Not IsDate(HandSetSource) then
AddDate = LoseHtml(GetOtherContent(NewsPageStr,AddDateHeadSetting,AddDateFootSetting))
else
AddDate = HandSetAddDate
end if
if AddDate <> "" then
if Not IsDate(AddDate) then AddDate = Now
else
AddDate = Now
end if
SaveCollectContent TitleStr,NewsLinkStr,ContentStr,SysClassID,AuthorStr,SourceStr,AddDate
end if
Set RsCheckNewsObj = Nothing
else
ReturnValue = GetOneNewsReturnValue(5,i + 1,"","",NewsLinkStr) & ReturnValue
End If
ElseIf session("ConfirmCollectRevert")<>"ConfirmCollectRevert" Then
session("ConfirmCollectRevert") = "ConfirmCollectRevert"
response.write("<script>if(confirm(""您改变过采集顺序吗？\n如果修改过，请单击确定改回原样再续采！\n没有修改过请单击取消继续！""))window.location=""site.asp""</script>")
End If
End If
Next
CollectStartLocation = i
End Function
Function GetOneNewsContent(FirstPageContent,NewsLinkStr)
'On Error Resume Next
Dim OtherPageNewsLink,OtherPageNewsContentStr,tempSplitArr1,tempSplitArr2
OtherPageNewsContentStr = FirstPageContent
GetOneNewsContent = ReplaceKeyWords(GetOtherContent(FirstPageContent,PagebodyHeadSetting,PagebodyFootSetting))
if IsNull(OtherNewsPageHeadSetting) OR IsNull(OtherNewsPageFootSetting) OR (OtherNewsPageHeadSetting = "") OR (OtherNewsPageFootSetting = "") Then
OtherPageNewsLink = ""
ElseIf InStr(OtherNewsPageHeadSetting,"[2006-3-17AddByChning]")>0 Then
OtherNewsPageHeadSetting = Replace(OtherNewsPageHeadSetting,"[2006-3-17AddByChning]","")
If InStr(OtherPageNewsContentStr,OtherNewsPageHeadSetting)>0 And InStr(OtherPageNewsContentStr,OtherNewsPageFootSetting)>0 Then
tempSplitArr1 = Split(OtherPageNewsContentStr,OtherNewsPageFootSetting)
tempSplitArr2 = Split(tempSplitArr1(0),OtherNewsPageHeadSetting)
OtherPageNewsLink = tempSplitArr2(UBound(tempSplitArr2))
Else
OtherPageNewsLink = GetOtherContentFromEnd(OtherPageNewsContentStr,OtherNewsPageHeadSetting,OtherNewsPageFootSetting)
End If
Do While (OtherPageNewsLink <> "")
OtherPageNewsLink = FormatUrl(OtherPageNewsLink,NewsLinkStr)
OtherPageNewsContentStr = GetPageContent(OtherPageNewsLink)
If InStr(OtherPageNewsContentStr,OtherNewsPageFootSetting)>0 And InStr(OtherPageNewsContentStr,OtherNewsPageHeadSetting)>0 Then
tempSplitArr1 = Split(OtherPageNewsContentStr,OtherNewsPageFootSetting)
tempSplitArr2 = Split(tempSplitArr1(0),OtherNewsPageHeadSetting)
OtherPageNewsLink = tempSplitArr2(UBound(tempSplitArr2))
Else
OtherPageNewsLink = GetOtherContentFromEnd(OtherPageNewsContentStr,OtherNewsPageHeadSetting,OtherNewsPageFootSetting)
End If
If OtherPageNewsContentStr<>False Then
GetOneNewsContent = GetOneNewsContent & "[Page]" & ReplaceKeyWords(GetOtherContent(OtherPageNewsContentStr,PagebodyHeadSetting,PagebodyFootSetting))
Else
OtherPageNewsLink = ""
End If
If Err Then
Err.clear
OtherPageNewsLink = ""
End If
Loop
Else
If InStr(OtherPageNewsContentStr,OtherNewsPageFootSetting)>0 And InStr(OtherPageNewsContentStr,OtherNewsPageHeadSetting)>0 Then
tempSplitArr1 = Split(OtherPageNewsContentStr,OtherNewsPageHeadSetting)
tempSplitArr2 = Split(tempSplitArr1(1),OtherNewsPageFootSetting)
OtherPageNewsLink = tempSplitArr2(0)
Else
OtherPageNewsLink = GetOtherContent(OtherPageNewsContentStr,OtherNewsPageHeadSetting,OtherNewsPageFootSetting)
End If
Do While (OtherPageNewsLink <> "")
OtherPageNewsLink = FormatUrl(OtherPageNewsLink,NewsLinkStr)
OtherPageNewsContentStr = GetPageContent(OtherPageNewsLink)
If InStr(OtherPageNewsContentStr,OtherNewsPageFootSetting)>0 And InStr(OtherPageNewsContentStr,OtherNewsPageHeadSetting)>0 Then
tempSplitArr1 = Split(OtherPageNewsContentStr,OtherNewsPageHeadSetting)
tempSplitArr2 = Split(tempSplitArr1(1),OtherNewsPageFootSetting)
OtherPageNewsLink = tempSplitArr2(0)
Else
OtherPageNewsLink = GetOtherContent(OtherPageNewsContentStr,OtherNewsPageHeadSetting,OtherNewsPageFootSetting)
End If
If OtherPageNewsContentStr<>False Then
GetOneNewsContent = GetOneNewsContent & "[Page]" & ReplaceKeyWords(GetOtherContent(OtherPageNewsContentStr,PagebodyHeadSetting,PagebodyFootSetting))
Else
OtherPageNewsLink = ""
End If
If Err Then
Err.clear
OtherPageNewsLink = ""
End If
Loop
End If
End Function
Function GetOneNewsReturnValue(CauseIndex,NewsIndex,Title,Content,LinkStr)
Select Case CauseIndex
Case 1 '不允许重名保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>已经采集，在等待审核或者在历史纪录里面</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>标题</strong>： " & Title
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case 2 '标题为空，没有保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>标题为空，没有保存</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case 3 '内容为空，没有保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>内容为空，没有保存</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>标题</strong>： " & Title
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case 4 '成功保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： 采集成功"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>标题</strong>： " & Title
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>内容</strong>： " & Left(LoseHtml(Content),30) & " ......"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
CollectOKNumber = CollectOKNumber + 1
Case 5 '不能够读取新闻目标页面
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>不能够读取新闻目标页面</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case else
End Select
End Function
Function SaveCollectContent(Title,Links,Content,ClassID,Author,SourceString,AddDate)
Dim RsNewsObj,RsTempObj
Set RsNewsObj = Server.CreateObject("Adodb.RecordSet")
RsNewsObj.Open "Select * from FS_News where 1=0",CollectConn,3,3
RsNewsObj.AddNew
RsNewsObj("Title") = LoseHtml(Title)
RsNewsObj("Links") = Links
RsNewsObj("Content") = Content
RsNewsObj("ContentLength") = Len(Content)
RsNewsObj("AddDate") = AddDate
RsNewsObj("ImagesCount") = 0
RsNewsObj("ClassID") = ClassID
RsNewsObj("SysTemplet") = SysTemplet
RsNewsObj("SiteID") = CollectingSiteID
RsNewsObj("Author") = Left(Author,200)
RsNewsObj("IsLock") = 0
RsNewsObj("History") = 0
RsNewsObj("Source") = Left(SourceString,200)
RsNewsObj.UpDate
RsNewsObj.Close
Set RsNewsObj = Nothing
End Function
Function ReplaceKeyWords(Content)
Dim RsRuleObj,HeadSeting,FootSeting,ReContent,regEx
Set RsRuleObj = CollectConn.Execute("Select * from FS_Rule where SiteID=" & CollectingSiteID)
do while Not RsRuleObj.Eof
HeadSeting = RsRuleObj("HeadSeting")
FootSeting = RsRuleObj("FootSeting")
ReContent = RsRuleObj("ReContent")
if IsNull(FootSeting) or FootSeting = "" then
if HeadSeting <> "" then
Content = Replace(Content,HeadSeting,ReContent)
end if
end if
if Not IsNull(FootSeting) and FootSeting <> "" and Not IsNull(HeadSeting) and HeadSeting <> "" then
Set regEx = New RegExp
regEx.Pattern = HeadSeting & "[^\0]*" & FootSeting
regEx.IgnoreCase = False
regEx.Global = True
'Dim Matches,Match,HaveTF,ShowStr
'HaveTF = False
'Set Matches = regEx.Execute(Content)
'For Each Match in Matches
'ShowStr = ShowStr & Match.Value & "<br>"
'HaveTF = True
'Next
'if HaveTF = True then
'Response.Write(ShowStr)
'Response.End
'end if
if IsNull(ReContent) then
Content = regEx.Replace(Content,"")
else
Content = regEx.Replace(Content,ReContent)
end if
Set regEx = Nothing
end if
RsRuleObj.MoveNext
loop
Set RsRuleObj = Nothing
ReplaceKeyWords = Content
End Function
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -