<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
''----------------------------------------
'　黄彦平　最后修改于2005.9.27
'　自动按时间重命名上传文件名
'  datefile=1 时按时间，反之保留原名
''----------------------------------------

dim Data_5xsoft
on error resume next
Class upload_5xsoft
  
dim objForm,objFile,Version

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 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
  Version="化境HTTP上传程序 Version 2.0"
  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 Data_5xsoft = Server.CreateObject("adodb.stream")
  Data_5xsoft.Type = 1
  Data_5xsoft.Mode =3
  Data_5xsoft.Open
  Data_5xsoft.Write  Request.BinaryRead(Request.TotalBytes)
  Data_5xsoft.Position=0
  RequestData =Data_5xsoft.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
	Data_5xsoft.Position = iFormStart
	Data_5xsoft.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
		Data_5xsoft.Position = iInfoEnd 
		Data_5xsoft.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
	Data_5xsoft.Close
	set Data_5xsoft =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
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(sPath,sFileName)
    dim dr,ErrorChar,i
    SaveAs=true
	sPath = Server.MapPath(sPath)
    If Right(sPath,1) <> "\" Then		'检测目录参数的完整性
       sPath = sPath & "\"
    End If
	'response.write spath & sfilename
	
	Fullpath=sPath & GetTFileName(sPath,sFileName)'按时间生成文件名再保存

    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
    Data_5xsoft.position=FileStart
    Data_5xsoft.copyto dr,FileSize
    'response.write fullpath
    dr.SaveToFile FullPath,2
    dr.Close
    set dr=nothing 
    SaveAs=sfilename  '将文件名回传给函数以用于保存
  end function
  
  '----------------------------------------------------------------
  '根据时间生成时间串
  '年   月 日 小时 分+递增号
  '0000 00 00 00   00+*

  '取得文件名，自动判断是否存在，如果存在则序号相加
  Public Function GetTFileName(Spath,sFileName)
	Dim fs
	Dim i
	Dim hFileName
	Dim rFileName
  '----------------------------0000 00 00 00 00*　START--------------------------------
   dim xStr,cu
   dim g_year,g_month,g_day, g_hour, g_minute
   cu=now()
   g_year=year(cu)
   g_month=month(cu)
   if g_month < 10 then g_month="0" & g_month
   g_day=day(cu)
   if g_day < 10 then g_day="0" & g_day
   g_hour=hour(cu)
   if g_hour < 10 then g_hour="0" & g_hour
   g_minute=minute(cu)
   if g_minute < 10 then g_minute="0" & g_minute
   g_Second=Second(time)
   if g_second<10 then g_second="0" & g_second
   xStr=g_year & g_month & g_day & g_hour & g_minute & g_Second
   xStr=trim(xStr)
  '----------------------------0000 00 00 00 * END--------------------------------
  '用时间生成的文件名
   if datefile=1 then 
      sFileName=xStr & Right(sFileName,4)'新的全路径文件名
   end if
    CheckPath(sPath)    '检查目录是否存在

  '	If fsotype=1 then									'如果支持FSO,则执行FSO过程
		Set fs = Server.CreateObject("Scripting.FileSystemObject")
		If fs.FileExists(Spath & bin2str(sFileName)) = True Then
			hFileName = sFileName
			rFileName = ""
			For i = LenB(sFileName) To 1 Step -1
				If MidB(sFileName, i, 1) = ChrB(Asc(".")) Then
					hFileName = LeftB(sFileName, i-1)
					rFileName = RightB(sFileName, LenB(sFileName)-i+1)
					Exit For
				End If
			Next

			For i = 0 to 9999 
				If fs.FileExists(Spath & bin2str(hFileName) & i & bin2str(rFileName)) = False Then
					FileName = hFileName & str2bin(i) & rFileName
					Exit For
				End If
			Next
		End If
		Set fs = Nothing
  '  End If
	GetTFileName = sFileName
  End Function

  '将二进制转为字符串
  Function bin2str(binstr)
	Dim BytesStream,StringReturn

	Set BytesStream = Server.CreateObject("ADODB.Stream")
		With BytesStream
			.Type = 2
			.Open
			.WriteText binstr
			.Position = 0
			.Charset = "GB2312"
			.Position = 2
			StringReturn = .ReadText
			.close
		End With
		Set BytesStream = Nothing
	bin2str = StringReturn
  End Function

  '字符转为二进制
  Function str2bin(str)
	Dim i
    For i = 1 To Len(str)
        str2bin = str2bin & ChrB(Asc(Mid(str, i, 1)))
    Next
  End Function

 '检测该目录是否存在，如果不存在，则建立该目录
  Function CheckPath(path)	
	Dim Fs
	set Fs=server.CreateObject("scripting.filesystemobject")
	if not fs.FolderExists(path) then
		Fs.CreateFolder(path)
	end if
	set Fs = nothing
  End function
  '-----------------------------------------------------------
  
  End Class
</SCRIPT>