upload.vb

使用asp+sql编写的的各种程序案例

<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>