ASP:无组件上传代码

upload.vb

 

<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
'定义全局变量保存用户上传的内容'
dim strmUpload
'自定义class处理上传文件'
Class FileUpload
 dim Form,File
 Private Sub Class_Initialize
  dim iStart,iFileNameStart,iFileNameEnd,iEnd,vbEnter,iFormStart,iFormEnd,theFile
  dim strDiv,mFormName,mFormValue,mFileName,mFileSize,mFilePath,iDivLen,mStr
  if Request.TotalBytes<1 then Exit Sub
  set Form=CreateObject("Scripting.Dictionary")
  set File=CreateObject("Scripting.Dictionary")
  set strmUpload=CreateObject("Adodb.Stream")
  strmUpload.mode=3
  strmUpload.type=1
  strmUpload.open
  strmUpload.write Request.BinaryRead(Request.TotalBytes)
  'vbscript中的换行符字符串'
  vbEnter=Chr(13)&Chr(10)
  '换行符的位置'
  iDivLen=InStrB(1,vbEnter)+1
  '表单中不同控件数据的分隔字符串'
  strDiv=SubStrB(1,iDivLen)
  '表单有效数据开始位置'
  iFormStart=iDivLen
  '表单有效数据结束位置'
  iFormEnd=InStrB(iformStart,strDiv)-1
  '循环得到表单中所有控件的值'
  while iFormStart < iFormEnd
   '得到控件的name'
   iStart=InStrB(iFormStart,"name=""")
   iEnd=InStrB(iStart+6,"""")
   mFormName=SubStrB(iStart+6,iEnd-iStart-6)
   '得到file控件的filename'
   iFileNameStart=InStrB(iEnd+1,"filename=""")
   '如果是file控件'
   if iFileNameStart>0 and iFileNameStart<iFormEnd then
    iFileNameEnd=InStrB(iFileNameStart+10,"""")
    mFileName=SubStrB(iFileNameStart+10,iFileNameEnd-iFileNameStart-10)
    iStart=InStrB(iFileNameEnd+1,vbEnter&vbEnter)
    iEnd=InStrB(iStart+4,vbEnter&strDiv)
    '如果上传了文件'
    if iEnd>iStart then
     '得到上传文件的大小'
     mFileSize=iEnd-iStart-4
    else
     mFileSize=0
    end if
    set theFile=new FileInfo
    theFile.FileName=getFileName(mFileName)
    theFile.FilePath=getFilePath(mFileName)
    theFile.FileSize=mFileSize
    theFile.FileStart=iStart+4
    theFile.FormName=FormName
    '将上传文件加入到file Directory中'
    file.add mFormName,theFile
   '如果不是file控件'
   else
    iStart=InStrB(iEnd+1,vbEnter&vbEnter)
    iEnd=InStrB(iStart+4,vbEnter&strDiv)
    
    if iEnd>iStart then
     mFormValue=SubStrB(iStart+4,iEnd-iStart-4)
    else
     mFormValue=""
    end if
    '将控件的名、值加入到form Directory中'
    form.Add mFormName,mFormValue
   end if
   '准备读取下一个控件值'
   iFormStart=iformEnd+iDivLen
   iFormEnd=InStrB(iformStart,strDiv)-1
  wend
 End Sub
 
 '类终结'
 Private Sub Class_Terminate 
  form.RemoveAll
  file.RemoveAll
  set form=nothing
  set file=nothing
  strmUpload.close
  set strmUpload=nothing
 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
 
 '返回子串
 Private Function SubStrB(theStart,theLen)
  dim i,c,stemp
  strmUpload.Position=theStart-1
  stemp=""
  for i=1 to theLen
   if strmUpload.EOS then Exit for
   c=ascB(strmUpload.Read(1))
   If c > 127 Then
   if strmUpload.EOS then Exit for
   stemp=stemp&Chr(AscW(ChrB(AscB(strmUpload.Read(1)))&ChrB(c)))
   i=i+1
   else
   stemp=stemp&Chr(c)
   End If
  Next
  SubStrB=stemp
 End function
 
 '返回指定字符串在strmUpload中的位置
 Private Function InStrB(theStart,varStr)
  dim i,j,bt,theLen,str
  InStrB=0
  '得到字节串
  Str=toByte(varStr)
  theLen=LenB(Str)
  for i=theStart to strmUpload.Size-theLen
   if i>strmUpload.size then exit Function
   strmUpload.Position=i-1
   if AscB(strmUpload.Read(1))=AscB(midB(Str,1)) then
   InStrB=i
   for j=2 to theLen
    if strmUpload.EOS then
     InStrB=0
     Exit for
    end if
    if AscB(strmUpload.Read(1))<>AscB(MidB(Str,j,1)) then
     InStrB=0
     Exit For
    end if
   next
   if InStrB<>0 then Exit Function
   end if
  next
 End function
 
  '将字符串转换成字节
 Private function toByte(Str)
  dim i,iCode,c,iLow,iHigh
  toByte=""
  For i=1 To Len(Str)
  c=mid(Str,i,1)
  iCode =Asc(c)
  If iCode<0 Then iCode = iCode + 65535
  If iCode>255 Then
   iLow = Left(Hex(Asc(c)),2)
   iHigh =Right(Hex(Asc(c)),2)
   toByte = toByte & chrB("&H"&iLow) & chrB("&H"&iHigh)
  Else
   toByte = toByte & chrB(AscB(c))
  End If
  Next
 End function
End Class

'自定义类FileInfo'
Class FileInfo
  dim FormName,FileName,FilePath,FileSize,FileStart,DBContent
  '类初始化'
 Private Sub Class_Initialize
    FileName = ""
    FilePath = ""
    FileSize = 0
    FileStart= 0
    FormName = ""
  DBContent = ""
  End Sub
 
 '自定义方法，将上传文件保存到服务器指定目录'
 Public function SaveAs(FullPath)
  dim dr,ErrorChar,i
  SaveAs=1
  if trim(fullpath)="" or FileSize=0 or FileStart=0 or FileName="" then exit function
  if FileStart=0 or right(fullpath,1)="/" then exit function
  set dr=CreateObject("Adodb.Stream")
  dr.Mode=3
  dr.Type=1
  dr.Open
  strmUpload.position=FileStart-1
  strmUpload.copyto dr,FileSize
  dr.SaveToFile FullPath,2
  dr.Close
  set dr=nothing
  SaveAs=0
   End function

 '自定义方法，将上传文件保存到数据库'
 Public function Save2DB()
    dim dr
    if FileSize=0 or FileStart=0 or FileName="" then exit function
    strmUpload.position=FileStart-1
  DBContent = strmUpload.Read(FileSize)
  End function
End Class
</SCRIPT>

 

file_upload.asp

 

<% Response.Buffer=True %>

<%
dim formPath,uploadsize,FileType
uploadsize= "200"  ''设置文件大小，单位是 K'
formPath= "files/"  ''设置保存目录，以程序所在目录为相对目录，可自己修改或创建。
FileType= ".zip.doc.jpg.gif.txt.bmp" ''设置限制上传文件类型，只支持三个字母的扩展名。'

dim upload,file,formName,iCount
dim err_str
'新建自定义对象FileUpload：upload'
set upload=new FileUpload
iCount=0
'循环所有上传文件'
for each formName in upload.file
 '生成一个文件对象'
 file_name=cstr(year(now()))&cstr(month(now()))&cstr(day(now()))&cstr(hour(now()))&cstr(minute(now()))&cstr(second(now()))
 set file=upload.file(formName) 
 if file.filesize=0 then
  HtmEnd "请选择你要上传的文件。"
  set upload=nothing
  response.end
 end if
 '判断文件大小' 
 if file.filesize>cint(uploadsize)*1024 then
  HtmEnd "文件大小超过了限制。"
  set upload=nothing
  response.end
 end if
 '判断文件格式'
 if Instr(FileType,GetExtendName(file.FileName)) then
  ext=right(file.FileName,4)
 else
  HtmEnd "文件格式不符合要求。"
      set upload=nothing
      response.end
 end if
 
 '如果上传了文件'
 if file.FileSize>0 then 
  file_name=file_name&ext      
  file.SaveAs Server.mappath(formPath&file_name)   ''保存文件
  response.write "<b>您的文件：</b> <a href='"&formPath&file_name&"'>"&file.FilePath&file.FileName&"</a>"
  response.write "<br><b>文件大小：</b> "&file.FileSize&" Byte"
  response.write "<br><b>◇已成功上传◇</b><br>"
  iCount=iCount+1
 end if
 '清空file对象'
 set file=nothing
next
 '删除upload对象'
set upload=nothing

sub HtmEnd(Msg)
 set upload=nothing
 response.write Msg&"</td></tr>"
 response.write "<tr align=""center"" valign=""middle"" bgcolor=""#cccccc"">"
 response.write "<td bgcolor=""#cccccc"" height=""25"">"
 response.write "<a href=""javascript:history.back();""> 返回 </a>"
 response.write "</td></tr></table></body></html>"
 response.end
end sub

function GetExtendName(FileName)
 dim ExtName
 ExtName = LCase(FileName)
 ExtName = right(ExtName,3)
 ExtName = right(ExtName,3-Instr(ExtName,"."))
 GetExtendName = ExtName
end function
%>