collection.asp

采用的是新云内核

		'---- 开始替换操作
		Dim UploadPath
		l = InStrRev(strPath, "UploadPic", -1)
		UploadPath = Right(strPath, Len(strPath) - l + 1)
		
		nFileNum = 0
		For i = 1 To n
			SaveFileType = Mid(a_RemoteUrl(i), InStrRev(a_RemoteUrl(i), ".") + 1)
			SaveFileName = GetRndFileName(SaveFileType)
			If SaveRemoteFile(strPath & SaveFileName, a_RemoteUrl(i)) = True Then
				nFileNum = nFileNum + 1
				If nFileNum > 0 Then
					PathFileName = PathFileName & "|"
				End If
				PathFileName = PathFileName & UploadPath & SaveFileName
				s_Content = Replace(s_Content, a_RemoteUrl(i), strPath & SaveFileName, 1, -1, 1)
			End If
		Next
		RemoteToLocal = s_Content
		Exit Function
	End Function
	Public Function FormatUrl(ByVal str)
		If Not IsNull(str) And Trim(str) <> "" And LCase(str) <> "http://" And Len(str) < 255 Then
			str = Trim(Replace(Replace(Replace(Replace(str, vbNewLine, ""), Chr(9), ""), Chr(39), ""), Chr(34), ""))
			If InStr(str, "://") > 0 Then
				FormatUrl = str
			Else
				FormatUrl = "http://" & str
			End If
		Else
			FormatUrl = ""
		End If
	End Function
	'--内容过滤
	Public Function Html2Ubb(ByVal strContent, ByVal sRemoveCode)
		On Error Resume Next
		If Len(strContent) > 0 Then
			Dim ArrayCodes
			Dim re
			Set re = New RegExp
			If Len(sRemoveCode) < 21 Then sRemoveCode = "1|1|0|0|0|0|0|0|0|0|0|0"
			ArrayCodes = Split(sRemoveCode, "|")
			
			re.IgnoreCase = True
			re.Global = True
			
			'--清除script脚本
			If CInt(ArrayCodes(0)) = 1 Then
				re.Pattern = "(<s+cript(.+?)<\/s+cript>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有iframe框架
			If CInt(ArrayCodes(1)) = 1 Then
				re.Pattern = "(<iframe(.+?)<\/iframe>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有object对象
			If CInt(ArrayCodes(2)) = 1 Then
				re.Pattern = "(<object(.+?)<\/object>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有java applet
			If CInt(ArrayCodes(3)) = 1 Then
				re.Pattern = "(<applet(.+?)<\/applet>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有div标签
			If CInt(ArrayCodes(4)) = 1 Then
				re.Pattern = "(<DIV>)|(<DIV(.+?)>)"
				strContent = re.Replace(strContent, "")
				re.Pattern = "(<\/DIV>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有font标签
			If CInt(ArrayCodes(5)) = 1 Then
				re.Pattern = "(<FONT>)|(<FONT(.+?)>)"
				strContent = re.Replace(strContent, "")
				re.Pattern = "(<\/FONT>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有span标签
			If CInt(ArrayCodes(6)) = 1 Then
				re.Pattern = "(<SPAN>)|(<SPAN(.+?)>)"
				strContent = re.Replace(strContent, "")
				re.Pattern = "(<\/SPAN>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有A标签
			If CInt(ArrayCodes(7)) = 1 Then
				re.Pattern = "(<A>)|(<A(.+?)>)"
				strContent = re.Replace(strContent, "")
				re.Pattern = "(<\/A>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有img标签
			If CInt(ArrayCodes(8)) = 1 Then
				re.Pattern = "(<IMG(.+?)>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有FORM标签
			If CInt(ArrayCodes(9)) = 1 Then
				re.Pattern = "(<FORM>)|(<FORM(.+?)>)"
				strContent = re.Replace(strContent, "")
				re.Pattern = "(<\/FORM>)"
				strContent = re.Replace(strContent, "")
			End If
			'--清除所有HTML标签
			If CInt(ArrayCodes(10)) = 1 Then
				re.Pattern = "<(.[^>]*)>"
				strContent = re.Replace(strContent, "")
			End If
			re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")"
			strContent = re.Replace(strContent, vbNullString)
			re.Pattern = "(<!--(.+?)-->)"
			strContent = re.Replace(strContent, vbNullString)
			re.Pattern = "(<TBODY>)"
			strContent = re.Replace(strContent, "")
			re.Pattern = "(<\/TBODY>)"
			strContent = re.Replace(strContent, "")
			re.Pattern = "(<" & Chr(37) & ")"
			strContent = re.Replace(strContent, "&lt;%")
			re.Pattern = "(" & Chr(37) & ">)"
			strContent = re.Replace(strContent, "%&gt;")
			Set re = Nothing
			Html2Ubb = strContent
		Else
			Html2Ubb = ""
		End If
		Exit Function
	End Function
	'--分类名称替换
	Public Function ReplaceClass(ByVal ClassName, ByVal ClassList)
		If Len(ClassList) < 3 Then
			ReplaceClass = Trim(ClassName)
			Exit Function
		End If
		ClassName = Trim(ClassName)
		If Len(ClassName) = 0 Then Exit Function
		
		Dim i
		Dim ArrayClassList
		Dim ArrayClassName
		
		On Error Resume Next
		
		ArrayClassList = Split(ClassList, "$$$")
		For i = 0 To UBound(ArrayClassList)
			If Len(ArrayClassList(i)) > 2 Then
				ArrayClassName = Split(ArrayClassList(i), "|")
				ClassName = Replace(ClassName, ArrayClassName(0), ArrayClassName(1))
			End If
		Next
		ReplaceClass = ClassName
	End Function
	'格式化文件大小KB
	Public Function FormatSize(ByVal strFileSize)
		On Error Resume Next
		Dim valFileSize
		strFileSize = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(UCase(strFileSize), "Ｋ", "K"), "Ｂ", "B"), "Ｍ", "M"), "Ｇ", "G"), "Ｙ", "Y"), "Ｔ", "T"), "Ｅ", "E"), "Ｓ", "S")
		valFileSize = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(UCase(strFileSize), "BYTE", ""), "K", ""), "M", ""), "G", ""), "B", ""), "S", ""), " ", ""), "&NBSP;", ""), vbNewLine, ""), Chr(-24159), ""), Chr(9), ""), Chr(11), "")
		If IsNumeric(valFileSize) Then
			If InStr(strFileSize, "K") > 0 Then
				valFileSize = valFileSize
			ElseIf InStr(strFileSize, "M") > 0 Then
				valFileSize = valFileSize * 1024
			ElseIf InStr(strFileSize, "G") > 0 Then
				valFileSize = valFileSize * 1024 * 1024
			ElseIf InStr(strFileSize, "BYTE") > 0 Then
				valFileSize = valFileSize \ 1024
			Else
				valFileSize = valFileSize
			End If
		Else
			valFileSize = 0
		End If
		FormatSize = valFileSize
		Exit Function
	End Function
	'--建立日期目录
	Public Function BuildDatePath(ByVal DirForm)
		On Error Resume Next
		DirForm = CInt(DirForm)
		Dim DatePath
		Select Case DirForm
		Case 1
			DatePath = Year(Now) & "-" & Month(Now)
			BuildDatePath = DatePath & "/"
		Case 2
			DatePath = Year(Now) & "_" & Month(Now)
			BuildDatePath = DatePath & "/"
		Case 3
			DatePath = Year(Now) & Month(Now)
			BuildDatePath = DatePath & "/"
		Case 4
			DatePath = Year(Now)
			BuildDatePath = DatePath & "/"
		Case 5
			DatePath = Year(Now) & "/" & Month(Now)
			BuildDatePath = DatePath & "/"
		Case 6
			DatePath = Year(Now) & "/" & Month(Now) & "/" & Day(Now)
			BuildDatePath = DatePath & "/"
		Case 7
			DatePath = Year(Now) & Month(Now) & Day(Now)
			BuildDatePath = DatePath & "/"
		Case Else
			BuildDatePath = vbNullString
		End Select
	End Function
	'================================================
	'函数名：GetRndFileName
	'作  用：取随机文件名
	'参  数：sExt   ----原字符串
	'返回值：获取后的文件名
	'================================================
	Public Function GetRndFileName(ByVal sExt)
		Dim sRnd
		Randomize
		sRnd = Int(900 * Rnd) + 100
		GetRndFileName = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now) & sRnd & "." & sExt
	End Function
	'=================================================
	'函数名：GetFileExtName
	'作  用：获取文件扩展名
	'=================================================
	Public Function GetFileExtName(ByVal sName)
		Dim FileName
		FileName = Split(sName, ".")
		GetFileExtName = FileName(UBound(FileName))
	End Function
	'================================================
	'函数名：GetRndHits
	'作  用：取随机点击数
	'================================================
	Public Function GetRndHits()
		Dim sRnd
		Randomize
		sRnd = Int(900 * Rnd) + 100
		GetRndHits = sRnd
	End Function
	Public Function CheckPath(ByVal sPath)
		'-- 修正文件路径
		sPath = Trim(sPath)
		If Right(sPath, 1) <> "\" And sPath <> "" Then
			sPath = sPath & "\"
		End If
		CheckPath = sPath
	End Function
	'================================================
	'函数名：CreatedPathEx
	'作  用：FSO创建多级目录
	'参  数：LocalPath   ----原文件路径
	'返回值：False  ----  True
	'================================================
	Public Function CreatedPathEx(ByVal sPath)
		sPath = Replace(sPath, "/", "\")
		sPath = Replace(sPath, "\\", "\")
		On Error Resume Next
		
		Dim strHostPath,strPath
		Dim sPathItem,sTempPath
		Dim i,fso
		
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		strHostPath = Server.MapPath("/")
		If InStr(sPath, ":") = 0 Then sPath = Server.MapPath(sPath)
		If fso.FolderExists(sPath) Or Len(sPath) < 3 Then
			CreatedPathEx = True
			Exit Function
		End If
		
		strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1)
		sPathItem = Split(strPath, "\")
		
		If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then
			sTempPath = sPathItem(0)
		Else
			sTempPath = strHostPath
		End If
		
		For i = 1 To UBound(sPathItem)
			If sPathItem(i) <> "" Then
				sTempPath = sTempPath & "\" & sPathItem(i)
				If fso.FolderExists(sTempPath) = False Then
					fso.CreateFolder sTempPath
				End If
			End If
		Next
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
		CreatedPathEx = True
	End Function
	
	'--删除文件
	Public Function DeleteFiles(ByVal sFilePath)
		On Error Resume Next
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		fso.DeleteFile sFilePath, True
		DeleteFiles = True
		Set fso = Nothing
		Exit Function
	End Function
	'=============================================================
	'函数名：ChkFormStr
	'作  用：过滤表单字符
	'参  数：str   ----原字符串
	'返回值：过滤后的字符串
	'=============================================================
	Public Function FormatStr(ByVal str)
		Dim fString
		fString = str
		If Len(str) = 0 Then
			FormatStr = ""
			Exit Function
		End If
		fString = Replace(fString, "'", "&#39;")
		fString = Replace(fString, Chr(34), "&quot;")
		fString = Replace(fString, Chr(13), "")
		fString = Replace(fString, Chr(10), "")
		fString = Replace(fString, Chr(9), "")
		fString = Replace(fString, ">", "&gt;")
		fString = Replace(fString, "<", "&lt;")
		fString = Replace(fString, "%", "％")
		FormatStr = Trim(fString)
	End Function

End Class

Public Sub OutErrors(msg)
	Response.Write "<script language=""javascript"">" & vbCrLf
	Response.Write "alert(""" & Replace(Replace(Replace(msg, "<li>", "", 1, -1, 1), "</li>", "\n", 1, -1, 1), """", "\""") & """);"
	Response.Write "history.back();" & vbCrLf
	Response.Write "</script>" & vbCrLf
	Response.Flush
End Sub
Public Sub OutScript(msg)
	Response.Write "<script language=""javascript"">" & vbCrLf
	Response.Write "alert(""" & Replace(Replace(Replace(msg, "<li>", "", 1, -1, 1), "</li>", "\n", 1, -1, 1), """", "\""") & """);"
	Response.Write "location.replace(""" & Request.ServerVariables("HTTP_REFERER") & """);" & vbCrLf
	Response.Write "</script>" & vbCrLf
	Response.Flush: Response.End
End Sub
Public Sub ReturnError(ErrMsg)
	Response.Write "<br><br><table cellpadding=5 cellspacing=1 border=0 align=center class=tableBorder1>" & vbCrLf
	Response.Write "  <tr><th colspan=2>错误提示信息!</th></tr>" & vbCrLf
	Response.Write "  <tr><td colspan=2 align=center height=50 class=TableRow1>" & ErrMsg & "</td></tr>" & vbCrLf
	Response.Write "</table><br>" & vbCrLf
	Response.Flush
End Sub
'================================================
'函数名：ShowListPage
'作  用：通用分页
'================================================
Public Function ShowListPage(ByVal CurrentPage, ByVal Pcount, ByVal totalrec, ByVal PageNum, ByVal strLink, ByVal ListName)
	With Response
		.Write "<script>"
		.Write "ShowListPage("
		.Write CurrentPage
		.Write ","
		.Write Pcount
		.Write ","
		.Write totalrec
		.Write ","
		.Write PageNum
		.Write ",'"
		.Write strLink
		.Write "','"
		.Write ListName
		.Write "');"
		.Write "</script>" & vbNewLine
	End With
End Function
'-- 连接数据库
Sub DatabaseConnection()
	On Error Resume Next
	Set MyConn = Server.CreateObject("ADODB.Connection")
	MyConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ChkMapPath(DBPath)
	If Err Then
		Err.Clear
		Set MyConn = Nothing
		Response.Write "数据库连接出错，请打开conn.asp检查采集数据库连接字串。"
		Response.End
	End If
	IsConnection = True
End Sub
%>