?? sk_collectionfast.asp
字號:
<%
'================================================================================================
' 軟件名稱：清風信息自動采集生成系統
' 當前版本：CJ 1.0
' 更新日期：2008-7-18
' 程序版權：龍心數據
' 程序開發：龍心數據開發組
' 演示站點：http://cj.iising.com
' 官方網站：http://www.iising.com QQ：24387481 電話：13719316070
' 鄭重聲明:
' ①、沒有版權,你愛抄抄,愛搬搬,偶看不見!
' ②、不要用黑與白來衡量你我之間的距離,更不要讓生活磨滅我們的個性！
' ③、歡迎定做各種信息采集功能系統。
'================================================================================================
option explicit
Response.Buffer = True
Server.ScriptTimeOut=999
Response.Expires = -1
Response.ExpiresAbsolute = Now() - 1
Response.Expires = 0
Response.CacheControl = "no-cache"
%>
<!--#include file="inc/conn.asp"-->
<!--#include file="inc/function.asp"-->
<!--#include file="inc/ubbcode.asp"-->
<!--#include file="inc/SK_FunCls.asp"-->
<!--#include file="inc/clsCache.asp"-->
<!--#include file="inc/cj_cls.asp"-->
<!--#include file="inc/Md5.asp"-->
<%
dim Skcj
Set Skcj= New FunCls
Dim Action,CollecType
Dim myCache
Dim ItemNum,ListNum,PaingNum,NewsSuccesNum,NewsFalseNum,NewsNum_i,Itemon,ItemIdstr,Itemok
Dim Rs,Sql,RsItem,SqlItem,FoundErr,ItemEnd,ListEnd
Dim PicUrls_i,NewsUrlPaing_s,NewsUrlPaing_o,NewsPaingNext_Code,TypeArray_Url,TypeNews_Url
'項目變量
Dim ItemID,ItemName,ChannelID,strChannelDir,ClassID,SpecialID,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse
Dim ListStr,LsString,LoString,ListPaingType,LPsString,LPoString,ListPaingStr1,ListPaingStr2,ListPaingID1,ListPaingID2,ListPaingStr3,HsString,HoString,HttpUrlType,HttpUrlStr,photourls,photourlo,PhotoPaingType,PhotoType_s,PhotoType_o,PhotoLurl_s,PhotoLurl_o,Phototypefy_s,Phototypefy_o,Phototypefyurl_s,Phototypefyurl_o,Phototypeurl_s,Phototypeurl_o,Colleclx,selEncoding,SaveFileUrl,x_tpUrl,Thumb_WaterMark,Thumbs_Create,Timing,strReplace
'下載變量
dim DownSize,DownYY,DownSQ,DownPT,YSDZ,ZCDZ,PhotoUrl,DownUrls
'下載變量項目字段
dim Downlist_s,Downlist_o,DownUrl_s,DownUrl_o,DownNewType,DownNewlist_s,DownNewlist_o,DownNewUrl_s,DownNewUrl_o,LinkUrlYn
dim ZdType_001,Zds_001,Zdo_001,ZD_001,ZdType_002,Zds_002,Zdo_002,ZD_002,ZdType_003,Zds_003,Zdo_003,ZD_003,ZdType_004,Zds_004,Zdo_004,ZD_004,ZdType_005,Zds_005,Zdo_005,ZD_005,ZdType_006,Zds_006,Zdo_006,ZD_006,ZdType_007,Zds_007,Zdo_007,ZD_007,ZdType_008,Zds_008,Zdo_008,ZD_008
'--圖片列表鏈接
dim imhstr,imostr,NewsimageCode,Newsimage,picpath,Radiobutton,x_tp
'--圖片列表鏈接
Dim TsString,ToString,CsString,CoString,DateType,DsString,DoString,AuthorType,AsString,AoString,AuthorStr,CopyFromType,FsString,FoString
Dim CopyFromStr,KeyType,KsString,KoString,KeyStr,NewsPaingType,NPsString,NpoString,NewsPaingStr,NewsPaingHtml
Dim ItemCollecDate,PaginationType,MaxCharPerPage,ReadLevel,Stars,ReadPoint,Hits,UpDateType,UpDateTime,IncludePicYn,DefaultPicYn,OnTop,Elite,Hot
Dim SkinID,TemplateID,Script_Iframe,Script_Object,Script_Script,Script_Div,Script_Class,Script_Span,Script_Img,Script_Font,Script_A,Script_Html,CollecListNum,CollecNewsNum,Passed,SaveFiles,CollecOrder,InputerType,Inputer,EditorType,Editor,ShowCommentLink,Script_Table,Script_Tr,Script_Td
'過濾變量
Dim Arr_Filters,FilterStr,Filteri
'采集相關的變量
Dim ContentTemp,NewsPaingNext,NewsPaingNextCode,Arr_i,NewsUrl,NewsCode,ListTypeCode,ListTypeUrlCode,TypeUrlArray,TypeNewsUrl,NewsTypeCode,PicUrls,Arr_ii,Arr_ii_2,ListTypeCode_2,ListTypeUrlCode_2,TypeUrlArray_2
'文章保存變量
Dim ArticleID,Title,Content,Author,CopyFrom,Key,IncludePic,UploadFiles,DefaultPicUrl,Coll_DefiniteUrl
'其它變量
Dim LoginData,LoginResult,OrderTemp,i
Dim Arr_Item,CollecTest,Content_View,CollecNewsAll
Dim StepID
'歷史記錄
Dim Arr_Histrolys,His_Title,His_CollecDate,His_Result,His_Repeat,His_i
'執行時間變量
Dim StartTime,OverTime
'圖片統計
Dim Arr_Images,ImagesNum,ImagesNumAll
'列表
Dim ListUrl,ListCode,NewsArrayCode,NewsArray,ListArray,ListPaingNext
'安裝路徑
Dim strInstallDir,CacheTemp
Dim DiyFieldSTR_z,DiyFieldSTR_l'自定義
Dim FoundErr_1
'----是否登陸---------------------
Call Skcj.Admin()
If Skcj.IsAdmin=False Then
ErrMsg="<li> 您沒有登陸或不是管理員。請<a href='sk_login.asp' target='_top'>登陸</a>。"
response.Redirect("Sk_err.asp?action=AdminErr&ErrMsg="&ErrMsg&"")
response.End()
End If
'-------------------------------------
'On Error Resume Next
strInstallDir=trim(request.ServerVariables("SCRIPT_NAME"))
strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/")-1)
'緩存路徑
CacheTemp=Lcase(trim(request.ServerVariables("SCRIPT_NAME")))
CacheTemp=left(CacheTemp,instrrev(CacheTemp,"/"))
CacheTemp=replace(CacheTemp,"\","_")
CacheTemp=replace(CacheTemp,"/","_")
CacheTemp="ansir" & CacheTemp
'數據初始化
CollecListNum=0'列表數
CollecNewsNum=0'列表數
ArticleID=0'ID
ItemNum=Clng(Trim(Request("ItemNum")))
ListNum=Clng(Trim(Request("ListNum")))
NewsNum_i=Clng(Trim(Request("NewsNum_i")))
NewsSuccesNum=Clng(Trim(Request("NewsSuccesNum")))
NewsFalseNum=Clng(Trim(Request("NewsFalseNum")))
ImagesNumAll=Clng(Trim(Request("ImagesNumAll")))
ListPaingNext=Trim(Request("ListPaingNext"))
Itemon=Trim(Request("Itemon"))'快速采集
Itemok=Trim(Request("Itemok"))'快速采集
FoundErr=False
ItemEnd=False
ListEnd=False
ErrMsg=""
Call DelNews()'
Call CheckForm()'檢察ItemID值
Dim Collecdate : Collecdate=Trim(Request("Collecdate"))
If Itemok = "yes" then
If Instr(Itemon,",")>0 Then
ItemIdstr=GetItemId(Itemon,1)
Response.write("<script>location.href='Sk_CollectionFast.asp?ItemID="&GetItemId(Itemon,0)&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Itemon="& ItemIdstr &"&Collecdate="& Collecdate &"';</script>")'到頁面
Else
Response.write("<script>location.href='Sk_CollectionFast.asp?ItemID="&Itemon&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Collecdate="& Collecdate &"';</script>")'到頁面
End if
Response.end
End if
If Instr(ItemID,",")>0 Then
ItemIdstr=GetItemId(ItemID,1)
Response.write("<script>location.href='Sk_CollectionFast.asp?ItemID="&GetItemId(ItemID,0)&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Itemon="& ItemIdstr&"&Collecdate="& Collecdate &"';</script>")'到頁面
Response.end
End if
If FoundErr<>True Then
Call SetCache()'項目信息寫入緩存
End If
If FoundErr=True Then
Call WriteErrMsg(ErrMsg)
Else
Call GetCache()
Call Main()
Collection_Fast
End If
'關閉數據庫鏈接
Call CloseConnItem()
%>
<!--#include file="Admin_ItemFoot.asp"-->
<%Sub Main%>
<html>
<head>
<title>采集系統</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" type="text/css" href="css/Admin_Style.css">
</head>
<body leftmargin="0" topmargin="0" marginwidth="0" marginheight="0">
<br>
</body>
</html>
<%End Sub
Sub CheckForm()'提取表單
ItemID=Trim(Request("ItemID"))
CollecTest=Trim(Request.Form("CollecTest"))
Content_View=Trim(Request.Form("Content_View"))
'檢察表單
If ItemID="" Then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>請您選擇項目!</li>"
Else
If Instr(ItemID,",")>0 Then
ItemID=Replace(ItemID," ","")
End If
Response.Flush()
set rs=connItem.execute("select top 1 * from Item Where ItemID in(" & ItemID &")" )
if connItem.Execute("select count(ClassID) from SK_Class Where ClassID=" & RS("ClassID"))(0)=0 then
'if conn.Execute("select count(id) from ks_Class Where ID='" & RS("ClassID") &"'")(0)=0 then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>請您設置頻道欄目! </li>"
rs.close
set rs=nothing
end if
End If
If CollecTest="yes" Then
CollecTest=True
Else
CollecTest=False
End If
If Content_View="yes" Then
Content_View=True
Else
Content_View=False
End If
End Sub
'==================================================
'過程名：SetCache1
'作 用：存取緩存
'參 數：無
'==================================================
Sub GetCache()
Dim myCache
Set myCache=new SK_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 & "histrolys"
If myCache.valid then
Arr_Histrolys=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 SetCache()'項目信息寫入緩存
SqlItem ="select * from Item where ItemID in(" & ItemID & ")"
Set RsItem=Server.CreateObject("adodb.recordset")
RsItem.Open SqlItem,ConnItem,1,1
If Not RsItem.Eof Then
Arr_Item=RsItem.GetRows()
End If
RsItem.Close
Set RsItem=Nothing
Set myCache=new SK_clsCache
myCache.name=CacheTemp & "items"
Call myCache.clean()
If IsArray(Arr_Item)=True Then
myCache.add Arr_Item,Dateadd("n",1000,now)
Else
FoundErr=True
ErrMsg=ErrMsg & "<br>發生意外錯誤！"
End If
'過濾信息
SqlItem ="select * from Filters where Flag=True"
Set RsItem=Server.CreateObject("adodb.recordset")
RsItem.Open SqlItem,ConnItem,1,1
If Not RsItem.Eof Then
Arr_Filters=RsItem.GetRows()
End If
RsItem.Close
Set Rsitem=Nothing
myCache.name=CacheTemp & "filters"
Call myCache.clean()
If IsArray(Arr_Filters)=True Then
myCache.add Arr_Filters,Dateadd("n",1000,now)
End If
'歷史記錄
SqlItem ="select NewsUrl,Title,CollecDate,Result from Histroly"
Set RsItem=Server.CreateObject("adodb.recordset")
RsItem.Open SqlItem,ConnItem,1,1
If Not RsItem.Eof Then
Arr_Histrolys=RsItem.GetRows()
End If
RsItem.Close
Set RsItem=Nothing
myCache.name=CacheTemp & "histrolys"
Call myCache.clean()
If IsArray(Arr_Histrolys)=True Then
myCache.add Arr_Histrolys,Dateadd("n",1000,now)
End If
'其它信息
myCache.name=CacheTemp & "collectest"
Call myCache.clean()
myCache.add CollecTest,Dateadd("n",1000,now)
myCache.name=CacheTemp & "contentview"
Call myCache.clean()
myCache.add Content_View,Dateadd("n",1000,now)
set myCache=nothing
End Sub
Sub DelNews()
ConnItem.execute("Delete From [NewsList]")
End Sub
'=============快速采集==================
Public Sub Collection_Fast
If ItemEnd<>True Then
If (ItemNum-1)>Ubound(Arr_Item,2) then
ItemEnd=True
Else
SK.SetItems()
End If
End If
If ItemEnd<>True Then
If ListPaingType=0 Then
If ListNum=1 Then
ListUrl=ListStr
Else
ListEnd=True
End If
ElseIf ListPaingType=1 Then
if listnum=1 and ListPaingID1<>1 and ListPaingID2<>1 then
ListUrl=ListStr
else
If ListPaingID1>ListPaingID2 then
If (ListPaingID1-ListNum+1)<ListPaingID2 or (ListPaingID1-ListNum+1)<0 Then
Listend=True
Else
ListUrl=Replace(ListPaingStr2,"{$ID}",Cstr(ListpaingID1-ListNum+1))
End if
Else
If (ListPaingID1+ListNum-1)>ListPaingID2 Then
ListEnd=True
Else
ListUrl=Replace(ListPaingStr2,"{$ID}",CStr(ListPaingID1+ListNum-1))
End If
End If
end if
ElseIf ListPaingType=2 Then
ListArray=Split(ListPaingStr3,"|")
If (ListNum-1)>Ubound(ListArray) Then
ListEnd=True
Else
ListUrl=ListArray(ListNum-1)
End If
ElseIf ListPaingType=3 Then
If ListNum=1 Then
ListUrl=ListStr
ListCode=ListStr
application.Lock()
application("IPQ_SS")=ListUrl
application.UnLock()
Else
ListUrl=application("IPQ_SS")
ListCode=SKcj.GetHttpPage(ListUrl,"GB2312")
ListCode=SKcj.GetBody(ListCode,LPsString,LPoString,False,False)
End if
If ListCode<>"$False$" or ListCode<>"" Then
ListCode=Trim(Skcj.FormatRemoteUrl(ListCode,ListStr))
ListUrl=ListCode
application.Lock()
application("IPQ_SS")=ListUrl
application.UnLock()
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -