📄 collect_itemcollecfast.asp
字号:
Else
InfoPageArray = Split(InfoPageArrayCode, "$Array$")
If IsArray(InfoPageArray) = True Then
For Testi = 0 To UBound(InfoPageArray)
InfoPageArray(Testi) = KMCObj.DefiniteUrl(InfoPageArray(Testi), NewsUrl)
NewsPageNextCode = KMCObj.GetHttpPage(InfoPageArray(Testi))
ContentTemp=KMCObj.GetBody(NewsPageNextCode, CsString, CoString, False, False)
NewsNextPageStr = KMCObj.GetBody(NewsPageNextCode, NPsString, NPoString, False, False)
if NewsNextPageStr="Error" Then '载取分页字符串没成功时，改变结束标记重新载取
NewsNextPageStr=KMCObj.GetBody(ContentTemp, NPsString, CoString, False, False)
End IF
IF NewsPageNext<>"Error" Then
ContentTemp=Replace(ContentTemp,NewsNextPageStr,"") '替换分页部分
End IF
If ContentTemp = "Error" Then
Exit For
Else
PageNum = PageNum + 1
IF PaginationType=0 Then ' 不分页
Content=Content&ContentTemp
ElseIF PaginationType=1 Then '自动分页
Content=Content&ContentTemp
ElseIf PaginationType=2 Then '原文分页方式
Content = Content & "[NextPage]" & ContentTemp
End IF
End If
Next
IF PaginationType=1 Then '调用自动分页函数
Content=KMCObj.SplitNewsPage(Content,MaxCharPerPage)
End IF
Else
FoundErr = True
ErrMsg = ErrMsg & "<br><li>在分析：" & NewsUrl & "新闻列表时发生错误！</li>"
End If
End If
End if
Content=Replace(Content,NewsPageNext,"")
End If
'过滤
Call Filters
Title = KMCObj.FpHtmlEnCode(Title)
Call FilterScript
Content = KMCObj.UBBCode(Content, strInstallDir, strChannelDir)
End If
End If
If FoundErr <> True Then
'时间
If UpDateType = 0 Then
UpDateTime = Now()
ElseIf UpDateType = 1 Then
If DateType = 0 Then
UpDateTime = Now()
Else
UpDateTime = KMCObj.GetBody(NewsCode, DsString, DoString, False, False)
UpDateTime = KMCObj.FpHtmlEnCode(UpDateTime)
UpDateTime = Trim(Replace(UpDateTime, " ", " "))
If IsDate(UpDateTime) = True Then
UpDateTime = CDate(UpDateTime)
Else
UpDateTime = Now()
End If
End If
ElseIf UpDateType = 2 Then
Else
UpDateTime = Now()
End If
'作者
If AuthorType = 1 Then
Author = KMCObj.GetBody(NewsCode, AsString, AoString, False, False)
ElseIf AuthorType = 2 Then
Author = AuthorStr
Else
Author = "佚名"
End If
Author = KMCObj.FpHtmlEnCode(Author)
If Author = "" Or Author = "Error" Then
Author = "佚名"
Else
If Len(Author) > 255 Then
Author = Left(Author, 255)
End If
End If
'来源
If CopyFromType = 1 Then
CopyFrom = KMCObj.GetBody(NewsCode, FsString, FoString, False, False)
ElseIf CopyFromType = 2 Then
CopyFrom = CopyFromStr
Else
CopyFrom = "不详"
End If
CopyFrom = KMCObj.FpHtmlEnCode(CopyFrom)
If CopyFrom = "" Or CopyFrom = "Error" Then
CopyFrom = "不详"
Else
If Len(CopyFrom) > 255 Then
CopyFrom = Left(CopyFrom, 255)
End If
End If
'关键字
If KeyType = 0 Then
Key = Title
Key = KMCObj.CreateKeyWord(Key, 2)
ElseIf KeyType = 1 Then
Key = KMCObj.GetBody(NewsCode, KsString, KoString, False, False)
Key = KMCObj.FpHtmlEnCode(Key)
Key = KMCObj.CreateKeyWord(Key, 2)
ElseIf KeyType = 2 Then
Key = KeyStr
Key = KMCObj.FpHtmlEnCode(Key)
If Len(Key) > 253 Then
Key = "|" & Left(Key, 253) & "|"
Else
Key = "|" & Key & "|"
End If
End If
If Key = "" Or Key = "Error" Then
Key = ""
End If
'转换图片相对地址为绝对地址/保存
If CollecTest = False And BeyondSavePic = 1 Then
Content = KMCObj.ReplaceSaveRemoteFile(UploadFiles, Content, strInstallDir, strChannelDir, True, NewsUrl)
Else
Content = KMCObj.ReplaceSaveRemoteFile(UploadFiles, Content, strInstallDir, strChannelDir, False, NewsUrl)
End If
'转换swf文件地址
Content = KMCObj.ReplaceSwfFile(Content, NewsUrl)
'图片统计、文章图片属性设置
If UploadFiles <> "" Then
If InStr(UploadFiles, "|") > 0 Then
Arr_Images = Split(UploadFiles, "|")
ImagesNum = UBound(Arr_Images) + 1
DefaultPicUrl = Arr_Images(0)
Else
ImagesNum = 1
DefaultPicUrl = UploadFiles
End If
If BeyondSavePic <> 1 Then
UploadFiles = ""
End If
Else
ImagesNum = 0
DefaultPicUrl = ""
IncludePic = 0
End If
ImagesNumAll = ImagesNumAll + ImagesNum
End If
If FoundErr <> True Then
If CollecTest = False Then
Call SaveArticle
SqlItem = "INSERT INTO KS_History(ItemID,ChannelID,ClassID,SpecialID,ArticleID,Title,CollecDate,NewsUrl,Result) VALUES ('" & ItemID & "','" & ChannelID & "','" & ClassID & "','" & SpecialID & "','" & ArticleID & "','" & Title & "','" & Now() & "','" & NewsUrl & "',True)"
ConnItem.Execute (SqlItem)
Content = Replace(Content, "[InstallDir_ChannelDir]", strInstallDir & strChannelDir & "/")
End If
NewsSuccesNum = NewsSuccesNum + 1
ErrMsg = ErrMsg & "No:<font color=red>" & NewsSuccesNum + NewsFalseNum & "</font><br>"
ErrMsg = ErrMsg & "文章标题："
ErrMsg = ErrMsg & "<font color=red>" & Title & "</font><br>"
ErrMsg = ErrMsg & "更新时间：" & UpDateTime & "<br>"
ErrMsg = ErrMsg & "文章作者：" & Author & "<br>"
ErrMsg = ErrMsg & "文章来源：" & CopyFrom & "<br>"
ErrMsg = ErrMsg & "采集页面：<a href=" & NewsUrl & " target=_blank>" & NewsUrl & "</a><br>"
ErrMsg = ErrMsg & "其它信息：分页--" & PageNum & " 页，图片--" & ImagesNum & " 张<br>"
ErrMsg = ErrMsg & "正文预览："
If Content_View = True Then
ErrMsg = ErrMsg & "<br>" & Content
Else
ErrMsg = ErrMsg & "您没有启用正文预览功能"
End If
ErrMsg = ErrMsg & "<br><br>关 键 字：" & Key & ""
Else
NewsFalseNum = NewsFalseNum + 1
If His_Repeat = True Then
ErrMsg = ErrMsg & "No:<font color=red>" & NewsSuccesNum + NewsFalseNum & "</font><br>"
ErrMsg = ErrMsg & "目标文章：<font color=red>"
If His_Result = True Then
ErrMsg = ErrMsg & His_Title
Else
ErrMsg = ErrMsg & NewsUrl
End If
ErrMsg = ErrMsg & "</font> 的记录已存在，不给予采集。<br>"
ErrMsg = ErrMsg & "采集时间：" & His_CollecDate & "<br>"
ErrMsg = ErrMsg & "文章来源：<a href='" & NewsUrl & "' target=_blank>" & NewsUrl & "</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 CollecTest = False And His_Repeat = False Then
SqlItem = "INSERT INTO KS_History(ItemID,ChannelID,ClassID,SpecialID,Title,CollecDate,NewsUrl,Result) VALUES ('" & ItemID & "','" & ChannelID & "','" & ClassID & "','" & SpecialID & "','" & Title & "','" & Now() & "','" & NewsUrl & "',False)"
ConnItem.Execute (SqlItem)
End If
End If
Call ShowMsg(ErrMsg)
Response.Flush '刷新
Next
Else
Call ShowMsg(ErrMsg)
End If
Response.Write "<table width=""90%"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">"
Response.Write "<tr>"
Response.Write "<td height=""22"" colspan=""2"" align=""left"">"
If CollecTest = False Then
Response.Write "数据整理中，5秒后继续......5秒后如果还没反应请点击 <a href='Collect_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum + 1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPageNext=" & ListPageNext & "'><font color=red>这里</font></a> 继续<br>"
Response.Write "<meta http-equiv=""refresh"" content=""5;url=Collect_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum + 1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPageNext=" & ListPageNext & """>"
Else
Response.Write "<a href='Collect_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum + 1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPageNext=" & ListPageNext & "'><font color=red>请 继 续</font></a>"
End If
Response.Write "</td></tr>"
Response.Write "</table>"
'边框结束
Response.Write "</Div>"
End Sub
'==================================================
'过程名：SetCache
'作 用：存取缓存
'参 数：无
'==================================================
Sub SetCache()
Dim myCache
Set myCache = New ClsCache
'项目信息
myCache.name = CacheTemp & "items"
If myCache.valid Then
Arr_Item = myCache.value
Else
ItemEnd = True
End If
'过滤信息
myCache.name = CacheTemp & "filters"
If myCache.valid Then
Arr_Filters = myCache.value
End If
'历史记录
myCache.name = CacheTemp & "Historys"
If myCache.valid Then
Arr_Historys = myCache.value
End If
'其它信息
myCache.name = CacheTemp & "collectest"
If myCache.valid Then
CollecTest = myCache.value
Else
CollecTest = False
End If
myCache.name = CacheTemp & "contentview"
If myCache.valid Then
Content_View = myCache.value
Else
Content_View = False
End If
Set myCache = Nothing
End Sub
Sub DelCache()
Dim myCache
Set myCache = New ClsCache
myCache.name = CacheTemp & "items"
Call myCache.clean
myCache.name = CacheTemp & "filters"
Call myCache.clean
myCache.name = CacheTemp & "Historys"
Call myCache.clean
myCache.name = CacheTemp & "collectest"
Call myCache.clean
myCache.name = CacheTemp & "contentview"
Call myCache.clean
Set myCache = Nothing
End Sub
'==================================================
'过程名：SetItems
'作 用：获取项目信息
'参 数：无
'==================================================
Sub SetItems()
Dim ItemNumTemp
ItemNumTemp = ItemNum - 1
ItemID = Arr_Item(0, ItemNumTemp)
ItemName = Arr_Item(1, ItemNumTemp)
ChannelID = Arr_Item(2, ItemNumTemp) '频道ID
strChannelDir = Arr_Item(3, ItemNumTemp) '频道目录
ClassID = Arr_Item(4, ItemNumTemp) '栏目
SpecialID = Arr_Item(5, ItemNumTemp) '专题
LoginType = Arr_Item(9, ItemNumTemp)
LoginUrl = Arr_Item(10, ItemNumTemp) '登录
LoginPostUrl = Arr_Item(11, ItemNumTemp)
LoginUser = Arr_Item(12, ItemNumTemp)
LoginPass = Arr_Item(13, ItemNumTemp)
LoginFalse = Arr_Item(14, ItemNumTemp)
ListStr = Arr_Item(15, ItemNumTemp) '列表地址
LsString = Arr_Item(16, ItemNumTemp) '列表
LoString = Arr_Item(17, ItemNumTemp)
ListPageType = Arr_Item(18, ItemNumTemp)
LPsString = Arr_Item(19, ItemNumTemp)
LPoString = Arr_Item(20, ItemNumTemp)
ListPageStr1 = Arr_Item(21, ItemNumTemp)
ListPageStr2 = Arr_Item(22, ItemNumTemp)
ListPageID1 = Arr_Item(23, ItemNumTemp)
ListPageID2 = Arr_Item(24, ItemNumTemp)
ListPageStr3 = Arr_Item(25, ItemNumTemp)
HsString = Arr_Item(26, ItemNumTemp)
HoString = Arr_Item(27, ItemNumTemp)
HttpUrlType = Arr_Item(28, ItemNumTemp)
HttpUrlStr = Arr_Item(29, ItemNumTemp)
TsString = Arr_Item(30, ItemNumTemp) '标题
ToString = Arr_Item(31, ItemNumTemp)
CsString = Arr_Item(32, ItemNumTemp) '正文
CoString = Arr_Item(33, ItemNumTemp)
DateType = Arr_Item(34, ItemNumTemp) '作者
DsString = Arr_Item(35, ItemNumTemp)
DoString = Arr_Item(36, ItemNumTemp)
AuthorType = Arr_Item(37, ItemNumTemp) '作者
AsString = Arr_Item(38, ItemNumTemp)
AoString = Arr_Item(39, ItemNumTemp)
AuthorStr = Arr_Item(40, ItemNumTemp)
CopyFromType = Arr_Item(41, ItemNumTemp) '来源
FsString = Arr_Item(42, ItemNumTemp)
FoString = Arr_Item(43, ItemNumTemp)
CopyFromStr = Arr_Item(44, ItemNumTemp)
KeyType = Arr_Item(45, ItemNumTemp) '关键词
KsString = Arr_Item(46, ItemNumTemp)
KoString = Arr_Item(47, ItemNumTemp)
KeyStr = Arr_Item(48, ItemNumTemp)
NewsPageType = Arr_Item(49, ItemNumTemp) '文章分页
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -