修改savepost.asp文件
找到
Dvbbs.MyUserInfo(Dvbbs.UserInfoCount-1) = Content '222行左右
修改為
Dvbbs.MyUserInfo(Dvbbs.UserInfoCount-1) = ReplaceRemoteUrl(Content)
在最后的 End Function 和 %> 之間增加（一定要看清，是之間不是最后）
'==================================================
'過程名：ReplaceRemoteUrl
'作 用：替換字符串中的遠程文件為本地文件并保存遠程文件
'參 數：strContent ------ 要替換的字符串
'==================================================
function ReplaceRemoteUrl(strContent)
if IsObjInstalled("Microsoft.XMLHTTP")=False then
ReplaceRemoteUrl=strContent
exit function
end if
dim re,RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,arrSaveFileName,ranNum,UploadFiles,FormPath
FormPath=CheckFolder&CreatePath() '上傳目錄路徑
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}(gif|jpg|png|bmp)))"
Set RemoteFile = re.Execute(strContent)
For Each RemoteFileurl in RemoteFile
arrSaveFileName = split(RemoteFileurl,".")
SaveFileType=arrSaveFileName(ubound(arrSaveFileName))
ranNum=int(900*rnd)+100
SaveFileName = FormPath&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType
call SaveRemoteFile(SaveFileName,RemoteFileurl)
strContent=Replace(strContent,RemoteFileurl,SaveFileName)
if UploadFiles="" then
UploadFiles=SaveFileName
else
UploadFiles=UploadFiles & "|" & SaveFileName
end if
Next
ReplaceRemoteUrl=strContent
end function
'==================================================
'過程名：SaveRemoteFile
'作 用：保存遠程的文件到本地
'參 數：LocalFileName ------ 本地文件名
' RemoteFileUrl ------ 遠程文件URL
'==================================================
sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", 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(LocalFileName),2
.Cancel()
.Close()
End With
Set Ads=nothing
end sub
'**************************************************
'函數名：IsObjInstalled
'作 用：檢查組件是否已經安裝
'參 數：strClassString ----組件名
'返回值：True ----已經安裝
' False ----沒有安裝
'**************************************************
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'按月份自動明名上傳文件夾,需要ＦＳＯ組件支持。
Function CreatePath()
Dim objFSO,Fsofolder,uploadpath
uploadpath=year(now)&"-"&month(now) '以年月創建上傳文件夾，格式：2003－8
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(Server.MapPath(CheckFolder&uploadpath))=False Then
objFSO.CreateFolder Server.MapPath(CheckFolder&uploadpath)
End If
If Err.Number = 0 Then
CreatePath=uploadpath&"/"
Else
CreatePath=""
End If
Set objFSO = Nothing
End Function
'讀取上傳目錄
Function CheckFolder()
If Dvbbs.Forum_Setting(76)="" Or Dvbbs.Forum_Setting(76)="0" Then Dvbbs.Forum_Setting(76)="UploadFile/"
CheckFolder = Replace(Replace(Dvbbs.Forum_Setting(76),Chr(0),""),".","")
'在目錄后加(/)
If Right(CheckFolder,1)<>"/" Then CheckFolder=CheckFolder&"/"
End Function
具體效果參考本站。使用本方法需要你的服務器支持FSO和XMLHTML組件。請在使用本修改前檢測一下你的服務器是否支持FSO和XMLHTML組件。
將以下代碼保存為check.asp文件，運行后即可知道你的服務器是否支持FSO和XMLHTML組件。
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<HEAD>
<TITLE> New Document </TITLE>
<META NAME="Generator" CONTENT="EditPlus">
<META NAME="Author" CONTENT="">
<META NAME="Keywords" CONTENT="">
<META NAME="Description" CONTENT="">
</HEAD>
<BODY>
<%
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 IsObjInstalled("Microsoft.XMLHTTP") = False then
Response.WRite "你的服務器不支持Microsoft.XMLHTTP組件，你不能使用本修改。"
Else
Response.WRite "你的服務器支持Microsoft.XMLHTTP組件，你可以使用。"
End If
%>
</BODY>
</HTML>
加好友 
發短信
新月派彎刀
Post By：2006/10/18 12:04:15 [只看該作者]
