[ASP通用类]替换远程文件为本地文件并保存远程文件

不知道这个是不是叫通用类呢?ASP基础知识没学扎实,不好意思





1、将下面的文本文件下载,并将.TXT改为.ASP,里面有具体设置方法



2、调用方法:

<!--#include file="remote.asp"-->

文章入库的地方改成下面的代码

CODE:

[Copy to clipboard]

If sSaveFileSelect=True Then
     Rs("Content")=ReplaceRemoteUrl(ArticleContent,sSaveFilePath,sFileExt)
    Else
     Rs("Content")=ArticleContent
End If

<% '添加资源时是否保存远程图片 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 %>