<% CheckLogin() dim action,sortType,saveFilePath,stype action = getForm("action", "get") stype = getForm("stype","get") sortType = getForm("sortType","get") Dim Tobj : Tobj =getForm("Tobj", "get") Dim Toimg : Toimg =getForm("Toimg", "get") if action="save" then response.write uploadfile() else %>
<% end if %> <% function uploadfile() dim immediate,attachdir,dirtype,maxattachsize,upext,saveFilePath,fType '上傳文件保存路徑，結尾不要帶/ select case sortType case "2" attachdir=sitePath&"/"&upLoadPath &"/news" case "3" attachdir=sitePath&"/"&upLoadPath &"/product" case "4" attachdir=sitePath&"/"&upLoadPath &"/down" case "5" attachdir=sitePath&"/"&upLoadPath &"/job" case "6" attachdir=sitePath&"/"&upLoadPath &"/album" case "8" attachdir=sitePath&"/"&upLoadPath &"/video" case "10" attachdir=sitePath&"/"&upLoadPath &"/sort" case "11" attachdir=sitePath&"/"&upLoadPath &"/links" case "12" attachdir=sitePath&"/"&upLoadPath &"/slide" case "13" attachdir=sitePath&"/"&upLoadPath &"/Logo" case "14" attachdir=sitePath&"/"&upLoadPath &"/ad" case "15" attachdir=sitePath case else attachdir=sitePath&"/"&upLoadPath &"/other" end select 'die attachdir 'createFolder attachdir,"folderdir" saveFilePath ="/upload/" & saveFilePath 'attachdir=sitePath+"/upload"'上傳文件保存路徑，結尾不要帶/ dirtype=2'1:按天存入目錄 2:按月存入目錄 3:按擴展名存目錄 建議使用按天存 if stype <> "video" then maxattachsize=2097152'最大上傳大小，默認是2M else maxattachsize=10240000'最大上傳大小，默認是10M end if upext="txt,rar,zip,jpg,jpeg,gif,png,swf,wmv,avi,wma,mp3,mid,ico"'上傳擴展名 server.ScriptTimeout=600 dim err,msg,upfile err = "" msg = "" set upfile=new upfile_class upfile.AllowExt=replace(upext,",",";")+";" upfile.GetData(maxattachsize) if upfile.isErr then select case upfile.isErr case 1 err="無數據提交" case 2 err="文件大小超過 "+cstr(maxattachsize)+"字節" case else err=upfile.ErrMessage end select alertMsgAndGo err,"-1" else dim attach_dir,attach_subdir,filename,extension,target,tmpfile,formName,oFile,fsize for each formName in upfile.file '列出所有上傳了的文件 set oFile=upfile.file(formname) if oFile.FileExt="" then alertMsgAndGo "無數據提交","-1" extension=oFile.FileExt fType=extension select case dirtype case 1 attach_subdir="day_"+DateFormat(now,"yymmdd") case 2 attach_subdir="month_"+DateFormat(now,"yymm") case 3 attach_subdir="ext_"+extension end select if sorttype=15 then attach_dir=attachdir+"/" else attach_dir=attachdir+"/"+attach_subdir+"/" end if '建文件夾 CreateFolder attach_dir,"folderdir" tmpfile=upfile.AutoSave(formName,Server.mappath(attach_dir)+"\") if upfile.isErr then if upfile.isErr=3 then err="上傳文件擴展名必需為："+upext else err=upfile.ErrMessage end if alertMsgAndGo err,"-1" else '生成隨機文件名並改名 Randomize timer if sortType=15 then delFile sitePath&"/"&"favicon.ico" filename="favicon.ico" else filename=DateFormat(now,"yyyymmddhhnnss")+cstr(cint(9999*Rnd))+"."+extension end if target=attach_dir+filename moveFile attach_dir+tmpfile,target if sortType<>99 then if waterMark=1 then waterMarkImg target,waterMarkLocation msg=target if immediate="1" then msg="!"+msg end if end if fsize=oFile.filesize set oFile=nothing %>
恭喜你！文件上傳成功。">點擊此處繼續上傳 <% if stype="image" or stype="sort" then dim inEditorStr Select Case fType Case "gif","jpg","png","bmp","jpeg","tif","iff" if stype="sort" then inEditorStr="oEditor.InsertHtml("""");" & vbCrLf 'inEditorStr="oEditor.InsertHtml("""");" & vbCrLf %> <% Case "swf" inEditorStr="oEditor.InsertHtml('')" & vbCrLf Case "mp3","wma" inEditorStr="oEditor.InsertHtml('')" & vbCrLf Case "rm","rmvb" inEditorStr="oEditor.InsertHtml('"& vbCrLf&_ "
"& vbCrLf&_ ""& vbCrLf&_ "
"& vbCrLf&_ "')}" & vbCrLf Case "ra" inEditorStr="oEditor.InsertHtml('"& vbCrLf&_ "')" & vbCrLf Case "asf","avi","wmv" inEditorStr="oEditor.InsertHtml('"& vbCrLf&_ "')" & vbCrLf Case Else inEditorStr="oEditor.InsertHtml('點擊下載此文件')" & vbCrLf End Select %> <% elseif stype="video" then echo "" %> <% elseif stype="file" then echo "" if toimg<>"" then echo "" 'echo "
"&filename&"上傳成功![ 重新上傳 ]
" end if next end if set upfile=nothing end function function jsonString(str) str=replace(str,"\","\\") str=replace(str,"/","\/") str=replace(str,"'","\'") jsonString=str end function Function Iif(expression,returntrue,returnfalse) If expression=true Then iif=returntrue Else iif=returnfalse End If End Function function DateFormat(strDate,fstr) if isdate(strDate) then dim i,temp temp=replace(fstr,"yyyy",DatePart("yyyy",strDate)) temp=replace(temp,"yy",mid(DatePart("yyyy",strDate),3)) temp=replace(temp,"y",DatePart("y",strDate)) temp=replace(temp,"w",DatePart("w",strDate)) temp=replace(temp,"ww",DatePart("ww",strDate)) temp=replace(temp,"q",DatePart("q",strDate)) temp=replace(temp,"mm",iif(len(DatePart("m",strDate))>1,DatePart("m",strDate),"0"&DatePart("m",strDate))) temp=replace(temp,"dd",iif(len(DatePart("d",strDate))>1,DatePart("d",strDate),"0"&DatePart("d",strDate))) temp=replace(temp,"hh",iif(len(DatePart("h",strDate))>1,DatePart("h",strDate),"0"&DatePart("h",strDate))) temp=replace(temp,"nn",iif(len(DatePart("n",strDate))>1,DatePart("n",strDate),"0"&DatePart("n",strDate))) temp=replace(temp,"ss",iif(len(DatePart("s",strDate))>1,DatePart("s",strDate),"0"&DatePart("s",strDate))) DateFormat=temp else DateFormat=false end if end function Function moveFile(oldfile,newfile) dim fs Set fs=Server.CreateObject("Scri"&"pting.File"&"Sys"&"temObject") fs.movefile Server.MapPath(oldfile),Server.MapPath(newfile) Set fs=Nothing End Function '---------------------------------------------------------------------- '文件上傳類 Class UpFile_Class Dim Form,File Dim AllowExt_ Dim NoAllowExt_ Dim IsDebug_ Private oUpFileStream Private isErr_ Private ErrMessage_ Private isGetData_ '------------------------------------------------------------------ '類的屬性 Public Property Get Version Version="無懼上傳類 Version V2.0" End Property Public Property Get isErr isErr=isErr_ End Property Public Property Get ErrMessage ErrMessage=ErrMessage_ End Property Public Property Get AllowExt AllowExt=AllowExt_ End Property Public Property Let AllowExt(Value) AllowExt_=LCase(Value) End Property Public Property Get NoAllowExt NoAllowExt=NoAllowExt_ End Property Public Property Let NoAllowExt(Value) NoAllowExt_=LCase(Value) End Property Public Property Let IsDebug(Value) IsDebug_=Value End Property '---------------------------------------------------------------- '類實現代碼 '初始化類 Private Sub Class_Initialize isErr_ = 0 NoAllowExt="asp;asa;cer;aspx;php;" NoAllowExt=LCase(NoAllowExt) AllowExt="" AllowExt=LCase(AllowExt) isGetData_=false End Sub '類結束 Private Sub Class_Terminate on error Resume Next '清除變量及對像 Form.RemoveAll Set Form = Nothing File.RemoveAll Set File = Nothing oUpFileStream.Close Set oUpFileStream = Nothing if Err.number<>0 then OutErr("清除類時發生錯誤!") End Sub '分析上傳的數據 Public Sub GetData (MaxSize) '定義變量 on error Resume Next if isGetData_=false then Dim RequestBinDate,sSpace,bCrLf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,oFileInfo Dim sFormValue,sFileName Dim iFindStart,iFindEnd Dim iFormStart,iFormEnd,sFormName '代碼開始 If Request.TotalBytes < 1 Then '如果沒有數據上傳 isErr_ = 1 ErrMessage_="沒有數據上傳,這是因為直接提交網址所產生的錯誤!" OutErr("沒有數據上傳,這是因為直接提交網址所產生的錯誤!!") Exit Sub End If If MaxSize > 0 Then '如果限制大小 If Request.TotalBytes > MaxSize Then isErr_ = 2 '如果上傳的數據超出限制大小 ErrMessage_="上傳的數據超出限制大小!" OutErr("上傳的數據超出限制大小!") Exit Sub End If End If Set Form = Server.CreateObject ("Scripting.Dictionary") Form.CompareMode = 1 Set File = Server.CreateObject ("Scripting.Dictionary") File.CompareMode = 1 Set tStream = Server.CreateObject ("ADODB.Stream") Set oUpFileStream = Server.CreateObject ("ADODB.Stream") if Err.number<>0 then OutErr("創建流對象(ADODB.STREAM)時出錯,可能系統不支持或沒有開通該組件") oUpFileStream.Type = 1 oUpFileStream.Mode = 3 oUpFileStream.Open oUpFileStream.Write Request.BinaryRead (Request.TotalBytes) oUpFileStream.Position = 0 RequestBinDate = oUpFileStream.Read iFormEnd = oUpFileStream.Size bCrLf = ChrB (13) & ChrB (10) '取得每個項目之間的分隔符 sSpace = MidB (RequestBinDate,1, InStrB (1,RequestBinDate,bCrLf)-1) iStart = LenB(sSpace) iFormStart = iStart+2 '分解項目 Do iInfoEnd = InStrB (iFormStart,RequestBinDate,bCrLf & bCrLf)+3 tStream.Type = 1 tStream.Mode = 3 tStream.Open oUpFileStream.Position = iFormStart oUpFileStream.CopyTo tStream,iInfoEnd-iFormStart tStream.Position = 0 tStream.Type = 2 tStream.CharSet = "utf-8" sInfo = tStream.ReadText '取得表單項目名稱 iFormStart = InStrB (iInfoEnd,RequestBinDate,sSpace)-1 iFindStart = InStr (22,sInfo,"name=""",1)+6 iFindEnd = InStr (iFindStart,sInfo,"""",1) sFormName = Mid(sinfo,iFindStart,iFindEnd-iFindStart) '如果是文件 If InStr (45,sInfo,"filename=""",1) > 0 Then Set oFileInfo = new FileInfo_Class '取得文件屬性 iFindStart = InStr (iFindEnd,sInfo,"filename=""",1)+10 iFindEnd = InStr (iFindStart,sInfo,""""&vbCrLf,1) sFileName = Trim(Mid(sinfo,iFindStart,iFindEnd-iFindStart)) oFileInfo.FileName = GetFileName(sFileName) oFileInfo.FilePath = GetFilePath(sFileName) oFileInfo.FileExt = GetFileExt(sFileName) iFindStart = InStr (iFindEnd,sInfo,"Content-Type: ",1)+14 iFindEnd = InStr (iFindStart,sInfo,vbCr) oFileInfo.FileMIME = Mid(sinfo,iFindStart,iFindEnd-iFindStart) oFileInfo.FileStart = iInfoEnd oFileInfo.FileSize = iFormStart -iInfoEnd -2 oFileInfo.FormName = sFormName file.add sFormName,oFileInfo else '如果是表單項目 tStream.Close tStream.Type = 1 tStream.Mode = 3 tStream.Open oUpFileStream.Position = iInfoEnd oUpFileStream.CopyTo tStream,iFormStart-iInfoEnd-2 tStream.Position = 0 tStream.Type = 2 tStream.CharSet = "utf-8" sFormValue = tStream.ReadText If Form.Exists (sFormName) Then Form (sFormName) = Form (sFormName) & ", " & sFormValue else Form.Add sFormName,sFormValue End If End If tStream.Close iFormStart = iFormStart+iStart+2 '如果到文件尾了就退出 Loop Until (iFormStart+2) >= iFormEnd if Err.number<>0 then OutErr("分解上傳數據時發生錯誤,可能客戶端的上傳數據不正確或不符合上傳數據規則") RequestBinDate = "" Set tStream = Nothing isGetData_=true end if End Sub '保存到文件,自動覆蓋已存在的同名文件 Public Function SaveToFile(Item,Path) SaveToFile=SaveToFileEx(Item,Path,True) End Function '保存到文件,自動設置文件名 Public Function AutoSave(Item,Path) AutoSave=SaveToFileEx(Item,Path,false) End Function '保存到文件,OVER為真時,自動覆蓋已存在的同名文件,否則自動把文件改名保存 Private Function SaveToFileEx(Item,Path,Over) On Error Resume Next Dim FileExt if file.Exists(Item) then Dim oFileStream Dim tmpPath isErr_=0 Set oFileStream = CreateObject ("ADODB.Stream") oFileStream.Type = 1 oFileStream.Mode = 3 oFileStream.CharSet = "utf-8" oFileStream.Open oUpFileStream.Position = File(Item).FileStart oUpFileStream.CopyTo oFileStream,File(Item).FileSize tmpPath=Split(Path,".")(0) FileExt=GetFileExt(Path) if Over then if isAllowExt(FileExt) then oFileStream.SaveToFile tmpPath & "." & FileExt,2 if Err.number<>0 then OutErr("保存文件時出錯,請檢查路徑,是否存在該上傳目錄!該文件保存路徑為" & tmpPath & "." & FileExt) Else isErr_=3 ErrMessage_="該後綴名的文件不允許上傳!" OutErr("該後綴名的文件不允許上傳") End if Else Path=GetFilePath(Path) dim fori fori=1 if isAllowExt(File(Item).FileExt) then do fori=fori+1 Err.Clear() tmpPath=Path&GetNewFileName()&"."&File(Item).FileExt oFileStream.SaveToFile tmpPath loop Until ((Err.number=0) or (fori>50)) if Err.number<>0 then OutErr("自動保存文件出錯,已經測試50次不同的文件名來保存,請檢查目錄是否存在!該文件最後一次保存時全路徑為"&Path&GetNewFileName()&"."&File(Item).FileExt) Else isErr_=3 ErrMessage_="該後綴名的文件不允許上傳!" OutErr("該後綴名的文件不允許上傳") End if End if oFileStream.Close Set oFileStream = Nothing else ErrMessage_="不存在該對象(如該文件沒有上傳,文件為空)!" OutErr("不存在該對象(如該文件沒有上傳,文件為空)") end if if isErr_=3 then SaveToFileEx="" else SaveToFileEx=GetFileName(tmpPath) End Function '取得文件數據 Public Function FileData(Item) isErr_=0 if file.Exists(Item) then if isAllowExt(File(Item).FileExt) then oUpFileStream.Position = File(Item).FileStart FileData = oUpFileStream.Read (File(Item).FileSize) Else isErr_=3 ErrMessage_="該後綴名的文件不允許上傳" OutErr("該後綴名的文件不允許上傳") FileData="" End if else ErrMessage_="不存在該對象(如該文件沒有上傳,文件為空)!" OutErr("不存在該對象(如該文件沒有上傳,文件為空)") end if End Function '取得文件路徑 Public function GetFilePath(FullPath) If FullPath <> "" Then GetFilePath = Left(FullPath,InStrRev(FullPath, "\")) Else GetFilePath = "" End If End function '取得文件名 Public Function GetFileName(FullPath) If FullPath <> "" Then GetFileName = mid(FullPath,InStrRev(FullPath, "\")+1) Else GetFileName = "" End If End function '取得文件的後綴名 Public Function GetFileExt(FullPath) If FullPath <> "" Then GetFileExt = LCase(Mid(FullPath,InStrRev(FullPath, ".")+1)) Else GetFileExt = "" End If End function '取得一個不重復的序號 Public Function GetNewFileName() dim ranNum dim dtNow dtNow=Now() randomize ranNum=int(90000*rnd)+10000 '以下這段由webboy提供 GetNewFileName=year(dtNow) & right("0" & month(dtNow),2) & right("0" & day(dtNow),2) & right("0" & hour(dtNow),2) & right("0" & minute(dtNow),2) & right("0" & second(dtNow),2) & ranNum End Function Public Function isAllowExt(Ext) If NoAllowExt = "" Then isAllowExt=cbool(InStr(1,";"&AllowExt&";",LCase(";"&Ext&";"))) Else Dim ar, a ar = Split(NoAllowExt, ";") For Each a In ar If a <> "" Then If InStr(LCase(Ext), LCase(a)) > 0 Then isAllowExt = False Exit Function End If End If Next isAllowExt = True End If End Function End Class Public Sub OutErr(ErrMsg) if IsDebug_=true then Response.Write ErrMsg Response.End End if End Sub '---------------------------------------------------------------------------------------------------- '文件屬性類 Class FileInfo_Class Dim FormName,FileName,FilePath,FileSize,FileMIME,FileStart,FileExt End Class %>