|
'================================================
'函数名：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
'================================================
'函数名：ClearHtml
'作 用：过滤掉字符中所有的HTML代码
'参 数：Str ----原字符串
'返回值：过滤取后的字符串
'================================================
Public Function CheckHTMLToChar(ByVal str,ByVal strr)
On Error Resume Next
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "<(.[^>]*)>"
str = re.Replace(str,strr)
Set re = Nothing
CheckHTMLToChar = str
Exit Function
End Function
'================================================
'函数名：CheckStopKey
'作 用：判断是否有关键字而网站屏蔽该站
'================================================
Public Function CheckStopKey(ByVal HtmlCode)
KeyWord=split("暂时不能访问|当前访问的页面因为含有不允许的关键字","|")
For each key in KeyWord
If instr(HtmlCode,key)>0 then
CheckStopKey=true
Exit Function
Else
CheckStopKey=false
End if
Next
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 InStr(URL, "/")=0 and InStr(URL, ".")=0 and InStr(URL, "(")=0 then
FormatRemoteUrl=Left(CurrentUrl, InStrRev(CurrentUrl, "/"))&URL&"/"
Exit Function
end if
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
共7页: 上一页 [1] [2] 3 [4] [5] [6] [7] 下一页
|
