又为ajax上传工具重新写了一个服务器端上传程序

之前写了一个ajax上传工具。但是只是客户端的工具是我写的，服务器端的那个程序，我是修改了一个网上流传的无组件上传类。因为当时我还不懂什么adodb.stream什么的。但是我依然觉得它不够简洁。因为我知道它是可以一次性处理多个文件而且循环处理的。但是ajax上传工具一次只上传一个文件。为了让服务器资源能省的尽量省，我又不懈地研究，重新写了这么一个上传文件。把下面的代码保存为upload.asp吧：

<％@LANGUAGE="VBSCRIPT" CODEPAGE="936"％>
<％Option Explicit
Response.Buffer = True
response.charset = "gb2312"
Const uploadfolder="uploadpic"
Const allowExt="jpg,jpeg,gif,png,rar,doc,zip,xls,pdf,swf,avi,mp3,txt,htm,html"
Function BytestoStr(filestr)
 dim skipflag : skipflag = 0
 dim varlen,clow,i
 dim content : content = ""
 if not isnull(filestr) then
  varlen = lenb(filestr)
  for i=1 to varlen
   if skipflag=0 then
    clow = midb(filestr,i,1)
    if ascb(clow) > 127 then
     content = content & chr(ascw(midb(filestr,i+1,1) & clow))
     skipflag = 1
    else
     content = content & chr(ascb(clow))
    end if
   else
    skipflag = 0
   end if
  next
 end if
 BytestoStr = content
End Function
Function getFilepath(ext)
 dim folderpath,fso,filename
 folderpath=server.mappath(uploadfolder)
 set fso=server.createobject("Scripting.FileSystemObject")
 if Fso.FolderExists(folderpath)=false then fso.CreateFolder(folderpath)
 folderpath=folderpath&"\"&date()
 fileinfo=uploadfolder&date()
 if Fso.FolderExists(folderpath)=false then fso.CreateFolder(folderpath)
 filename=cstr(timer()*100)&"."&ext
 getFilepath=folderpath&"\"&filename
 fileinfo=fileinfo&"/"&filename
 set Fso=nothing
End Function
Function CheckExt(fileinfo)
 dim re
 set re=new regexp
 re.global=false
 re.ignorecase=true
 re.pattern="filename=""[^""]+\.(\w{2,4})"""
 if re.test(fileinfo)=false then
  response.write "{""err"":""\u4E0A\u4F20\u6587\u4EF6\u4E0D\u6B63\u786E"",""msg"":""""}"
  CheckExt=false
  set re=nothing
  exit function
 end if
 re.pattern="^[\s\S]+filename=""[^""]+\.(\w{2,4})""[\s\S]+$"
 Ext=re.replace(fileinfo,"$1")
 Ext=lcase(Ext)
 re.pattern="^("&replace(allowExt,",",")|(")&")$"
 if re.test(Ext)=false then
  response.write "{""err"":""\u6587\u4EF6\u7C7B\u578B\u4E0D\u6B63\u786E"",""msg"":""""}"
  CheckExt=false
 else
  CheckExt=true
 end if
 set re=nothing
End Function
If Request.serverVariables("request_method")="POST" then
 if Request.TotalBytes>204800 then
  response.write "{""err"":""\u6587\u4EF6\u592A\u5927\u4E86\2C\u4E0A\u4F20\u6587\u4EF6\u4E0D\u80FD\u8D85\u8FC7200K"",""msg"":""""}"
  response.end
 end if
 dim oStream,oBinary,istart,iseparate,ifinish,ilength,bcrlf,sStream,fileinfo,filepath,ext
 bcrlf=ChrB(13)&ChrB (10)
 set oStream=server.createobject("adodb.stream")
 oStream.Type = 1
 oStream.Mode = 3
 oStream.Open
 oBinary=Request.BinaryRead (Request.TotalBytes)
 oStream.write oBinary
 istart=instrb(oBinary,bcrlf&bcrlf)+3
 iseparate=leftb(oBinary,instrb(oBinary,bcrlf)-1)
 fileinfo=leftb(oBinary,istart-4)
 fileinfo=BytestoStr(fileinfo)
 if CheckExt(fileinfo)=false then
  oStream.close
  set oStream=nothing
  response.end
 end if
 filepath=getFilepath(ext)
 set sStream=server.createobject("adodb.stream")
 sStream.Type = 1
 sStream.Mode = 3
 sStream.Open
 ifinish=instrb(istart,oBinary,iseparate)-3
 ilength=ifinish-istart
 oStream.position=istart
 oStream.Copyto sStream,ilength
 sStream.savetofile filepath,2
 sStream.close
 oStream.close
 set sStream=nothing
 set oStream=nothing
 response.write "{""err"":"""",""msg"":"""&fileinfo&"""}"
End If
％>

这个上传程序，上面有两个参数可以手工修改，一个是上传文件夹，另一个是允许上传的文件格式。它会把上传的文件按日期分存到不同的文件夹里，如果该文件夹不存在，则自动创建。然后文件名是当前时间的厘秒数加扩展名。命名方式其实可以按自己的意愿重新写过的。改那个getfilepath函数就好了。

那个ajax上传组件在这里：

https://www.aspxhome.com/download/2009/12104.htm