clsuploadfile.asp

html生成静态页的小程序

<%
Dim objUpFileStream

Class clsUpLoadFile

	Dim objForm,objFile
	
	Public FileSize,FileType,SavePath,RootPath,FileNameType,FilePath

	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 CheckFileSize(sFileSize)
		If sFileSize / 1024 > FileSize Then
			Call MessageBox("请不要上传超过" & FileSize & "Kb的文件")
		End If
	End Sub
	
	Private Sub CheckFileType(sFileType)
		If InStr("|" & FileType & "|","|" & Lcase(sFileType) & "|")<=0 Then
			Call MessageBox("请上传以下格式（" & FileType & "）的文件")
		End If
	End Sub
	
	Function IntTo2Bit(sInt)
		If sInt<10 Then
			IntTo2Bit = "0" & sInt
			Else
				IntTo2Bit = sInt
		End If
	End Function

	Function FileAutoName(FileSize,FileType)
		Dim Path
		Path = SavePath
		
		Select Case FileNameType
			Case "1"
				Path = Path & Year(Date()) & IntTo2Bit(Month(Date())) & IntTo2Bit(Day(Date())) & IntTo2Bit(Hour(Time())) & IntTo2Bit(Minute(Time())) & IntTo2Bit(Second(Time())) & "." & FileType
			Case "2"
				Path = Path & Year(Date()) & "/" & IntTo2Bit(Month(Date())) & "/" & IntTo2Bit(Day(Date())) & IntTo2Bit(Hour(Time())) & IntTo2Bit(Minute(Time())) & IntTo2Bit(Second(Time())) & "." & FileType
			Case Else
				Path = Path & Year(Date()) & "/" & IntTo2Bit(Month(Date())) & "/" & IntTo2Bit(Day(Date())) & "/" & IntTo2Bit(Hour(Time())) & IntTo2Bit(Minute(Time())) & IntTo2Bit(Second(Time())) & "." & FileType
		End Select
		
		Dim pp_Path
		pp_Path = ""
		p_tmp = Split(Path,"/")
		For i = 0 To Ubound(p_tmp)-1
			pp_Path = pp_Path & p_tmp(i) & "/"
			If Not CheckFolder(Server.MapPath(RootPath & pp_Path)) Then Call CreateFolder(Server.MapPath(RootPath & pp_Path))	
		Next

		FileAutoName = Path
	End Function

'=======================================================================
	
	Public Function UpFile(strFile)
		Set oFile = File(strFile)
		If oFile.FileSize > 0 Then
			Call CheckFileSize(oFile.FileSize)
			
			tmpFileType = Split(oFile.FileName,".")
			
			Call CheckFileType(tmpFileType(Ubound(tmpFileType)))
			
			FilePath = FileAutoName(oFile.FileSize,tmpFileType(Ubound(tmpFileType)))
			
			oFile.SaveAs Server.MapPath(RootPath & FilePath)
		End If
		Set oFile = Nothing
	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 objUpFileStream = Server.CreateObject("Adodb" & ".Stream")
	  objUpFileStream.Type = 1
	  objUpFileStream.Mode =3
	  objUpFileStream.Open
	  objUpFileStream.Write  Request.BinaryRead(Request.TotalBytes)
	  objUpFileStream.Position=0
	  RequestData =objUpFileStream.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
		objUpFileStream.Position = iFormStart
		objUpFileStream.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
			objUpFileStream.Position = iInfoEnd 
			objUpFileStream.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
		objUpFileStream.Close
		set objUpFileStream =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
	
	Private Sub MessageBox(Msg)
		Response.Write("<script language=""javascript"">")
		Response.Write("alert(""" & Msg & """);")
		Response.Write("parent.close();")
		Response.Write("</script>")
		Response.End()
	End Sub
	
	'测试文件夹是否存在
	Function CheckFolder(Folder)
		Dim fso,Exists
		Set fso = CreateObject("Scripting.FileSystemObject")
		CheckFolder = fso.FolderExists(Folder)
		Set fso = Nothing
	End Function
	
	'创建文件夹
	Private Sub CreateFolder(Folder)
	  Dim fso
	  Set fso = CreateObject("Scripting.FileSystemObject")
	  fso.CreateFolder(Folder)
	  Set fso = Nothing
	End Sub
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
		objUpFileStream.position=FileStart
		objUpFileStream.copyto dr,FileSize
		dr.SaveToFile FullPath,2
		dr.Close
		set dr=nothing 
		SaveAs=false
	end function
End Class
%>