www.gusucode.com > 艺术签名文章资讯网源代码 > 艺术签名文章资讯网源代码/624/adminhtry/include/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 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 CutFixate = Trim(strContent) Exit Function End Function '================================================ '函数名:ReplaceTrim '作 用:过滤掉字符中所有的tab和回车和换行 '================================================ Public Function ReplaceTrim(ByVal strContent) On Error Resume Next Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")" strContent = re.Replace(strContent, vbNullString) Set re = Nothing ReplaceTrim = strContent Exit Function End Function '================================================ '函数名:ReplaceTrim '作 用:过滤掉字符中所有的tab和回车和换行 '================================================ Public Function ReplacedTrim(ByVal strContent) On Error Resume Next Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")" strContent = re.Replace(strContent, vbNullString) re.Pattern = "(<!--(.+?)-->)" strContent = re.Replace(strContent, vbNullString) Set re = Nothing ReplacedTrim = strContent Exit Function End Function Public Function CheckMatch(ByVal strContent, ByVal start, ByVal last) If Len(strContent) = 0 Then Exit Function If Len(start) = 0 Then CheckMatch = strContent Exit Function End If If Len(last) = 0 Then CheckMatch = strContent Exit Function End If Dim strPattern On Error Resume Next strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")" Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(" & vbNewLine & ")" strContent = re.Replace(strContent, vbNullString) re.Pattern = strPattern strContent = re.Replace(strContent, vbNullString) Set re = Nothing CheckMatch = strContent Exit Function End Function Private Function CorrectPattern(ByVal str) str = Replace(str, "\", "\\") str = Replace(str, "~", "\~") str = Replace(str, "!", "\!") str = Replace(str, "@", "\@") str = Replace(str, "#", "\#") str = Replace(str, "%", "\%") str = Replace(str, "^", "\^") str = Replace(str, "&", "\&") str = Replace(str, "*", "\*") str = Replace(str, "(", "\(") str = Replace(str, ")", "\)") str = Replace(str, "-", "\-") str = Replace(str, "+", "\+") str = Replace(str, "[", "\[") str = Replace(str, "]", "\]") str = Replace(str, "<", "\<") str = Replace(str, ">", "\>") str = Replace(str, ".", "\.") str = Replace(str, "/", "\/") str = Replace(str, "?", "\?") str = Replace(str, "=", "\=") str = Replace(str, "|", "\|") str = Replace(str, "$", "\$") CorrectPattern = str End Function '================================================ '函数名:ClearHtml '作 用:过滤掉字符中所有的HTML代码 '参 数:Str ----原字符串 '返回值:过滤取后的字符串 '================================================ Public Function CheckHTML(ByVal str) On Error Resume Next Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "<(.[^>]*)>" str = re.Replace(str, "") Set re = Nothing CheckHTML = str Exit Function End Function '================================================ '函数名:Formatime '作 用:格式化时间 '================================================ Public Function Formatime(ByVal datime) datime = Trim(Replace(Replace(Replace(Trim(datime), " ", ""), Chr(255), ""), Chr(127), "")) datime = Trim(Replace(Replace(Replace(Replace(datime, vbNewLine, ""), Chr(9), ""), Chr(39), ""), Chr(34), "")) If Not IsDate(datime) Then Formatime = Now Exit Function End If If Len(datime) < 11 Then Formatime = CDate(datime & " " & FormatDateTime(Now, 3)) Else Formatime = CDate(datime) End If End Function '================================================ '函数名:GetRemoteUrl '作 用:格式化成完整的URL '================================================ Public Function FormatRemoteUrl(ByVal CurrentUrl, ByVal URL) Dim strUrl If Len(URL) < 2 Or Len(URL) > 255 Or Len(CurrentUrl) < 2 Then FormatRemoteUrl = vbNullString Exit Function End If CurrentUrl = Trim(Replace(Replace(Replace(Replace(Replace(CurrentUrl, "'", vbNullString), """", vbNullString), vbNewLine, vbNullString), "\", "/"), "|", vbNullString)) URL = Trim(Replace(Replace(Replace(Replace(Replace(URL, "'", vbNullString), """", vbNullString), vbNewLine, vbNullString), "\", "/"), "|", vbNullString)) If InStr(9, CurrentUrl, "/") = 0 Then strUrl = CurrentUrl Else strUrl = Left(CurrentUrl, InStr(9, CurrentUrl, "/") - 1) End If If strUrl = vbNullString Then strUrl = CurrentUrl Select Case Left(LCase(URL), 6) Case "http:/", "https:", "ftp://", "rtsp:/", "mms://" FormatRemoteUrl = URL Exit Function End Select If Left(URL, 1) = "/" Then FormatRemoteUrl = strUrl & URL Exit Function End If If Left(URL, 3) = "../" Then Dim ArrayUrl Dim ArrayCurrentUrl Dim ArrayTemp() Dim strTemp Dim i, n Dim c, l n = 0 ArrayCurrentUrl = Split(CurrentUrl, "/") ArrayUrl = Split(URL, "../") c = UBound(ArrayCurrentUrl) l = UBound(ArrayUrl) + 1 If c > l + 2 Then For i = 0 To c - l ReDim Preserve ArrayTemp(n) ArrayTemp(n) = ArrayCurrentUrl(i) n = n + 1 Next strTemp = Join(ArrayTemp, "/") Else strTemp = strUrl End If URL = Replace(URL, "../", vbNullString) FormatRemoteUrl = strTemp & "/" & URL Exit Function End If strUrl = Left(CurrentUrl, InStrRev(CurrentUrl, "/")) FormatRemoteUrl = strUrl & Replace(URL, "./", vbNullString) Exit Function End Function '================================================ '函数名:FormatContentUrl '作 用:格式化URL '参 数:Str ----原字符串 ' url ----网站URL ' ChildUrl ----子目录URL '返回值:格式化取后的字符串 '================================================ Public Function FormatContentUrl(ByVal str, ByVal URL) Dim s_Content Dim re Dim ContentFile, ContentFileUrl Dim strTempUrl,strFileUrl s_Content = str On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "((src=|href=)((\S)+[.]{1}(" & sAllowExtName & ")))" Set ContentFile = re.Execute(s_Content) Dim sContentUrl(), n, i, bRepeat n = 0 For Each ContentFileUrl In ContentFile strFileUrl = Replace(Replace(Replace(Replace(ContentFileUrl.Value, "src=", "", 1, -1, 1), "href=", "", 1, -1, 1), "'", ""), Chr(34), "") If n = 0 Then n = n + 1 ReDim sContentUrl(n) sContentUrl(n) = strFileUrl Else bRepeat = False For i = 1 To UBound(sContentUrl) If UCase(strFileUrl) = UCase(sContentUrl(i)) Then bRepeat = True Exit For End If Next If bRepeat = False Then n = n + 1 ReDim Preserve sContentUrl(n) sContentUrl(n) = strFileUrl End If End If Next If n = 0 Then FormatContentUrl = s_Content Exit Function End If For i = 1 To n strTempUrl = sContentUrl(i) If LCase(Left(strTempUrl, 4)) <> "http" Then s_Content = Replace(s_Content, strTempUrl, FormatRemoteUrl(URL, strTempUrl), 1, -1, 1) End If Next Set re = Nothing PictureExist = True FormatContentUrl = s_Content Exit Function End Function '================================================ '函数名:SaveRemoteFile '作 用:保存远程的文件到本地 '参 数:s_LocalFileName ------ 本地文件名 ' s_RemoteFileUrl ------ 远程文件URL '返回值:True ----成功 ' False ----失败 '================================================ Public Function SaveRemoteFile(ByVal s_LocalFileName, ByVal s_RemoteFileUrl) Dim GetRemoteData Dim bError bError = False SaveRemoteFile = False On Error Resume Next Dim Retrieval Set Retrieval = CreateObject("MSXML2.XMLHTTP") With Retrieval .Open "GET", s_RemoteFileUrl, False, "", "" .setRequestHeader "Referer", s_RemoteFileUrl .send If .readyState <> 4 Then Exit Function If .Status > 300 Then Exit Function GetRemoteData = .responseBody End With Set Retrieval = Nothing If LenB(GetRemoteData) < 100 Then Exit Function If MaxFileSize > 0 Then If LenB(GetRemoteData) > MaxFileSize Then Exit Function End If Dim Ads Set Ads = Server.CreateObject("ADODB.Stream") With Ads .Type = 1 .Open .Write GetRemoteData .SaveToFile ChkMapPath(s_LocalFileName), 2 .Cancel .Close End With Set Ads = Nothing If Err.Number = 0 And bError = False Then SaveRemoteFile = True Else SaveRemoteFile = False Err.Clear End If End Function '================================================ '函数名:RemoteToLocal '作 用:替换字符串中的远程文件为本地文件并保存远程文件 '参 数: ' sHTML : 要替换的字符串 ' sExt : 执行替换的扩展名 '================================================ Public Function RemoteToLocal(ByVal sHTML, ByVal strPath) Dim s_Content Dim re Dim RemoteFile Dim RemoteFileUrl Dim SaveFileName Dim SaveFileType Dim a_RemoteUrl() Dim n Dim i Dim l Dim bRepeat Dim nFileNum Dim sContentPath s_Content = sHTML On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}(([A-Za-z0-9_-])+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sAllowExtName & ")))" Set RemoteFile = re.Execute(s_Content) n = 0 '---- 转入无重复数据 For Each RemoteFileUrl In RemoteFile If n = 0 Then n = n + 1 ReDim a_RemoteUrl(n) a_RemoteUrl(n) = RemoteFileUrl Else bRepeat = False For i = 1 To UBound(a_RemoteUrl) If UCase(RemoteFileUrl) = UCase(a_RemoteUrl(i)) Then bRepeat = True Exit For End If Next If bRepeat = False Then n = n + 1 ReDim Preserve a_RemoteUrl(n) a_RemoteUrl(n) = RemoteFileUrl End If End If Next Set RemoteFile = Nothing Set re = Nothing If n = 0 Then PathFileName = "" RemoteToLocal = s_Content Exit Function End If '---- 开始替换操作 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, "<%") re.Pattern = "(" & Chr(37) & ">)" strContent = re.Replace(strContent, "%>") 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", "K"), "B", "B"), "M", "M"), "G", "G"), "Y", "Y"), "T", "T"), "E", "E"), "S", "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, "'", "'") fString = Replace(fString, Chr(34), """) fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10), "") fString = Replace(fString, Chr(9), "") fString = Replace(fString, ">", ">") fString = Replace(fString, "<", "<") 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(MyAppPath & DBPath) If Err Then Err.Clear Set MyConn = Nothing Response.Write "数据库连接出错,请打开conn.asp检查采集数据库连接字串。" Response.End End If IsConnection = True End Sub %>