pload.asp 仿MOP对开式论坛程序 1.0源码程序 - ASP源码程序

www.gusucode.com > 仿MOP对开式论坛程序 1.0源码程序 > upload.asp
    <%@language="VBScript"%>
<!--#include file="title.asp"-->
<!--#include file="sub.asp"-->
<%
Server.ScriptTimeOut=500
contents=contents &"<title>文件上传－"& caption &"</title>"&_
"</head>"&_
"<body>"&_
""&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">"
if gbmaduser="" then
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">出错</td></tr><tr><td><br>你还没登陆或者已经掉线。<br>请<a href=""login.asp"">登陆</a>，2秒后自动执行<Script Language=""JavaScript"">setTimeout(""location.href='login.asp'"",3000)</script>。<br><br></td></tr>"
else
if validate<>creatvalidate(gb+imprison,ip) then
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">出错</td></tr><tr><td><br>验证Cookies信息出错，请<a href=""login.asp"">重新登陆</a>。<br>引起该错误的原因可能是因为你手动修改了Cookies。<br><br></td></tr>"
else
if gb<11 then
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">出错</td></tr><tr><td><br>你的"& gbname &"不足10，不能使用文件上传功能。<br><br></td></tr>"
else
Dim amount,delfile,i,upload,url,filename,filepath,fso,file,fileext
if gb<51 then
amount=3
elseif gb<101 then
amount=6
elseif gb<251 then
amount=10
elseif gb<501 then
amount=20
elseif gb<1001 then
amount=30
elseif gb<3001 then
amount=40
elseif gb<5001 then
amount=55
elseif gb<10001 then
amount=70
elseif gb<50001 then
amount=85
elseif gb<100001 then
amount=100
elseif gb<500001 then
amount=125
elseif gb<1000001 then
amount=150
elseif gb>1000001 then
amount=200
end if
delfile=Request.QueryString("delfile")
if IsNumeric(delfile) then
delfile=Clng(delfile)
else
delfile=0
end if
url=Request.ServerVariables("HTTP_REFERER")
if delfile>0 then
rs.Open "upfile Where id="& delfile,conn,1,3
if Not rs.Eof then
if rs("gbmaduser")=gbmaduser or bbsadmin>3 then
Set fso=CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.MapPath(rs("filename")))
Set fso=Nothing
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">删除文件</td></tr><tr><td><br>删除文件 "& rs("fileinfo") &" 成功。<br><br></td></tr>"
if Instr(url,"user.asp")>0 then delfile=rs("fileinfo")
rs.Delete
if Instr(url,"user.asp")>0 and Instr(url,"&delfile=")>0 then
Response.Redirect Left(url,Instr(url,"&delfile=")-1) &"&delfile="& delfile
elseif Instr(url,"user.asp")>0 then
Response.Redirect url &"&delfile="& delfile
end if
end if
end if
rs.Close
end if
Set upload=New UploadDate
filepath="upload/"& month(now) & day(now) &"/"
Set fso=CreateObject("Scripting.FileSystemObject")
if Not fso.FolderExists(Server.Mappath(filepath)) then fso.CreateFolder(Server.Mappath(filepath))
Set fso=Nothing
if Instr(url,"upload.asp")>0 and delfile=0 then
Set file=upload.file("file")
randomize()
filename=Year(now()) & Month(now()) & Day(now()) & Hour(now()) & Minute(now()) & Second(now()) & Right(Rnd,2)
fileext=Lcase(Right(file.filename,4))
if FileExt=".jpg" or FileExt=".gif" or FileExt=".png" or FileExt=".swf" or FileExt=".zip" or FileExt=".rar" then
if file.FileSize>0 then
if file.FileSize<1024*1024 then
file.SaveAs Server.MapPath(filepath & filename & fileext)
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">上传文件</td></tr><tr><td><br>上传文件 "& file.filename &" 成功。<br><br></td></tr>"
rs.Open "upfile Where id=0",conn,1,3
rs.AddNew
rs("filename")=filepath & filename & fileext
rs("fileinfo")=file.filename
rs("gbmaduser")=gbmaduser
rs.Update
rs.Close
else
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">上传文件</td></tr><tr><td><br>你上传的文件大小超过 1M，上传失败。<br><br></td></tr>"
end if
else
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">上传文件</td></tr><tr><td><br>你上传的文件大小为 0Byte，上传失败。<br><br></td></tr>"
end if
else
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">上传文件</td></tr><tr><td><br>你上传的文件类型错误，上传失败。<br><br></td></tr>"
end if
end if
contents=contents &"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">文件上传</td></tr>"
rs.Open "upfile Where gbmaduser='"& gbmaduser &"' Order by id Desc",conn,1,1
if rs.RecordCount+1>amount then
contents=contents &"<tr class=""tds""><td>"&_
"你上传的文件数已超过 "& amount &" 个，如果要上传更多文件请等到你"& gbname &"达到相应值。"&_
"</td></tr>"
else
contents=contents &"<form name=""upload"" onsubmit=""return validinput();"" method=""post"" action=""upload.asp"" enctype=""multipart/form-data"">"&_
"<tr class=""tds""><td>"&_
"<script language=""JavaScript"">"&_
"function validinput()"&_
"{"&_
"if ((document.upload.file.value.indexOf("".gif"")==-1) && (document.upload.file.value.indexOf("".Gif"")==-1) && (document.upload.file.value.indexOf("".GIF"")==-1) && (document.upload.file.value.indexOf("".jpg"")==-1) && (document.upload.file.value.indexOf("".Jpg"")==-1) && (document.upload.file.value.indexOf("".JPG"")==-1) && (document.upload.file.value.indexOf("".png"")==-1) && (document.upload.file.value.indexOf("".Png"")==-1) && (document.upload.file.value.indexOf("".PNG"")==-1) && (document.upload.file.value.indexOf("".swf"")==-1) && (document.upload.file.value.indexOf("".Swf"")==-1) && (document.upload.file.value.indexOf("".SWF"")==-1) && (document.upload.file.value.indexOf("".zip"")==-1) && (document.upload.file.value.indexOf("".Zip"")==-1) && (document.upload.file.value.indexOf("".ZIP"")==-1) && (document.upload.file.value.indexOf("".rar"")==-1) && (document.upload.file.value.indexOf("".Rar"")==-1) && (document.upload.file.value.indexOf("".RAR"")==-1)){"&_
"alert(""请选择.gif、.jpg、.png、.swf、.zip或.rar的文件。"");"&_
"document.upload.file.focus();"&_
"return false;"&_
"}"&_
"document.upload.button.disabled=""true"";"&_
"return true;"&_
"}"&_
"</script>"&_
"允许文件类型：.gif;.jpg;.png;.swf;.zip;.rar。大小：1M<br>其他格式请转换为这六种格式再上传。<br>请不要尝试上传不符合上面条件的文件。<br>你还可以上传"& amount-rs.RecordCount &"个文件。<br><br>"&_
"浏览文件：<input type=""file"" name=""file"" size=""15"" class=""iptwin"">　<input name=""button"" type=""submit"" value=""提交"" onmouseover=""this.className='over';"" onmouseout=""this.className='out';"" class=""out"">"&_
"</td></tr>"&_
"</form>"
end if
contents=contents &"</table>"&_
"<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tdc"">"&_
"<tr class=""toptr""><td class=""tdc"" height=""20"" background="""& theme &"02.gif"">我的文件</td></tr>"&_
"<tr class=""tds""><td>"&_
"<script language=""JavaScript"">"&_
"function copyurl(htmlurl)"&_
"{"&_
"document.all.hiddenurl.value=htmlurl;document.all.hiddenurl.select();url=document.all.hiddenurl.createTextRange();url.execCommand(""Copy"");"&_
"return false;"&_
"}"&_
"</script>"&_
"<input type=""hidden"" name=""hiddenurl"" value="""">"&_
"<table border=""0"" cellpadding=""3"" cellspacing=""3"" width=""100%"">"&_
"<tr class=""toptr""><td>文件名/备注</td><td width=""75"">操作</td></tr>"
For i=1 to rs.RecordCount
contents=contents &"<tr><td class=""otr"">&nbsp;<a href="""& rs("filename") &""" target=""_blank"">"& rs("fileinfo") &"</a></td><td><a href="""& rs("filename") &""" onClick=""return copyurl(this.href)"">复制URL</a> <a href=""upload.asp?delfile="& rs("id") &""">删除</a></td></tr>"
rs.MoveNext
Next
contents=contents &"</table>"&_
"</td></tr>"&_
"</table>"
rs.Close
end if
end if
end if
contents=contents &"</table>"&_
""
%>
<!--#include file="bottom.asp"-->
<Script Runat="Server" Language="VBScript">
Dim DateUpload
Class UploadDate
Dim objForm,objFile
Public Function Form(strForm)
strForm=lcase(strForm)
if not objForm.exists(strForm) then
Form=""
else
Form=objForm(strForm)
end if
end Function
Public Function File(strFile)
strFile=lcase(strFile)
if not objFile.exists(strFile) then
set File=new FileInfo
else
Set File=objFile(strFile)
end if
end Function
Private Sub Class_Initialize
Dim RequestData,sStart,vbCrlf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,theFile
Dim iFileSize,sFilePath,sFileType,sFormValue,sFileName
Dim iFindStart,iFindEnd
Dim iFormStart,iFormEnd,sFormName
Set objForm=Server.CreateObject("Scripting.Dictionary")
Set objFile=Server.CreateObject("Scripting.Dictionary")
if Request.TotalBytes<1 then Exit Sub
Set tStream=Server.CreateObject("Adodb.Stream")
Set DateUpload=Server.CreateObject("Adodb.Stream")
DateUpload.Type=1
DateUpload.Mode=3
DateUpload.Open
DateUpload.Write Request.BinaryRead(Request.TotalBytes)
DateUpload.Position=0
RequestData=DateUpload.Read
iFormStart=1
iFormEnd=LenB(RequestData)
vbCrlf=ChrB(13) & chrB(10)
sStart=MidB(RequestData,1,InStrB(iFormStart,RequestData,vbCrlf)-1)
iStart=LenB(sStart)
iFormStart=iFormStart+iStart+1
While (iFormStart+10)<iFormEnd
iInfoEnd=InStrB(iFormStart,RequestData,vbCrlf & vbCrlf)+3
tStream.Type=1
tStream.Mode=3
tStream.Open
DateUpload.Position=iFormStart
DateUpload.CopyTo tStream,iInfoEnd-iFormStart
tStream.Position=0
tStream.Type=2
tStream.Charset="gb2312"
sInfo=tStream.ReadText
tStream.Close
iFormStart=InStrB(iInfoEnd,RequestData,sStart)
iFindStart=InStr(22,sInfo,"name=""",1)+6
iFindEnd=InStr(iFindStart,sInfo,"""",1)
sFormName=lcase(Mid(sinfo,iFindStart,iFindEnd-iFindStart))
if InStr (45,sInfo,"filename=""",1)>0 then
Set theFile=new FileInfo
iFindStart=InStr(iFindEnd,sInfo,"filename=""",1)+10
iFindEnd=InStr(iFindStart,sInfo,"""",1)
sFileName=Mid(sinfo,iFindStart,iFindEnd-iFindStart)
theFile.FileName=getFileName(sFileName)
theFile.FilePath=getFilePath(sFileName)
iFindStart=InStr(iFindEnd,sInfo,"Content-Type: ",1)+14
iFindEnd=InStr(iFindStart,sInfo,vbCr)
theFile.FileType=Mid(sinfo,iFindStart,iFindEnd-iFindStart)
theFile.FileStart=iInfoEnd
theFile.FileSize=iFormStart-iInfoEnd-3
theFile.FormName=sFormName
if not objFile.Exists(sFormName) then
objFile.Add sFormName,theFile
end if
else
tStream.Type=1
tStream.Mode=3
tStream.Open
DateUpload.Position=iInfoEnd
DateUpload.CopyTo tStream,iFormStart-iInfoEnd-3
tStream.Position=0
tStream.Type=2
tStream.Charset="gb2312"
sFormValue=tStream.ReadText
tStream.Close
if objForm.Exists(sFormName) then
objForm(sFormName)=objForm(sFormName)&", "&sFormValue
else
objForm.Add sFormName,sFormValue
end if
end if
iFormStart=iFormStart+iStart+1
Wend
RequestData=""
Set tStream=Nothing
end Sub
Private Sub Class_Terminate
if Request.TotalBytes>0 then
objForm.RemoveAll
objFile.RemoveAll
Set objForm=Nothing
Set objFile=Nothing
DateUpload.Close
Set DateUpload=Nothing
end if
end Sub
Private Function GetFilePath(FullPath)
if FullPath<>"" Then
GetFilePath=left(FullPath,InStrRev(FullPath,"\"))
else
GetFilePath=""
end if
end Function
Private Function GetFileName(FullPath)
if FullPath<>"" Then
GetFileName=mid(FullPath,InStrRev(FullPath,"\")+1)
else
GetFileName=""
end if
End  Function
end Class
Class FileInfo
dim FormName,FileName,FilePath,FileSize,FileType,FileStart
Private Sub Class_Initialize
FileName=""
FilePath=""
FileSize=0
FileStart=0
FormName=""
FileType=""
end Sub
Public Function SaveAs(FullPath)
dim dr,ErrorChar,i
SaveAs=true
if trim(fullpath)="" or FileStart=0 or FileName="" or right(fullpath,1)="/" then exit function
Set dr=CreateObject("Adodb.Stream")
dr.Mode=3
dr.Type=1
dr.Open
DateUpload.position=FileStart
DateUpload.copyto dr,FileSize
dr.SaveToFile FullPath,2
dr.Close
Set dr=Nothing
SaveAs=false
end Function
End Class
</Script>