📄 collection.asp
字号:
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -