Private Sub Class_Initialize
dim iStart, iEnd, boundary, FieldName, FileName, ContentType, ItemValue, theFile, LineEnd
set FForm=CreateObject("Scripting.Dictionary")
set FFile=CreateObject("Scripting.Dictionary")
set Upload_Stream=CreateObject("Adodb.Stream")
Upload_Stream.mode=3
Upload_Stream.type=1
Upload_Stream.open
set ConvertStream = Server.CreateObject("adodb.stream")
ConvertStream.Mode =3
ConvertStream.Charset="GB2312"
if Request.TotalBytes<1 then Exit Sub
'dStart = CDbl(Time)
'查找第一个边界
iStart = Search(Upload_Stream, ChrB(13)&ChrB(10), 1)
'取边界串
boundary = subString(1, iStart-1, false)
'不是结束边界,则循环
do while StrComp(subString(iStart, 2, false),ChrB(13)&ChrB(10))=0
iStart = iStart+2
'取表单项信息头
do while true
iEnd = Search(Upload_Stream, ChrB(13)&ChrB(10), iStart)
'分解信息头
line = subString(iStart, iEnd-iStart, true)
'移动位置
iStart = iEnd+2
if Line="" then Exit do
pos = instr(line,":")
if pos>0 then
if StrComp(left(Line,pos-1),"Content-Disposition",1)=0 then
'取表单项名称
FieldName = ExtractValue(Line,pos+1,"name")
'取文件名称
FileName = ExtractValue(Line,pos+1,"filename")
'删除文件路径
FileName = Mid(FileName,InStrRev(FileName, "\")+1)
elseif StrComp(left(Line,pos-1),"Content-Type",1)=0 then
'取文件类型
ContentType = trim(mid(Line,pos+1))
end if
end if
loop
'取表单项内容
if FileName<>"" then
'新建文件内容
set the
File = new FileInfo
theFile.Init FileName, ContentType
'文件流内容移到文件流中
MoveData Upload_Stream, theFile.Stream, iStart
'上传数据直接传入文件流，可以减少文件存储时间
iEnd = Search(theFile.Stream, boundary, 1)
'后继数据移入工作流
MoveData theFile.Stream, Upload_Stream, iEnd-2
'
FFile.add FieldName, theFile
'移动位置
iStart = iStart+2+LenB(boundary)
else
'查找边界
iEnd = Search(Upload_Stream, boundary, iStart)
'取表单项内容
ItemValue = subString(iStart, iEnd-2-iStart, true)
'
if FForm.Exists(FieldName) then
FForm.Item(FieldName) = FForm.Item(FieldName) & "," & ItemValue
else
FForm.Add FieldName, ItemValue
end if
'移动位置
iStart = iEnd+LenB(boundary)
end if
loop
'Response.Write "parse time:" & FormatNumber((CDbl(Time)-dStart)*24*60*60,-1,-1) & "<br>"
End Sub
Private Function Search(src, str, theStart)
iStart = theStart
pos=0
do while pos=0
'长度不够，读一块
if src.Size<(iStart+lenb(str)-1) then ReadChunk src
'取一段数据，约64K，可以减少内存需求
src.Position = iStart-1
buf = src.Read
'检测边界
pos=InStrB(buf,str)
'如果未找到,向后移动
if pos=0 then iStart = iStart+LenB(buf)-LenB(str)+1
loop
Search = iStart+pos-1
End function
private sub MoveData(Src, Dest, theStart)
Src.Position = theStart-1
Dest.Position = Dest.Size
Src.CopyTo dest
Src.Position = theStart-1
Src.SetEOS
end sub
private function ExtractValue(line,pos,name)
dim t, p
ExtractValue = ""
t = name + "="""
p = instr(pos,line,t)
if p>0 then
n1 = p+len(t)
n2 = instr(n1,line,"""")
if n2>n1 then ExtractValue = mid(line,n1,n2-n1)
end if
end function
Private Function subString(theStart,theLen, ConvertToUnicode)
if theLen>0 then
'当长度不够时，读一块数据
if Upload_Stream.Size<theStart+theLen-1 then ReadChunk Upload_Stream
Upload_Stream.Position=theStart-1
Binary =Upload_Stream.Read(theLen)
if ConvertToUnicode then
ConvertStream.Type = 1
ConvertStream.Open
ConvertStream.Write Binary
Co
nvertStream.Position = 0
ConvertStream.Type = 2
subString = ConvertStream.ReadText
ConvertStream.Close
else
subString = midB(Binary,1)
end if
else
subString = ""
end if
End function
Private Sub ReadChunk(src)
'读一块，通过一次读64K，可以防止数据量过大时内存溢出
if Response.IsClientConnected = false then Raise "网络连接中断"
BytesRead = 65536
src.Position = src.Size
src.Write Request.BinaryRead(BytesRead)
End Sub
'异常信息
Private Sub Raise(Message)
Err.Raise vbObjectError, "QuickUpload", Message
End Sub
Private Sub Class_Terminate
form.RemoveAll
file.RemoveAll
set form=nothing
set file=nothing
Upload_Stream.close
set Upload_Stream=nothing
ConvertStream.Close
set ConvertStream=nothing
End Sub
End Class
Class FileInfo
Private FFileName, FFileType, FFileStart, FFileSize, FStream
property get FileName
FileName = FFileName
end property
property get FileType
FileType = FFileType
end property
property get FileSize
FileSize = FStream.Size
end property
property get Stream
set Stream = FStream
end property
Public Sub Init(AFileName, AFileType)
FFileName = AFileName
FFileType = AFileType
End Sub
Public function SaveAs(FullPath)
dim dr,ErrorChar,i
'dStart = CDbl(Time)
SaveAs=1
if trim(fullpath)="" or right(fullpath,1)="/" then exit function
On Error Resume Next
FStream.SaveToFile FullPath,2
if Err.Number>0 then Response.Write "保存数据出错：" & Err.Description & "<br>"
SaveAs=0
'Response.Write "save time:" & FormatNumber((CDbl(Time)-dStart)*24*60*60,-1,-1) & "<br>"
end function
Private Sub Class_Initialize
set FStream=CreateObject("Adodb.Stream")
FStream.mode=3
FStream.type=1
FStream.open
end sub
Private Sub Class_Terminate
FStream.Close
set FStream=nothing
end sub
End Class