文件上传

<%
Server.ScriptTimeout = 400 '设置超时时限
If Request.ServerVariables(""REQUEST_METHOD"") = ""POST"" Then 
  Dim Fields
  UploadSizeLimit = 10000000 '设置一次最大上传量
  Set Fields = GetUpload() '分解上传字段及取得文件内容
  p=SaveUpload(Fields, Server.MapPath(""."")) '保存于服务器端
  Fields = Empty 
End If
%>
<Table>
<form method=post ENCTYPE=""multipart/form-data"">
<TR><TD ColSpan=2>
<Table Width=100% Border=0 cellpadding=0 cellspacing=0><tr><TD>
<Div ID=files>
文件1:<input type=""file"" name=""File1""><br>
文件2:<input type=""file"" name=""File2"">
</Div>
<TD>
<input type=""submit"" Name=""Action"" value=""现在上传""> 
</TD></TR></Table> 
</TD></TR> 
</form> 
</Table> 


<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
Dim UploadSizeLimit

Function GetUpload()
Dim Result
Set Result = Nothing

If Request.ServerVariables(""REQUEST_METHOD"") = ""POST"" Then 
  Dim CT, PosB, Boundary, Length, PosE
  CT = Request.ServerVariables(""HTTP_Content_Type"") 
  If LCase(Left(CT, 19)) = ""multipart/form-data"" Then 
    PosB = InStr(LCase(CT), ""boundary="") 
      If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 
         Length = CLng(Request.ServerVariables(""HTTP_Content_Length"")) 
           if """" & UploadSizeLimit<>"""" then
              UploadSizeLimit = clng(UploadSizeLimit)
                  if Length > UploadSizeLimit then 
                     response.write(""length too max err!"")
                     exit function
                 end if
           end if

           If Length > 0 And Boundary <> """" Then 
               Boundary = ""--"" & Boundary
               Dim Head, Binary
               Binary = Request.BinaryRead(Length) 
               Set Result = SeparateFields(Binary, Boundary)
               Binary = Empty 
           Else
               response.write(""Zero length request ."")
           End If
      Else
          response.write( ""No file sent."")
      End If
 Else
    response.write(""Bad request method."")
 End If
 Set GetUpload = Result
End Function

Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)
Set Fields = CreateObject(""Scripting.Dictionary"")

Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
  Dim HeaderContent, FieldContent
  Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
  Dim Field, TwoCharsAfterEndBoundary
  PosEndOfHeader = 
         InstrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))
  HeaderContent = 
         MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
  FieldContent = 
         MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)
  GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type
  Set Field = CreateUploadField()

  Field.Name = FormFieldName
  Field.ContentDisposition = Content_Disposition
  Field.FilePath = SourceFileName
  Field.FileName = GetFileName(SourceFileName)
  Field.ContentType = Content_Type
  Field.Value = FieldContent
  Field.Length = LenB(FieldContent)
  Fields.Add FormFieldName, Field

  TwoCharsAfterEndBoundary = 
          BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
  isLastBoundary = TwoCharsAfterEndBoundary = ""--""
  If Not isLastBoundary Then 
    PosOpenBoundary = PosCloseBoundary
    PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary )
  End If
Loop

Set SeparateFields = Fields

End Function

Function BinaryToString(Bin_string_data)
Dim I, String_data

For I=1 to LenB(Bin_string_data)
  if AscB(MidB(bin_string_data, i, 1)) > 127 then
    string_data = 
               string_data & chr(Ascb(MidB(bin_string_data, i, 1))*256+Ascb(MidB(bin_string_data, i+1, 1)))
    i=i+1
  else
     string_data = string_data & ChrW(AscB(MidB(bin_string_data, i, 1)))
  end if 
Next 

BinaryToString = string_data
End Function

Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next 
StringToBinary = B
End Function

Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, ""content-disposition:"", "";""))
Name = (SeparateField(Head, ""name="", "";""))
If Left(Name, 1) = """""""" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, ""filename="", "";"")) 'ltrim
If Left(FileName, 1) = """""""" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, ""content-type:"", "";""))
End Function

Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function

Function GetFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case ""/"", ""\"": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
GetFileName = Mid(FullPath, PosF)
End Function

Function SaveUpload(Fields, DestinationFolder)
if DestinationFolder = """" then DestinationFolder = Server.MapPath(""."")
Dim FS, Field
Set FS = CreateObject(""Scripting.FileSystemObject"")
Dim TextStream
For Each Field In Fields.Items
if len(Field.FileName)>0 then
Set TextStream = FS.CreateTextFile(DestinationFolder & ""\"" & Field.FileName)
TextStream.Write BinaryToString(Field.Value) 
TextStream.Close
end if
Next
SaveUpload = Empty
End Function

</SCRIPT>


<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
this.Name = null
this.ContentDisposition = null
this.FileName = null
this.FilePath = null
this.ContentType = null
this.Value = null
this.Length = null
}
</SCRIPT>