collection.asp

采用的是新云内核

<%
'=====================================================================
' 软件名称：新云网站管理系统
' 当前版本：NewCloud Site Manager System Version 2.0.0
' 文件名称：collection.asp
' 更新日期：2004-12-20
' 官方网站：新云网络(www.newasp.net) QQ：94022511
'=====================================================================
' Copyright 2002-2005 newasp.net - All Rights Reserved.
' newasp is a trademark of newasp.net
'=====================================================================
Dim Mynewasp,MyConn,IsConnection
IsConnection = False

Set Mynewasp = New ClsProcess

Class ClsProcess
	Private CacheName, Reloadtime, LocalCacheName, Cache_Data
	Private MaxFileSize, sAllowExtName
	Public PathFileName, blnPassedTest
	Public PictureExist

	'-- 下载大小限制
	Public Property Let MaxSize(ByVal NewValue)
		MaxFileSize = NewValue * 1024
	End Property
	'-- 下载类型限制
	Public Property Let AllowExt(ByVal NewValue)
		sAllowExtName = NewValue
	End Property

	Public Property Get PictureEx()
		PictureEx = PictureExist
	End Property
	Public Property Get AllFileName()
		AllFileName = PathFileName
	End Property

	Private Sub Class_Initialize()
		On Error Resume Next
		Reloadtime = 28800
		CacheName = "mynewasp"
		blnPassedTest = False
		PictureExist = False
		MaxFileSize = 0
		sAllowExtName = "gif|jpg|jpge|png|bmp|swf|fla|psd"
	End Sub

	Private Sub Class_Terminate()
		'-- Class_Terminate
	End Sub

	'===================服务器缓存部分函数开始===================
	Public Property Let Name(ByVal vNewValue)
		LocalCacheName = LCase(vNewValue)
		Cache_Data = Application(CacheName & "_" & LocalCacheName)
	End Property
	Public Property Let Value(ByVal vNewValue)
		If LocalCacheName <> "" Then
			ReDim Cache_Data(2)
			Cache_Data(0) = vNewValue
			Cache_Data(1) = Now()
			Application.Lock
			Application(CacheName & "_" & LocalCacheName) = Cache_Data
			Application.UnLock
		Else
			Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName."
		End If
	End Property
	Public Property Get Value()
		If LocalCacheName <> "" Then
			If IsArray(Cache_Data) Then
				Value = Cache_Data(0)
			Else
				'Err.Raise vbObjectError + 1, "NewaspCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."
			End If
		Else
			Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName."
		End If
	End Property
	Public Function ObjIsEmpty()
		ObjIsEmpty = True
		If Not IsArray(Cache_Data) Then Exit Function
		If Not IsDate(Cache_Data(1)) Then Exit Function
		If DateDiff("s", CDate(Cache_Data(1)), Now()) < (60 * Reloadtime) Then ObjIsEmpty = False
	End Function
	Public Sub DelCahe(MyCaheName)
		Application.Lock
		Application.Contents.Remove (CacheName & "_" & MyCaheName)
		Application.UnLock
	End Sub
	'===================服务器缓存部分函数结束===================
	
	Public Function ChkBoolean(ByVal Values)
		If TypeName(Values) = "Boolean" Or IsNumeric(Values) Or LCase(Values) = "false" Or LCase(Values) = "true" Then
			ChkBoolean = CBool(Values)
		Else
			ChkBoolean = False
		End If
	End Function

	Public Function CheckNumeric(ByVal CHECK_ID)
		If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then _
			CHECK_ID = CCur(CHECK_ID) _
		Else _
			CHECK_ID = 0
		CheckNumeric = CHECK_ID
	End Function

	Public Function ChkNumeric(ByVal CHECK_ID)
		If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then
			CHECK_ID = CLng(CHECK_ID)
		Else
			CHECK_ID = 0
		End If
		ChkNumeric = CHECK_ID
	End Function

	Public Function CheckNull(ByVal str)
		If Not IsNull(str) And Trim(str) <> "" Then
			CheckNull = True
		Else
			CheckNull = False
		End If
	End Function

	Public Function CheckStr(ByVal str)
		If IsNull(str) Then
			CheckStr = ""
			Exit Function
		End If
		str = Replace(str, Chr(0), "")
		CheckStr = Replace(str, "'", "''")
	End Function

	Public Function CheckNostr(ByVal str)
		str = Trim(str)
		If Len(str) = 0 Then
			CheckNostr = ""
			Exit Function
		End If
		str = Replace(str, Chr(0), vbNullString)
		str = Replace(str, Chr(9), vbNullString)
		str = Replace(str, Chr(10), vbNullString)
		str = Replace(str, Chr(13), vbNullString)
		str = Replace(str, Chr(34), vbNullString)
		str = Replace(str, Chr(39), vbNullString)
		str = Replace(str, Chr(255), vbNullString)
		str = Replace(str, "%", "％")
		CheckNostr = Trim(str)
	End Function

	Public Function CheckNullStr(ByVal str)
		If Not IsNull(str) And Trim(str) <> "" And LCase(str) <> "http://" Then
			CheckNullStr = Trim(Replace(Replace(Replace(Replace(str, vbNewLine, ""), Chr(9), ""), Chr(39), ""), Chr(34), ""))
		Else
			CheckNullStr = ""
		End If
	End Function

	Public Function CheckMapPath(ByVal strPath)
		On Error Resume Next
		Dim fullPath
		strPath = Replace(Replace(Trim(strPath), "//", "/"), "\\", "\")

		If strPath = "" Then strPath = "."
		If InStr(strPath, ":") = 0 Then
			strPath = Replace(Trim(strPath), "\", "/")
			fullPath = Server.MapPath(strPath)
		Else
			strPath = Replace(Trim(strPath), "/", "\")
			fullPath = Trim(strPath)
		End If
		If Right(fullPath, 1) <> "\" Then fullPath = fullPath & "\"
		
		CheckMapPath = fullPath
	End Function
	Public Function ChkMapPath(ByVal strPath)
		On Error Resume Next
		Dim fullPath
		strPath = Replace(Replace(Trim(strPath), "//", "/"), "\\", "\")

		If strPath = "" Then strPath = "."
		If InStr(strPath, ":") = 0 Then
			strPath = Replace(Trim(strPath), "\", "/")
			fullPath = Server.MapPath(strPath)
		Else
			strPath = Replace(Trim(strPath), "/", "\")
			fullPath = Trim(strPath)
		End If
		If Right(fullPath, 1) <> "\" Then fullPath = fullPath & "\"
		fullPath = Left(fullPath, Len(fullPath) - 1)
		
		ChkMapPath = fullPath
	End Function
	'================================================
	'函数名：CheckRemoteUrl
	'作  用： 判断远程URL
	'================================================
	Public Function CheckHTTP(ByVal URL)
		Dim Retrieval 
		
		On Error Resume Next
		Set Retrieval = CreateObject("MSXML2.XMLHTTP")
		With Retrieval
			.Open "HEAD", URL, False
			.send
			If .readyState <> 4 Then
				CheckHTTP = False
				Set Retrieval = Nothing
				Exit Function
			End If
			If .Status < 300 Then
				CheckHTTP = True
				Set Retrieval = Nothing
				Exit Function
			Else
				CheckHTTP = False
				Set Retrieval = Nothing
				Exit Function
			End If
		End With
		If Err.Number <> 0 Then
			CheckHTTP = False
			Err.Clear
			Set Retrieval = Nothing
			Exit Function
		End If
		Set Retrieval = Nothing
		Exit Function
	End Function
	'================================================
	'函数名：GetHTTPPage
	'作  用：获取HTTP页
	'参  数：url   ----远程URL
	'返回值：远程HTML代码
	'================================================
	Public Function GetRemoteData(ByVal URL, ByVal Cset)
		If Len(Cset) < 2 Then Cset = "GB2312"
		
		Dim strHeader
		Dim l
		
		On Error Resume Next
		
		Dim Retrieval
		Dim ObjStream
		Set ObjStream = CreateObject("ADODB.Stream")
		ObjStream.Type = 1
		ObjStream.Mode = 3
		ObjStream.Open
		Set Retrieval = CreateObject("MSXML2.XMLHTTP")
		With Retrieval
			.Open "GET", URL, False
			.setRequestHeader "Referer", URL
			.send
			If .readyState <> 4 Then Exit Function
			If .Status > 300 Then Exit Function
			'--获取目标网站文件头
			strHeader = .getResponseHeader("Content-Type")
			strHeader = UCase(strHeader)
			ObjStream.Write (.responseBody)
		End With
		Set Retrieval = Nothing
		
		If Len(strHeader) > 0 Then
			'--获取目标文件编码
			l = InStrRev(strHeader, "CHARSET=", -1, 1)
			If l > 0 Then
				Cset = Right(strHeader, Len(strHeader) - l - 7)
			Else
				Cset = Cset
			End If
		End If

		ObjStream.Position = 0
		ObjStream.Type = 2
		ObjStream.Charset = Trim(Cset)
		GetRemoteData = ObjStream.ReadText
		ObjStream.Close
		Set ObjStream = Nothing
		Exit Function
	End Function
	'================================================
	'函数名：FindMatch
	'作  用：截取相匹配的内容
	'返回值：截取后的字符串
	'================================================
	Public Function FindMatch(ByVal str, ByVal start, ByVal last)
		
		Dim Match
		Dim s
		Dim FilterStr
		Dim MatchStr
		Dim strContent
		Dim ArrayFilter()
		Dim i, n
		Dim bRepeat
		
		If Len(start) = 0 Or Len(last) = 0 Then Exit Function
		
		On Error Resume Next
		
		MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
		
		Dim re
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = MatchStr
		Set s = re.Execute(str)
		n = 0
		For Each Match In s
			If n = 0 Then
				n = n + 1
				ReDim ArrayFilter(n)
				ArrayFilter(n) = Match
			Else
				bRepeat = False
				For i = 0 To UBound(ArrayFilter)
					If UCase(Match) = UCase(ArrayFilter(i)) Then
						bRepeat = True
						Exit For
					End If
				Next
				If bRepeat = False Then
					n = n + 1
					ReDim Preserve ArrayFilter(n)
					ArrayFilter(n) = Match
				End If
			End If
		Next
		
		Set s = Nothing
		Set re = Nothing
		
		strContent = Join(ArrayFilter, "|||")
		strContent = Replace(strContent, start, "")
		strContent = Replace(strContent, last, "")
		
		FindMatch = Replace(strContent, "|||", vbNullString, 1, 1)
		Exit Function
	End Function
	'================================================
	'函数名：CutFixed
	'作  用：截取固定的字符串
	'参  数：strHTML   ----原字符串
	'       start ------ 开始字符串
	'       last ------ 结束字符串
	'================================================
	Public Function CutFixed(ByVal strHTML, ByVal start, ByVal last)
		Dim s
		Dim Match
		Dim strPattern
		Dim strContent
		Dim t, l

		t = Len(start): l = Len(last)
		If t = 0 Or l = 0 Then Exit Function

		strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"

		On Error Resume Next

		Dim re
		Set re = New RegExp
		re.IgnoreCase = False
		re.Global = False
		re.Pattern = strPattern

		Set s = re.Execute(strHTML)
		For Each Match In s
			strContent = Match.Value
		Next

		Set s = Nothing
		Set re = Nothing
		CutFixed = Mid(strContent, t + 1, Len(strContent) - l - t)
		Exit Function
	End Function
	'================================================
	'函数名：CutFixate
	'返回值：截取后的字符串
	'================================================
	Public Function CutFixate(ByVal strHTML, ByVal start, ByVal last)
		
		Dim s
		Dim Match
		Dim strPattern