asp下实现替换远程文件为本地文件并保存远程文件的代码

　　<%

　　'添加资源时是否保存远程图片

　　Const sSaveFileSelect=True

　　'远程图片保存目录,结尾请不要加“/”

　　Const sSaveFilePath="/images/News"

　　'远程图片保存类型

　　Const sFileExt="jpg|gif|bmp|png"

　　'/////////////////////////////////////////////////////

　　'作 用：替换字符串中的远程文件为本地文件并保存远程文件

　　'参 数：

　　'     sHTML        : 要替换的字符串

　　'     sSavePath    : 保存文件的路径

　　'     sExt         : 执行替换的扩展名

　　Function ReplaceRemoteUrl(sHTML, sSaveFilePath, sFileExt)

　　Dim s_Content

　　s_Content = sHTML

　　If IsObjInstalled("Microsoft.XMLHTTP") = False then

　　ReplaceRemoteUrl = s_Content

　　Exit Function

　　End If

　　Dim re, RemoteFile, RemoteFileurl,SaveFileName,SaveFileType,arrSaveFileNameS,arrSaveFileName,sSaveFilePaths

　　Set re = new RegExp

　　re.IgnoreCase = True

　　re.Global = True

　　re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sFileExt & ")))"

　　Set RemoteFile = re.Execute(s_Content)

　　For Each RemoteFileurl in RemoteFile

　　SaveFileType = Replace(Replace(RemoteFileurl,"/", "a"), ":", "a")

　　arrSaveFileName = Right(SaveFileType,12)

　　sSaveFilePaths=sSaveFilePath & "/"

　　SaveFileName = sSaveFilePaths & arrSaveFileName

　　Call SaveRemoteFile(SaveFileName, RemoteFileurl)

　　s_Content = Replace(s_Content,RemoteFileurl,SaveFileName)

　　Next

　　ReplaceRemoteUrl = s_Content

　　End Function

　　'////////////////////////////////////////

　　'作 用：保存远程的文件到本地

　　'参 数：LocalFileName ------ 本地文件名

　　'       RemoteFileUrl ------ 远程文件URL

　　'返回值：True ----成功

　　'        False ----失败

　　Sub SaveRemoteFile(s_LocalFileName,s_RemoteFileUrl)

　　Dim Ads, Retrieval, GetRemoteData

　　On Error Resume Next

　　Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")

　　With Retrieval

　　.Open "Get", s_RemoteFileUrl, False, "", ""

　　.Send

　　GetRemoteData = .ResponseBody

　　End With

　　Set Retrieval = Nothing

　　Set Ads = Server.CreateObject("Adodb.Stream")

　　With Ads

　　.Type = 1

　　.Open

　　.Write GetRemoteData

　　.SaveToFile Server.MapPath(s_LocalFileName), 2

　　.Cancel()

　　.Close()

　　End With

　　Set Ads=nothing

　　End Sub

　　'////////////////////////////////////////

　　'作 用：检查组件是否已经安装

　　'参 数：strClassString ----组件名

　　'返回值：True ----已经安装

　　'     False ----没有安装

　　Function IsObjInstalled(s_ClassString)

　　On Error Resume Next

　　IsObjInstalled = False

　　Err = 0

　　Dim xTestObj

　　Set xTestObj = Server.CreateObject(s_ClassString)

　　If 0 = Err Then IsObjInstalled = True

　　Set xTestObj = Nothing

　　Err = 0

　　End Function

　　%>

　　If sSaveFileSelect=True Then

　　Rs("Content")=ReplaceRemoteUrl(ArticleContent,sSaveFilePath,sFileExt)

　　Else

　　Rs("Content")=ArticleContent

　　End If