www.gusucode.com > 全球营销软件站整站源码4月最新数据 4.0源码程序 > 801wyxqf\adminadmin\remoteupload.asp
<!--#include file="../conn.asp"-->
<!--#include file="setup.asp"-->
<!--#include file="inc/const.asp"-->
<!--#include file="inc/check.asp"-->
<%
'-- remoteupload.asp
Server.ScriptTimeout = 99999
Dim sAllowExt, nAllowSize, sUploadDir, sContentPath
Dim sFileExt, sOriginalFileName, sSaveFileName, sPathFileName, nFileNum
Dim SaveFilePath,UploadPath,strUploadDir
Dim ChannelSetting,m_strUploadPicDir
If Len(NewAsp.Channel_Setting &"") < 30 Then NewAsp.Channel_Setting = "0|||1|||2|||3|||4|||0|||1|||UploadPic/|||UploadFile/|||"
ChannelSetting = Split(NewAsp.Channel_Setting & "|||||||||||||||", "|||")
m_strUploadPicDir = Replace(Trim(ChannelSetting(7)), "\", "/")
If Len(m_strUploadPicDir) < 2 Then m_strUploadPicDir = "UploadPic/"
If Right(m_strUploadPicDir,1) <> "/" Then m_strUploadPicDir = m_strUploadPicDir & "/"
Dim Action
Action = LCase(Request("action"))
Call InitUpload()
If Action="upload" Then
Call UploadRemote()
End If
'-- 自动获取远程文件
Sub UploadRemote()
Dim strContent, i,objFile
strUploadDir = CreatePath(sUploadDir)
sUploadDir = sUploadDir & strUploadDir
For i = 1 To Request.form("NewAsp_UploadText").Count
strContent = strContent & Request.form("NewAsp_UploadText")(i)
Next
If sAllowExt <> "" Then
Set objFile = New Download_Cls
objFile.RemoteDir = sUploadDir
objFile.AllowMaxSize = nAllowSize
objFile.AllowExtName = sAllowExt
strContent = objFile.ChangeRemote(strContent)
sOriginalFileName = objFile.RemoteFileName
sSaveFileName = objFile.LocalFileName
sPathFileName = objFile.LocalFilePath
SaveFilePath = Replace(sPathFileName, NewAsp.InstallDir & NewAsp.ChannelDir, "",1,-1,1)
End If
Response.Write "<html><head><title>远程上传</title><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""/></head><body>" & _
"<input type=""hidden"" id=""UploadText"" value=""" & inHTML(strContent) & """/>" & _
"</body></html>"
Call OutScriptNoBack("try{parent.addUploadFile('" & sOriginalFileName & "', '" & sSaveFileName & "', '" & SaveFilePath & "');} catch(e){}")
Set objFile = Nothing
End Sub
'-- 初始化上传限制数据
Sub InitUpload()
If ChannelID <> 0 Then
sUploadDir = NewAsp.InstallDir & NewAsp.ChannelDir '上传文件路径
Else
sUploadDir = NewAsp.InstallDir '上传文件路径
End If
UploadPath = m_strUploadPicDir '上传文件目录
sUploadDir = sUploadDir & UploadPath '上传文件路径
nAllowSize = 102400 '允许上传的文件大小
sAllowExt = "gif|jpg|bmp|png|jpe|jpeg|tif|iff" '上传文件类型
sAllowExt = Replace(Replace(UCase(sAllowExt), "ASP", ""), "ASA", "")
End Sub
Function inHTML(str)
Dim sTemp
sTemp = str
inHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
inHTML = sTemp
End Function
Public Sub OutScriptNoBack(str)
Response.Write "<script type=""text/javascript"">" & vbCrLf
Response.Write "setUploadDone();" & vbCrLf
Response.Write str & vbCrLf
Response.Write "function setUploadDone() {" & vbCrLf
Response.Write " try{" & vbCrLf
Response.Write " var strHTML = document.getElementById(""UploadText"").value;" & vbCrLf
Response.Write " parent.FCK.SetHTML(strHTML);" & vbCrLf
Response.Write " }" & vbCrLf
Response.Write " catch(e){}" & vbCrLf
Response.Write " parent.remoteUploadDone();" & vbCrLf
Response.Write "}" & vbCrLf
Response.Write "</script>" & vbCrLf
End Sub
Function CreatePath(fromPath)
Dim uploadpath
uploadpath = Year(Now) & "-" & Month(Now) '以年月创建上传文件夹，格式：2007－8
uploadpath = Replace(uploadpath, ".", "_")
On Error Resume Next
If CreateFolderEx(Server.MapPath(fromPath & uploadpath)) Then
CreatePath = uploadpath & "/"
Else
CreatePath = ""
End If
Set objFSO = Nothing
End Function
Function CreateFolderEx(sPath)
On Error Resume Next
Dim strPath,fso
sPath = Replace(sPath, "\\", "\")
Err=False
Set fso = NewAsp.CreateAXObject(NewAsp.MainSetting(47))
If Trim(sPath) = "" Then Exit Function
If fso.FolderExists(sPath) Then
CreateFolderEx=True
Exit Function
End If
strPath = sPath
If Right(strPath, 1) = "\" Then strPath = Left(strPath, Len(strPath) - 1)
strPath = Left(strPath, InStrRev(strPath, "\") - 1)
If fso.FolderExists(strPath) = False Then
CreateFolderEx (strPath)
End If
If fso.FolderExists(sPath) = False Then fso.CreateFolder sPath
If Err Then
CreateFolderEx=False
Else
CreateFolderEx=True
End If
Set fso = Nothing
End Function
Class Download_Cls
Private sUploadDir,nAllowSize,sAllowExt
Private sOriginalFileName,sSaveFileName,sPathFileName
Private STREAMClassID,XMLHTTPClassID
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
sUploadDir = "UploadFile/"
nAllowSize = 50000
sAllowExt = "gif|jpg|png|bmp"
STREAMClassID = "ADO"+"DB"+"."+"Str"+"eam"
XMLHTTPClassID = "Micro"+"soft"+"."+"XML"+"HTTP"
End Sub
Public Function ChangeRemote(ByVal sHTML)
Dim s_Content
s_Content = sHTML
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
sOriginalFileName = Replace(sOriginalFileName, "|", vbNullString, 1, 1)
sSaveFileName = Replace(sSaveFileName, "|", vbNullString, 1, 1)
sPathFileName = Replace(sPathFileName, "|", vbNullString, 1, 1)
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 m_strPath
m_strPath = Request.ServerVariables("SCRIPT_NAME")
m_strPath = Left(m_strPath, InStrRev(m_strPath, "/") - 1)
Do While Left(sTempUrl, 3) = "../"
sTempUrl = Mid(sTempUrl, 4)
m_strPath = Left(m_strPath, InStrRev(m_strPath, "/") - 1)
Loop
RelativePath2RootPath = m_strPath & "/" & 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
Public Function SaveRemoteFile(ByVal s_LocalFileName, ByVal s_RemoteFileUrl)
On Error Resume Next
Dim GetRemoteData
Dim bError
bError = False
SaveRemoteFile = False
Dim Retrieval
Set Retrieval = NewAsp.CreateAXObject(XMLHTTPClassID)
With Retrieval
'.setTimeouts 1000,1000,1000,1000
.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
Dim Ads
Set Ads = NewAsp.CreateAXObject(STREAMClassID)
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile Server.MapPath(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
End Class
%>