<%
'================================================
' 函数名：SaveRemoteFile
' 作 用：保存远程文件到本地
' 参 数：strFileName ----保存文件的名称
' strRemoteUrl ----远程文件URL
' 返回值：布尔值 True/False
'================================================
Function SaveRemoteFile(ByVal strFileName, ByVal strRemoteUrl)
Dim oStream, Retrieval, GetRemoteData
SaveRemoteFile = False
On Error Resume Next
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
Retrieval.Open "GET", strRemoteUrl, False, "", ""
Retrieval.Send
If Retrieval.readyState <> 4 Then Exit Function
If Retrieval.Status > 300 Then Exit Function
GetRemoteData = Retrieval.ResponseBody
Set Retrieval = Nothing
If LenB(GetRemoteData) > 100 Then
Set oStream = Server.CreateObject("Adodb.Stream")
oStream.Type = 1
oStream.Mode = 3
oStream.Open
oStream.Write GetRemoteData
oStream.SaveToFile Server.MapPath(strFileName), 2
oStream.Cancel
oStream.Close
Set oStream = Nothing
Else
Exit Function
End If
If Err.Number = 0 Then
SaveRemoteFile = True
Else
Err.Clear
End If
End Function
%>

<%
Class Download_Cls
Private sUploadDir
Private nAllowSize
Private sAllowExt
Private sOriginalFileName
Private sSaveFileName
Private sPathFileName
Public Property Get RemoteFileName()
RemoteFileName = sOriginalFileName
End Property
Public Property Get LocalFileName()
LocalFileName = sSaveFileName
End Property
Public Property Get LocalFilePath()
LocalFilePath = sPathFileName
End Property
Public Property Let RemoteDir(ByVal strDir)
sUploadDir = strDir
End Property
Public Property Let AllowMaxSize(ByVal intSize)
nAllowSize = intSize
End Property
Public Property Let AllowExtName(ByVal strExt)
sAllowExt = strExt
End Property
Private Sub Class_Initialize()
On Error Resume Next
Script_Object = "Scripting.FileSystemObject"
sUploadDir = "UploadFile/"
nAllowSize = 500
sAllowExt = "gif|jpg|png|bmp"
End Sub
Public Function ChangeRemote(sHTML)
On Error Resume Next
Dim s_Content
s_Content = sHTML
On Error Resume Next
Dim re, s, RemoteFileUrl, SaveFileName, SaveFileType
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}(" & sAllowExt & ")))"
Set s = re.Execute(s_Content)
Dim a_RemoteUrl(), n, i, bRepeat
n = 0
' 转入无重复数据
For Each RemoteFileUrl In s
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
' 开始替换操作
Dim nFileNum, sContentPath,strFilePath
sContentPath = RelativePath2RootPath(sUploadDir)
nFileNum = 0
For i = 1 To n
SaveFileType = Mid(a_RemoteUrl(i), InStrRev(a_RemoteUrl(i), ".") + 1)
SaveFileName = GetRndFileName(SaveFileType)
strFilePath = sUploadDir & SaveFileName
If SaveRemoteFile(strFilePath, a_RemoteUrl(i)) = True Then
nFileNum = nFileNum + 1
If nFileNum > 0 Then
sOriginalFileName = sOriginalFileName & "|"
sSaveFileName = sSaveFileName & "|"
sPathFileName = sPathFileName & "|"
End If
sOriginalFileName = sOriginalFileName & Mid(a_RemoteUrl(i), InStrRev(a_RemoteUrl(i), "/") + 1)
sSaveFileName = sSaveFileName & SaveFileName
sPathFileName = sPathFileName & sContentPath & SaveFileName
s_Content = Replace(s_Content, a_RemoteUrl(i), sContentPath & SaveFileName, 1, -1, 1)
End If
Next
ChangeRemote = s_Content
End Function
Public Function RelativePath2RootPath(url)
'这个主要是实现../转换为实际路径
Dim sTempUrl
sTempUrl = url
If Left(sTempUrl, 1) = "/" Then
RelativePath2RootPath = sTempUrl
Exit Function
End If
Dim sWebEditorPath
sWebEditorPath = Request.ServerVariables("SCRIPT_NAME")
sWebEditorPath = Left(sWebEditorPath, InStrRev(sWebEditorPath, "/") - 1)
Do While Left(sTempUrl, 3) = "../"
sTempUrl = Mid(sTempUrl, 4)
sWebEditorPath = Left(sWebEditorPath, InStrRev(sWebEditorPath, "/") - 1)
Loop
RelativePath2RootPath = sWebEditorPath & "/" & sTempUrl
End Function
Public Function GetRndFileName(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
End Class
%>