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