cl_clscollect.asp

淘客网上商店网站程序 淘客网上商店网站程序 淘客网上商店网站程序

<%
'========================================
'	Edit by GDWneo
'	Last modify at 9:22 2007-9-6
'========================================

Const ContentPreview = "Yes"
Rem 是否开启正文预览功能

Dim CGet,CGetThumb
Set CGet	= New Cls_Collection
Set CGetThumb	= New Cls_Thumb



Class Cls_Collection
	Dim AllExtName  '下载类型限制
	Dim MaxFileSize '下载类型限制
	Dim DownTimeout '超时设置
	'===============================================
	'启动类事件
	'===============================================
	Private Sub Class_Initialize()
		On Error Resume Next
		DownTimeout = 64 '超时设置
		MaxFileSize = 0'-- 下载大小限制
		AllExtName = "rm|swf"'-- 下载类型限制
	End Sub
	'===============================================
	'关闭类事件
	'===============================================
	Private Sub Class_Terminate()
		'-- Class_Terminate
	End Sub
	'===============================================
	'-- 超时设置
	'===============================================
	Public Property Let CjTimeout(ByVal NewValue)
		DownTimeout = NewValue
	End Property
	'===============================================
	'-- 下载类型限制
	'===============================================
	Public Property Let DownExtName(ByVal NewValue)
		AllExtName = NewValue
	End Property
	'===============================================
	'-- 下载大小限制
	'===============================================
	Public Property Let MaxSize(ByVal NewValue)
		MaxFileSize = NewValue * 1024
	End Property
	'===============================================
	'函数名：G()
	'作  用：'取得Request.Querystring 或 Request.Form 的值
	'===============================================
	Public Function G(Str)
		G = Replace(Replace(Request(Str), "'", ""), """", "")
	End Function
	'===============================================
	'函数名：GetItemConfig
	'作  用：获取采集基础配置信息
	'参  数：ConfigField相应的字段名称,CJID基础配置的ID号
	'===============================================
	Public Function GetItemConfig(ByVal ConfigField,CJID)
		'IF Application(CJID & "ItemConfig_" & ConfigField)="" Then
			Dim ConfigRS:Set ConfigRS = Server.CreateObject("Adodb.Recordset")
			On Error Resume Next
			ConfigRS.Open ("Select * From ModuleInfo where ID="& CJID), Conn_C, 1, 1
			GetItemConfig = ConfigRS(ConfigField)
			If Err.Number <> 0 Then GetItemConfig = "":Err.clear
			ConfigRS.Close:Set ConfigRS = Nothing
		'else
		'	GetConfig=Application(CJID & "ItemConfig_" & ConfigField)
		'end if
	End Function
	'===============================================
	'函数名：GetHttpPage
	'作  用：获取网页源码
	'参  数：HttpUrl ------网页地址,Cset 编码
	'===============================================
	Function GetHttpPage(ByVal URL, ByVal Cset)
	Dim BlockStartTime
	On Error Resume Next
	Dim Http
	If IsNull(URL)=True Or Len(URL)<18 Or URL="$False$" Then
		GetHttpPage="$False$"
		Exit Function
	End If
	BlockStartTime = Timer()
	Set Http=server.createobject("MSXML2.XMLHTTP")
	Http.open "GET",URL,False
	Http.Send()
	'循环等待数据接收
	Dim temp,BlockTimeout 	
	BlockTimeout = 64
	While (http.ReadyState <> 4)
		' 判断是否块超时
		temp = Timer() - BlockStartTime
		Response.Write(Timer())
		If (temp > BlockTimeout) Then
			http.abort
			Set Http=Nothing 
			GetHttpPage="$False$"
			Exit function
			Response.End
		End If
		http.waitForResponse 10000'等待1000毫秒
	Wend
	If Http.Readystate<>4 then
		Set Http=Nothing 
		GetHttpPage="$False$"
		Exit function
	End if
	GetHTTPPage=bytesToBSTR(Http.responseBody,Cset)
	Set Http=Nothing
	
	If Err.number<>0 then
		If IsNull(URL)=True Or Len(URL)<18 Or URL="$False$" Then
		GetHttpPage="$False$"
		Exit Function
	End If
	Set Http=Nothing
		Err.Clear
	End If
	
	End Function
	'===============================================
	'函数名：BytesToBstr
	'作  用：将获取的源码转换为中文
	'参  数：Body ------要转换的变量
	'参  数：Cset ------要转换的类型
	'===============================================
	Function BytesToBstr(Body,Cset)
	Dim Objstream
	Set Objstream = Server.CreateObject("adodb.stream")
	objstream.Type = 1
	objstream.Mode =3
	objstream.Open
	objstream.Write body
	objstream.Position = 0
	objstream.Type = 2
	objstream.Charset = Cset
	BytesToBstr = objstream.ReadText 
	objstream.Close
	set objstream = nothing
	End Function

	'==================================================
	'函数名：PostHttpPage
	'作  用：登录
	'==================================================
	Function PostHttpPage(RefererUrl,PostUrl,PostData,Cset) 
		Dim xmlHttp 
		Dim RetStr
		On Error Resume Next
		Set xmlHttp = CreateObject("Msxml2.XMLHTTP")  
		xmlHttp.Open "POST", PostUrl, False
		XmlHTTP.setRequestHeader "Content-Length",Len(PostData) 
		xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
		xmlHttp.setRequestHeader "Referer", RefererUrl
		xmlHttp.Send PostData 
		If Err.Number <> 0 Then
			Set xmlHttp=Nothing
			PostHttpPage = "$False$"
			Exit Function
		End If
		PostHttpPage=bytesToBSTR(xmlHttp.responseBody,Cset)
		Set xmlHttp = Nothing
	End Function 

	'===============================================
	'函数名：UrlEncoding
	'作  用：转换编码
	'===============================================
	Function UrlEncoding(DataStr)
		Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
		StrReturn = ""
		For Si = 1 To Len(DataStr)
			ThisChr = Mid(DataStr,Si,1)
			If Abs(Asc(ThisChr)) < &HFF Then
				StrReturn = StrReturn & ThisChr
			Else
				InnerCode = Asc(ThisChr)
				If InnerCode < 0 Then
				InnerCode = InnerCode + &H10000
				End If
				Hight8 = (InnerCode  And &HFF00)\ &HFF
				Low8 = InnerCode And &HFF
				StrReturn = StrReturn & "%" & Hex(Hight8) &  "%" & Hex(Low8)
			End If
		Next
		UrlEncoding = StrReturn
	End Function
	'===============================================
	'函数名：GetBody
	'作  用：截取固定的字符串
	'参  数：strHTML   ----原字符串
	'参  数: start ------ 开始字符串
	'参  数: Over ------ 结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'===============================================
	Public Function GetBody(ByVal strHTML, ByVal Start, ByVal Over,IncluL,IncluR)
		Dim SS
		Dim Match
		Dim TempStr
		Dim strPattern
		Dim s,o  
		If IsNull(Start)=True Then GetBody="$False$" : Exit Function
		Start=ReplaceTrim(Start) : Over=ReplaceTrim(Over) : strHTML=strHTML
		s=Len(start) : o=Len(Over)

		If s = 0 Or o = 0  Then GetBody="$False$" : Exit Function
		strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(Over) & ")"
		On Error Resume Next
		Dim re
		Set re = New RegExp
		re.IgnoreCase = False
		re.Global = False
		re.Pattern = strPattern
		Set SS = re.Execute(strHTML)
		For Each Match In SS
			TempStr = Match.Value
		Next
		If TempStr="" Then'空字符串,结束函数名
			GetBody="$False$"
			Exit Function
		End If

		If IncluL=False then
			TempStr=Right(TempStr,Len(TempStr) -S)
		End if
		If IncluR=False then
			TempStr=Left(TempStr,Len(TempStr) - O)
		End if	
		If Err.number<>0 then	'出错,结束函数名
			GetBody="$False$"
			Exit Function
		End If
		Set SS = Nothing
		Set re = Nothing
		GetBody = TempStr
		Exit Function
	End Function
	'===============================================
	'函数名：GetArray
	'作  用：提取链接地址，以$Array$分隔
	'参  数：ConStr ------提取地址的原字符
	'参  数：StartStr ------开始字符串
	'参  数：OverStr ------结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'===============================================
	Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
	Dim TempStr,TempStr2,objRegExp,Matches,Match,Templisturl,TempStr_i
	Dim s,o 
	On Error Resume Next
	If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then
		GetArray="$False$"
		Exit Function
	End If
	StartStr=ReplaceTrim(StartStr) : OverStr=ReplaceTrim(OverStr) : ConStr=ConStr
	s=Len(StartStr) : o=Len(OverStr)
	TempStr=""
	Set objRegExp = New Regexp 
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True
	objRegExp.Pattern = "("&CorrectPattern(StartStr)&").+?("&CorrectPattern(OverStr)&")"
	Set Matches =objRegExp.Execute(ConStr) 
	For Each Match in Matches
		'If Templisturl =Match.Value then
		'Else
				TempStr_i=Match.Value
				If IncluL=False then
					TempStr_i=Right(TempStr_i,Len(TempStr_i) -S)
				End if
				If IncluR=False then
					TempStr_i=Left(TempStr_i,Len(TempStr_i) - O)
				End if	
				TempStr=TempStr & "$Array$" & TempStr_i
		'		Templisturl = Match.Value
		'End if
	Next 
	Set Matches=nothing
	
	If TempStr="" Then
		GetArray="$False$"
		Exit Function
	End If
	TempStr=Right(TempStr,Len(TempStr)-7)
	Set objRegExp=nothing
	Set Matches=nothing

	If TempStr="" then
		GetArray="$False$"
	Else
		GetArray=TempStr
	End if
	End Function
	'===============================================
	'函数名：ReplaceSaveRemoteFile
	'作  用：替换、保存远程图片
	'参  数：ConStr ------ 要替换的字符串
	'参  数：SaveTf ------ 是否保存文件，False不保存，True保存
	'参  数: TistUrl------ 当前网页地址
	'===============================================
	Function ReplaceSaveRemoteFile(ConStr,strInstallDir,ChannelDir,SaveTf,TistUrl,ModuleID)
	If ConStr="$False$" or ConStr="" or ChannelDir="" Then
		ReplaceSaveRemoteFile=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 ="<img.+?[^\>]>"
	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 ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
			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
		IncludePic=1'图片新闻
		Re.Pattern ="src\s*=\s*"
		TempStr=Re.Replace(TempStr,"")
	End If
	Set Matches=nothing
	Set Re=nothing
	If TempStr="" or IsNull(TempStr)=True Then