精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● ASP>>文件上传>>[转载]不用组件来上传文件

主题:[转载]不用组件来上传文件
发信人: nightcat()
整理人: qcrsoft(2002-05-13 16:33:05), 站内信件
下面将介绍一系列可以不用组件,而使用纯粹的ASP代码来上传文件
呵呵,我想这将给很多拥有个人主页的网友带来极大的方便。
    这个纯ASP代码由三个包含文件组成,代码中只使用了FileSystemObject
和Direction两个ASP固有对象。而不需要任何附加的组件,注意,为了保证
这段代码的出处,我没有对代码中的任何地方进行过修改。
    希望能够对大家有所帮助:
文件fupload.inc
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
'Sample multiple binary files upload via ASP - upload include 
'c1997-1999 Antonin Foller, PSTRUH Software, http://www.pstruh.cz
'The file is part of ScriptUtilities library
'The file enables http upload to ASP without any components.
'But there is a small problem - ASP does not allow save binary data to
 the disk.
' So you can use the upload for :
' 1. Upload small text (or HTML) files to server-side disk (Save the d
ata by filesystem object)
' 2. Upload binary/text files of any size to server-side database (RS(
"BinField") = Upload("FormField").Value


'Limit of upload size
Dim UploadSizeLimit

'********************************** GetUpload ************************
**********
'This function reads all form fields from binary input and returns it 
as a dictionary object.
'The dictionary object containing form fields. Each form field is repr
esented by six values :
'.Name name of the form field (<Input Name="..." Type="File,...">)
'.ContentDisposition = Content-Disposition of the form field
'.FileName = Source file name for <input type=file>
'.ContentType = Content-Type for <input type=file>
'.Value = Binary value of the source field. 
'.Length = Len of the binary data field
Function GetUpload()
  Dim Result
  Set Result = Nothing
  If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request 
method must be "POST"
    Dim CT, PosB, Boundary, Length, PosE
    CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-T
ype header
    If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type 
header must be "multipart/form-data"
      'This is upload request.
      'Get the boundary and length from Content-Type header
      PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
      If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundar
y
      Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'G
et Content-Length header
      if "" & UploadSizeLimit<>"" then
        UploadSizeLimit = clng(UploadSizeLimit)
        if Length > UploadSizeLimit then 
'          on error resume next 'Clears the input buffer
'            response.AddHeader "Connection", "Close"
'          on error goto 0
          Request.BinaryRead(Length)
          Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Leng
th,0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit,0) & "B"

          exit function
        end if
      end if
      
      If Length > 0 And Boundary <> "" Then 'Are there required inform
ations about upload ?
        Boundary = "--" & Boundary
        Dim Head, Binary
        Binary = Request.BinaryRead(Length) 'Reads binary data from cl
ient
        
        'Retrieves the upload fields from binary data
        Set Result = SeparateFields(Binary, Boundary)
        Binary = Empty 'Clear variables
      Else
        Err.Raise 10, "GetUpload", "Zero length request ."
      End If
    Else
      Err.Raise 11, "GetUpload", "No file sent."
    End If
  Else
    Err.Raise 1, "GetUpload", "Bad request method."
  End If
  Set GetUpload = Result
End Function

'********************************** SeparateFields *******************
***************
'This function retrieves the upload fields from binary data and retuns
 the fields as array
'Binary is safearray of all raw binary data from input.
Function SeparateFields(Binary, Boundary)
  Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundar
y
  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 isLas
tBoundary)
    'Header and file/source field data
    Dim HeaderContent, FieldContent
    'Header fields
    Dim Content_Disposition, FormFieldName, SourceFileName, Content_Ty
pe
    'Helping variables
    Dim Field, TwoCharsAfterEndBoundary
    'Get end of header
        PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binar
y, StringToBinary(vbCrLf + vbCrLf))

    'Separates field header
        HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) 
+ 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
        
    'Separates field content
        FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoun
dary - (PosEndOfHeader + 4) - 2)

    'Separates header fields from header
    GetHeadFields BinaryToString(HeaderContent), Content_Disposition, 
FormFieldName, SourceFileName, Content_Type

    'Create one field and assign parameters
    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

    'Is this ending boundary ?
    TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBou
ndary + LenB(Boundary), 2))
        'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
    isLastBoundary = TwoCharsAfterEndBoundary = "--"
    If Not isLastBoundary Then 'This is not ending boundary - go to ne
xt form field.
      PosOpenBoundary = PosCloseBoundary
            PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary)
, Binary, Boundary )
    End If
  Loop
  Set SeparateFields = Fields
End Function

'********************************** Utilities ************************
**********
Function BinaryToString(Binary)
    Dim I, S
    For I=1 to LenB(Binary)
        S = S & Chr(AscB(MidB(Binary,I,1)))
    Next 
    BinaryToString = S
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

'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName
, Content_Type)
  Content_Disposition = LTrim(SeparateField(Head, "content-disposition
:", ";"))
  Name = (SeparateField(Head, "name=", ";")) 'ltrim
  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(Fil
eName) - 2)
  Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function

'Separets one filed between sStart and sEnd
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

'Separetes file name from the full path of file
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
</SCRIPT>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
//The function creates Field object.
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>



文件futils.inc
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
'True PureASP upload - enables save of uploaded text fields to the dis
k.
'c1997-1999 Antonin Foller, PSTRUH Software, http://www.pstruh.cz
'The file is part of ScriptUtilities library
'The file enables http upload to ASP without any components.
'But there is a small problem - ASP does not allow save binary data to
 the disk.
' So you can use the upload for :
' 1. Upload small text (or HTML) files to server-side disk (Save the d
ata by filesystem object)
' 2. Upload binary/text files of any size to server-side database (RS(
"BinField") = Upload("FormField").Value

'All uploaded files and log file will be saved to the next folder :
Dim LogFolder
LogFolder = Server.MapPath(".")

'********************************** SaveUpload ***********************
***********
'This function creates folder and saves contents of the source fields 
to the disk.
'The fields are saved as files with names of form-field names.
'Also writes one line to the log file with basic informations about up
load.
Function SaveUpload(Fields, DestinationFolder, LogFolder)
  if DestinationFolder = "" then DestinationFolder = Server.MapPath(".
")

  Dim UploadNumber, OutFileName, FS, OutFolder, TimeName, Field
  Dim LogLine, pLogLine, OutLine

  'Create unique upload folder
  Application.Lock
    if Application("UploadNumber") = "" then 
      Application("UploadNumber") = 1
    else
      Application("UploadNumber") = Application("UploadNumber") + 1
    end if
    UploadNumber = Application("UploadNumber")
  Application.UnLock

  TimeName = Right("0" & Year(Now), 2) & Right("0" & Month(Now), 2) & 
Right("0" & Day(Now), 2) & "_" & Right("0" & Hour(Now), 2) & Right("0"
 & Minute(Now), 2) & Right("0" & Second(Now), 2) & "-" & UploadNumber

  Set FS = CreateObject("Scripting.FileSystemObject")
  Set OutFolder = FS.CreateFolder(DestinationFolder + "\" + TimeName)


  Dim TextStream
  'Save the uploaded fields and create log line
  For Each Field In Fields.Items
    'Write content of the field to the disk
    '!!!! This function uses FileSystemObject to save the file. !!!!!

    'So you can only use text files to upload. Save binary files by th
e function takes undefined results.
    'To upload binary files see ScriptUtilities, http://www.pstruh.cz


    'You can save files with original file names :
    'Set TextStream = FS.CreateTextFile(OutFolder & "\" & Field.FileNa
me )
    
    'Or with names of the fields
    Set TextStream = FS.CreateTextFile(OutFolder & "\" & Field.Name & 
".")

        'And this is the problem why only short text files - BinaryToS
tring uses char-to-char conversion. It takes a lot of computer time.
    TextStream.Write BinaryToString(Field.Value) ' BinaryToString is i
n upload.inc.
    TextStream.Close
    

    'Create log line with info about the field
    LogLine = LogLine & """" & LogF(Field.name) & LogSeparator & LogF(
Field.Length) & LogSeparator & LogF(Field.ContentDisposition) & LogSep
arator & LogF(Field.FileName) & LogSeparator & LogF(Field.ContentType)
 & """" & LogSeparator
  Next
  
  'Creates line with global request info
  pLogLine = pLogLine & Request.ServerVariables("REMOTE_ADDR") & LogSe
parator
  pLogLine = pLogLine & LogF(Request.ServerVariables("LOGON_USER")) & 
LogSeparator
  pLogLine = pLogLine & Request.ServerVariables("HTTP_Content_Length")
 & LogSeparator
  pLogLine = pLogLine & OutFolder & LogSeparator
  pLogLine = pLogLine & LogLine
  pLogLine = pLogLine & LogF(Request.ServerVariables("HTTP_USER_AGENT"
)) & LogSeparator
  pLogLine = pLogLine & LogF(Request.ServerVariables("HTTP_COOKIE"))

  'Create output line for the client
  OutLine = OutLine & "Fields was saved to the " & OutFolder & "> folder.<br>"
  
  DoLog pLogLine, "UP"
  
  OutFolder = Empty 'Clear variables.
  SaveUpload = OutLine
End Function

'Writes one log line to the log file
Function DoLog(LogLine, LogPrefix)
  if LogFolder = "" then LogFolder = Server.MapPath(".")
  Const LogSeparator = ", "
  Dim OutStream, FileName
  FileName = LogPrefix & Right("0" & Year(Now), 2) & Right("0" & Month
(Now), 2) & Right("0" & Day(Now), 2) & ".LOG"

  Set OutStream = Server.CreateObject("Scripting.FileSystemObject").Op
enTextFile(LogFolder & "\" & FileName, 8, True)
  OutStream.WriteLine Now() & LogSeparator & LogLine
  OutStream = Empty
End Function

'Returns field or "-" if field is empty
Function LogF(ByVal F)
  If "" & F = "" Then LogF = "-" Else LogF = "" & F
End Function

'Returns field or "-" if field is empty
Function LogFn(ByVal F)
  If "" & F = "" Then LogFn = "-" Else LogFn = formatnumber(F,0)
End Function

Dim Kernel, TickCount, KernelTime, UserTime
Sub BeginTimer()
on error resume next
  Set Kernel = CreateObject("ScriptUtils.Kernel") 'Creates the Kernel 
object
  'Get start times
  TickCount = Kernel.TickCount
  KernelTime = Kernel.CurrentThread.KernelTime
  UserTime = Kernel.CurrentThread.UserTime
on error goto 0
End Sub

Sub EndTimer()
  'Write times
on error resume next
  Response.Write "<br>Script time : " & (Kernel.TickCount - TickCount)
 & " ms"
  Response.Write "<br>Kernel time : " & CLng((Kernel.CurrentThread.Ker
nelTime - KernelTime) * 86400000) & " ms"
  Response.Write "<br>User time : " & CLng((Kernel.CurrentThread.UserT
ime - UserTime) * 86400000) & " ms"
on error goto 0
  Kernel = Empty
End Sub
</SCRIPT>



文件fformat.inc
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>

function Foot()
  DIM HTML
    HTML = "<hr><Table Border=0 Width=100%><TR><TD>燬ampl
e upload/download via ASP from PSTRUH Sof
tware
.
"
    HTML = HTML & "</td><td Align=right><A HRef=http://ww
w.pstruh.cz/help/ScptUtl/library.htm>Activex Upload?A HRef=http://
www.pstruh.cz/help/usrmgr/library.htm>ActiveX UserManager?A HRef=h
ttp://www.pstruh.cz/help/RSConv/library.htm>DBF on-the-fly?A HRef=
http://www.pstruh.cz/help/tcpip/library.htm>ActiveX DNS+TraceRoute
?A HRef=http://www.pstruh.cz/help/urlrepl/library.htm>URL Replacer
?/Font>"
    HTML = HTML & "</td></tr></table></Body></HTML>"
    Foot = HTML 
end function

function Head(Title, Description)
  DIM HTML
    HTML = "<HTML><Head>"
  HTML = HTML & "<Title>" & Title & "</Title>"
  HTML = HTML & "<Meta Content=""" & Description & """ Name=""Descript
ion"">"
    HTML = HTML & Style()
    HTML = HTML & "</Head>"
    HTML = HTML & Body()
    Head = HTML 
end function

function Body()
  DIM HTML
  HTML = "<body ALINK=YELLOW bgcolor=White LeftMargin=0 TopMargin=0>" 
&vbCrLf
    HTML = HTML & ClHead() &vbCrLf
    HTML = HTML & Source()
    Body = HTML
  '<LeftMargin=0 TopMargin=0 Style="margin-right:0pt; margin-top:0pt;
margin-left:0pt;">
end function

function Style()
  Style = "<STYLE TYPE=""text/css""><--BODY{font-size:10pt;font-family
:Arial,Arial CE,Helvetica,sans-serif }--></STYLE>"
  '<LeftMargin=0 TopMargin=0 Style="margin-right:0pt; margin-top:0pt;
margin-left:0pt;">
end function

function ClHead()
  DIM HTML
  HTML = HTML & "<TABLE width=100% border=1 cellpadding=1 cellspacing=
0 BORDERCOLOR=WHITE><tr bgcolor=SILVER>"
  HTML = HTML & "<th><a href=fupload.asp>Multiple text files upload></th>"
  HTML = HTML & "<th><a href=fdbupl.asp>Upload to database</th>"
  HTML = HTML & "<th><a href=fdbdown.asp>Download from database</t
h>"
  HTML = HTML & "<th><a href=" & request.servervariables("script_name"
) & "?S=1>View source</th>"
  HTML = HTML & "</tr></table>"
  ClHead = HTML
end function

function Source()
  DIM HTML
  if request.querystring("S")<>"" then
    HTML = HTML & "<pre>" & server.htmlencode(CreateObject("Scripting.
FileSystemObject").OpenTextFile _
    (server.mappath(request.servervariables("script_name")), 1, False,
 False).readall) & "</pre>"
  end if
    Source = BasicEncode(HTML)
end function


Function BasicEncode(ByVal VBCode)
'  Dim Pom, PosStart, PosEnd
'  PosStart = InStr(VBCode, "'")
'  Do While PosStart > 0
'    PosEnd = InStr(PosStart + 1, VBCode, vbCrLf)
'    If PosEnd = 0 Then PosEnd = Len(VBCode)
'    Pom = Left(VBCode, PosStart - 1) & ""
'    Pom = Pom & Mid(VBCode, PosStart, PosEnd - PosStart - 0) & "</fon
t>"
'    Pom = Pom & Mid(VBCode, PosEnd)
'    VBCode = Pom
'    PosStart = InStr(PosEnd + 1, VBCode, "'")
'  Loop
  VBCode = FilterBeginEnd(VBCode, "'", vbCrLf, "green")
  VBCode = FilterBeginEnd(VBCode, "&quot;", "&quot;", "brown")
  VBCode = FilterWord(VBCode, "Set ", "blue")
  VBCode = FilterWord(VBCode, "If ", "blue")
  VBCode = FilterWord(VBCode, "For ", "blue")
  VBCode = FilterWord(VBCode, " Then", "blue")
  VBCode = FilterWord(VBCode, " In ", "blue")
  VBCode = FilterWord(VBCode, "Each ", "blue")
  VBCode = FilterWord(VBCode, "Function ", "blue")
  VBCode = FilterWord(VBCode, "End Function", "blue")
  VBCode = FilterWord(VBCode, "MsgBox ", "blue")
  VBCode = FilterWord(VBCode, "OutPut ", "blue")
  VBCode = FilterWord(VBCode, "Empty", "blue")
  VBCode = FilterWord(VBCode, "Debug.Print ", "darkblue")
  VBCode = FilterWord(VBCode, "Print ", "blue")
  VBCode = FilterWord(VBCode, " And ", "blue")
  VBCode = FilterWord(VBCode, " Or ", "blue")
  VBCode = FilterWord(VBCode, "Next" & vbcrlf, "blue")
  VBCode = FilterWord(VBCode, "Next " , "blue")

  VBCode = FilterWord(VBCode, "Response.Write", "darkblue")
  VBCode = FilterWord(VBCode, "Response.BinaryWrite" , "darkblue")
  VBCode = FilterWord(VBCode, "Response.ContentType" , "darkblue")
  VBCode = FilterWord(VBCode, "Response.AddHeader" , "darkblue")
    
  VBCode = FilterWord(VBCode, "Server.CreateObject" , "darkblue")
  VBCode = FilterWord(VBCode, "CreateObject" , "darkblue")
   
'  VBCode = FilterWord(VBCode," = ","red")
  BasicEncode = VBCode
End Function

Function FilterBeginEnd(ByVal VBCode, ByVal sBegin, ByVal sEnd, ByVal 
Color)
  Dim Pom, PosStart, PosEnd, FontColor
  FontColor = "<font color=" & Color & ">"
  PosStart = InStr(ucase(VBCode), ucase(sBegin))
  Do While PosStart > 0
    PosEnd = InStr(PosStart + Len(sBegin), ucase(VBCode), ucase(sEnd))

    If PosEnd = 0 Then PosEnd = Len(VBCode)
    Pom = Left(VBCode, PosStart - 1) & FontColor
    Pom = Pom & Mid(VBCode, PosStart, PosEnd - PosStart + Len(sEnd)) &
 "
"
    Pom = Pom & Mid(VBCode, PosEnd + Len(sEnd))
    VBCode = Pom
    PosStart = InStr(PosEnd + Len(FontColor) + Len("
") + Len(sE
nd), ucase(VBCode), ucase(sBegin))
  Loop
  FilterBeginEnd = VBCode
End Function

Function FilterWord(ByVal VBCode, ByVal Word, ByVal Color)
  Dim Pom, PosStart, PosEnd, FontWord
  FontWord = "<font color=" & Color & ">" & Word & ""
  PosStart = InStr(ucase(VBCode), ucase(Word))
  Do While PosStart > 0
    Pom = Left(VBCode, PosStart - 1) & FontWord
    Pom = Pom & Mid(VBCode, PosStart + Len(Word))
    VBCode = Pom
    PosStart = InStr(PosStart + Len(FontWord), ucase(VBCode), ucase(Wo
rd))
  Loop
  FilterWord = VBCode
End Function
</SCRIPT>




--
※ 来源:.月光软件站 http://www.moon-soft.com.[FROM: 202.130.230.7]

[关闭][返回]