|
'================================================
'函数名：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
共7页: 上一页 [1] [2] [3] [4] 5 [6] [7] 下一页
| |
