ks_collectcommoncls.asp

SK信息采集2.0功能介绍: 1.可针对任何静态网页,动态网页进行采集。包括htm,html,shtml,ASP,ASPX,JSP,PHP等。 2.增加自定文件采集.用户可采集网页中的所有文件.

		   TempArray = Split(TempStr, "$Array$")
		   '去掉重复图片结束
		
		   '转换相对图片地址开始
		   TempStr = ""
		   For Tempi = 0 To UBound(TempArray)
			  TempStr = TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi), TistUrl)
		   Next
		   TempStr = Right(TempStr, Len(TempStr) - 7)
		   TempStr = Replace(TempStr, Chr(0), "")
		   TempArray2 = Split(TempStr, "$Array$")
		   TempStr = ""
		   '转换相对图片地址结束
		
		   '图片替换/保存
		   Set re = New RegExp
		   re.IgnoreCase = True
		   re.Global = True
		
		   For Tempi = 0 To UBound(TempArray2)
			  RemoteFileUrl = TempArray2(Tempi)
			  If RemoteFileUrl <> "Error" And SaveTf = True Then '保存图片
				 ArrSaveFileName = Split(RemoteFileUrl, ".")
			 strFileType = LCase(ArrSaveFileName(UBound(ArrSaveFileName))) '文件类型
				 If strFileType = "asp" Or strFileType = "asa" Or strFileType = "aspx" Or strFileType = "cer" Or strFileType = "cdx" Or strFileType = "exe" Or strFileType = "rar" Or strFileType = "zip" Then
					UploadFiles = ""
					ReplaceSaveRemoteFile = Constr
					Exit Function
				 End If
		
				 Randomize
				 RanNum = Int(900 * Rnd) + 100
			 strFileName = Year(DtNow) & Right("0" & Month(DtNow), 2) & Right("0" & Day(DtNow), 2) & Right("0" & Hour(DtNow), 2) & Right("0" & Minute(DtNow), 2) & Right("0" & Second(DtNow), 2) & RanNum & "." & strFileType
				 re.Pattern = TempArray(Tempi)
			 If SaveRemoteFile(SavePath & strFileName, RemoteFileUrl) = True Then
		'********************************
					PathTemp = SavePath & strFileName
					Constr = re.Replace(Constr, PathTemp)
					re.Pattern = strInstallDir & strChannelDir & "/"
					UploadFiles = UploadFiles & "|" & re.Replace(SavePath & strFileName, "")
				 Else
					PathTemp = RemoteFileUrl
					Constr = re.Replace(Constr, PathTemp)
					'UploadFiles=UploadFiles & "|" & RemoteFileUrl
				 End If
			  ElseIf RemoteFileUrl <> "Error" And SaveTf = False Then '不保存图片
				 re.Pattern = TempArray(Tempi)
				 Constr = re.Replace(Constr, RemoteFileUrl)
				 UploadFiles = UploadFiles & "|" & RemoteFileUrl
			  End If
		   Next
		   Set re = Nothing
		   If UploadFiles <> "" Then
			  UploadFiles = Right(UploadFiles, Len(UploadFiles) - 1)
		   End If
		   ReplaceSaveRemoteFile = Constr
		End Function
		
		'==================================================
		'函数名：ReplaceSwfFile
		'作  用：解析动画路径
		'参  数：ConStr ------ 要替换的字符串
		'参  数: TistUrl------ 当前网页地址
		'==================================================
		Function ReplaceSwfFile(Constr, TistUrl)
		   Dim RemoteFileUrl
		   If Constr = "Error" Or Constr = "" Or TistUrl = "" Or TistUrl = "Error" Then
			  ReplaceSwfFile = Constr
			  Exit Function
		   End If
		
		   Dim TempStr, TempStr2, TempStr3, re, Matches, Match, Tempi, TempArray, TempArray2
		
		   Set re = New RegExp
		   re.IgnoreCase = True
		   re.Global = True
		   re.Pattern = "<object.+?[^\>]>"
		   Set Matches = re.Execute(Constr)
		   For Each Match In Matches
			  If TempStr <> "" Then
				 TempStr = TempStr & "$Array$" & Match.value
			  Else
				 TempStr = Match.value
			  End If
		   Next
		   If TempStr <> "" Then
			  TempArray = Split(TempStr, "$Array$")
			  TempStr = ""
			  For Tempi = 0 To UBound(TempArray)
				 re.Pattern = "value\s*=\s*.+?\.swf"
				 Set Matches = re.Execute(TempArray(Tempi))
				 For Each Match In Matches
					If TempStr <> "" Then
					   TempStr = TempStr & "$Array$" & Match.value
					Else
					   TempStr = Match.value
					End If
				 Next
			  Next
		   End If
		   If TempStr <> "" Then
			  re.Pattern = "value\s*=\s*"
			  TempStr = re.Replace(TempStr, "")
		   End If
		   If TempStr = "" Or IsNull(TempStr) = True Then
			  ReplaceSwfFile = Constr
			  Exit Function
		   End If
		   TempStr = Replace(TempStr, """", "")
		   TempStr = Replace(TempStr, "'", "")
		   TempStr = Replace(TempStr, " ", "")
		
		   Set Matches = Nothing
		   Set re = Nothing
		
		   '去掉重复文件开始
		   TempArray = Split(TempStr, "$Array$")
		   TempStr = ""
		   For Tempi = 0 To UBound(TempArray)
			  If InStr(LCase(TempStr), LCase(TempArray(Tempi))) < 1 Then
				 TempStr = TempStr & "$Array$" & TempArray(Tempi)
			  End If
		   Next
		   TempStr = Right(TempStr, Len(TempStr) - 7)
		   TempArray = Split(TempStr, "$Array$")
		   '去掉重复文件结束
		
		   '转换相对地址开始
		   TempStr = ""
		   For Tempi = 0 To UBound(TempArray)
			  TempStr = TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi), TistUrl)
		   Next
		   TempStr = Right(TempStr, Len(TempStr) - 7)
		   TempStr = Replace(TempStr, Chr(0), "")
		   TempArray2 = Split(TempStr, "$Array$")
		   TempStr = ""
		   '转换相对地址结束
		
		   '替换
		   Set re = New RegExp
		   re.IgnoreCase = True
		   re.Global = True
		   For Tempi = 0 To UBound(TempArray2)
			  RemoteFileUrl = TempArray2(Tempi)
			  re.Pattern = TempArray(Tempi)
			  Constr = re.Replace(Constr, RemoteFileUrl)
		   Next
		   Set re = Nothing
		   ReplaceSwfFile = Constr
		End Function
		
		
		'==================================================
		'过程名：SaveRemoteFile
		'作  用：保存远程的文件到本地
		'参  数：LocalFileName ------ 本地文件名
		'参  数：RemoteFileUrl ------ 远程文件URL
		'==================================================
		Function SaveRemoteFile(LocalFileName, RemoteFileUrl)
		     On Error Resume Next
	         SaveRemoteFile=True
			dim Ads,Retrieval,GetRemoteData
			Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
			With Retrieval
				.Open "Get", RemoteFileUrl, False, "", ""
				.Send
				If .Readystate<>4 then
					SaveRemoteFile=False
					Exit Function
				End If
				GetRemoteData = .ResponseBody
			End With
			Set Retrieval = Nothing
			Set Ads = Server.CreateObject("Adodb.Stream")
			With Ads
				.Type = 1
				.Open
				.Write GetRemoteData
				.SaveToFile server.MapPath(LocalFileName),2
				.Cancel()
				.Close()
			End With
			Set Ads=nothing
		End Function
		
		'==================================================
		'函数名：FpHtmlEnCode
		'作  用：标题过滤
		'参  数：fString ------字符串
		'==================================================
		Function FpHtmlEnCode(fString)
		   If IsNull(fString) = False Or fString <> "" Or fString <> "Error" Then
			   fString = nohtml(fString)
			   fString = FilterJS(fString)
			   fString = Replace(fString, "&nbsp;", " ")
			   fString = Replace(fString, "&quot;", "")
			   fString = Replace(fString, "&#39;", "")
			   fString = Replace(fString, ">", "")
			   fString = Replace(fString, "<", "")
			   fString = Replace(fString, Chr(9), " ") '&nbsp;
			   fString = Replace(fString, Chr(10), "")
			   fString = Replace(fString, Chr(13), "")
			   fString = Replace(fString, Chr(34), "")
			   fString = Replace(fString, Chr(32), " ") 'space
			   fString = Replace(fString, Chr(39), "")
			   fString = Replace(fString, Chr(10) & Chr(10), "")
			   fString = Replace(fString, Chr(10) & Chr(13), "")
			   fString = Trim(fString)
			   FpHtmlEnCode = ReplaceChar(fString)
		   Else
			   FpHtmlEnCode = "Error"
		   End If
		End Function
		Function ReplaceChar(Content)
			Content=Replace(Replace(Content,"[",""),"]","")
			Content=Replace(Replace(Content,"［",""),"］","")
			Content=Replace(Replace(Content,"(",""),")","")
			Content=Replace(Replace(Content,"（",""),"）","")
			Content=Replace(Replace(Content,"《",""),"》","")
			Content=Replace(Replace(Content,"{",""),"}","")
			Content=Replace(Replace(Content,"'",""),"""","")
			Content=Replace(Replace(Content,"?",""),""="","")
			Content=Replace(Replace(Content,":",""),"：","")
			Content=Replace(Replace(Content,";",""),"：","")
			Content=Replace(Replace(Content,"/",""),"／","")
			Content=Replace(Replace(Content,"【",""),"】","")
			ReplaceChar=Content
		End Function
		'==================================================
		'函数名：GetPage
		'作  用：获取分页
		'==================================================
		Function GetPage(ByVal Constr, StartStr, OverStr, IncluL, IncluR)
		If Constr = "Error" Or Constr = "" Or StartStr = "" Or OverStr = "" Or IsNull(Constr) = True Or IsNull(StartStr) = True Or IsNull(OverStr) = True Then
		   GetPage = "Error"
		   Exit Function
		End If
		
		Dim Start, Over, ConTemp, TempStr
		TempStr = LCase(Constr)
		StartStr = LCase(StartStr)
		OverStr = LCase(OverStr)
		Over = InStr(1, TempStr, OverStr)
		If Over <= 0 Then
		   GetPage = "Error"
		   Exit Function
		Else
		   If IncluR = True Then
			  Over = Over + Len(OverStr)
		   End If
		End If
		TempStr = Mid(TempStr, 1, Over)
		Start = InStrRev(TempStr, StartStr)
		If IncluL = False Then
		   Start = Start + Len(StartStr)
		End If
		
		If Start <= 0 Or Start >= Over Then
		   GetPage = "Error"
		   Exit Function
		End If
		ConTemp = Mid(Constr, Start, Over - Start)
		
		ConTemp = Trim(ConTemp)
		ConTemp = Replace(ConTemp, " ", "")
		ConTemp = Replace(ConTemp, ",", "")
		ConTemp = Replace(ConTemp, "'", "")
		ConTemp = Replace(ConTemp, """", "")
		ConTemp = Replace(ConTemp, ">", "")
		ConTemp = Replace(ConTemp, "<", "")
		ConTemp = Replace(ConTemp, "&nbsp;", "")
		GetPage = ConTemp
		End Function
		
		'==================================================
		'函数名：ScriptHtml
		'作  用：过滤html标记
		'参  数：ConStr ------ 要过滤的字符串
		'==================================================
		Function ScriptHtml(ByVal Constr, TagName, FType)
			Dim re
			Set re = New RegExp
			re.IgnoreCase = True
			re.Global = True
			Select Case FType
			Case 1
			   re.Pattern = "<" & TagName & "([^>])*>"
			   Constr = re.Replace(Constr, "")
			Case 2
			   re.Pattern = "<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
			   Constr = re.Replace(Constr, "")
			Case 3
			   re.Pattern = "<" & TagName & "([^>])*>"
			   Constr = re.Replace(Constr, "")
			   re.Pattern = "</" & TagName & "([^>])*>"
			   Constr = re.Replace(Constr, "")
			End Select
			ScriptHtml = Constr
			Set re = Nothing
		End Function
		
		Function CheckDir(ByVal FolderPath)
			Dim fso
			Set fso = Server.CreateObject(KSCMS.GetConfig("FsoObjName"))
			If fso.FolderExists(Server.MapPath(FolderPath)) Then
			'存在
				CheckDir = True
			Else
			'不存在
				CheckDir = False
			End If
			Set fso = Nothing
		End Function
		Function MakeNewsDir(ByVal foldername)
			Dim fso
			Set fso = Server.CreateObject("Scripting.FileSystemObject")
				fso.CreateFolder (Server.MapPath(foldername))
				If fso.FolderExists(Server.MapPath(foldername)) Then
				   MakeNewsDir = True
				Else
				   MakeNewsDir = False
				End If
			Set fso = Nothing
		End Function
		
		'**************************************************
		'函数名：IsObjInstalled
		'作  用：检查组件是否已经安装
		'参  数：strClassString ----组件名
		'返回值：True  ----已经安装
		'       False ----没有安装
		'**************************************************
		Function IsObjInstalled(strClassString)
			IsObjInstalled = False
			Err = 0
			Dim xTestObj
			Set xTestObj = Server.CreateObject(strClassString)
			If 0 = Err Then IsObjInstalled = True
			Set xTestObj = Nothing
			Err = 0
		End Function
		
		'**************************************************
		'过程名：WriteErrMsg
		'作  用：显示错误提示信息
		'参  数：无
		'**************************************************
		Sub WriteErrMsg(ErrMsg)
			Dim strErr
			strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
			strErr = strErr & "<link href='../inc/Admin_STYLE.CSS' rel='stylesheet' type='text/css'></head><body oncontextmenu='return false'>" & vbCrLf
			strErr = strErr & "<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""sortbutton"">" & vbCrLf
			strErr = strErr & "<tr> " & vbCrLf
			strErr = strErr & "<td  height=""22"" align=""center"" nowrap><strong>错 误 信 息</strong></td>" & vbCrLf
			strErr = strErr & "</tr>" & vbCrLf
			strErr = strErr & "</table>" & vbCrLf
			strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
			strErr = strErr & "  <tr align='center' class='title'><td height='22'><strong></strong></td></tr>" & vbCrLf
			strErr = strErr & "  <tr ><td height='80' valign='top'>" & ErrMsg & "</td></tr>" & vbCrLf
			strErr = strErr & "  <tr align='center'><td><input type='button' onclick='javascript:history.go(-1)' value='&lt;&lt; 返回上一页'/></td></tr>" & vbCrLf
			strErr = strErr & "</table>" & vbCrLf
			strErr = strErr & "</body></html>" & vbCrLf
			Response.Write strErr
		End Sub
		
		'**************************************************
		'过程名：WriteSucced
		'作  用：显示成功提示信息
		'参  数：无
		'**************************************************
		Sub WriteSucced(ErrMsg)
			Dim strErr