荔园在线
荔园之美,在春之萌芽,在夏之绽放,在秋之收获,在冬之沉淀
[回到开始]
[上一篇][下一篇]
发信人: gary (★有所属), 信区: Homepage
标 题: 不用组件上载文件代码段(一)[转载]
发信站: BBS 荔园晨风站 (Sat Oct 14 08:24:36 2000), 转信
下面将介绍一系列可以不用组件,而使用纯粹的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 data by
fi)
' 2. Upload binary/text files of any size to server-side database
(RS("BinFielde
'Limit of upload size
Dim UploadSizeLimit
'********************************** GetUpload
**********************************
'This function reads all form fields from binary input and returns it as a
dict.
'The dictionary object containing form fields. Each form field is represented
b:
'.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
mu"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type
header
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header
mu"
'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 boundary
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get
Contenr
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(Length,0) & ""
exit function
end if
end if
If Length > 0 And Boundary <> "" Then 'Are there required informations
ab?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from client
'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
fiely
'Binary is safearray of all raw binary data from input.
Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary,
Boundar)
Set Fields = CreateObject("Scripting.Dictionary")
Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not
isLastBoundary)
'Header and file/source field data
Dim HeaderContent, FieldContent
'Header fields
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Helping variables
Dim Field, TwoCharsAfterEndBoundary
'Get end of header
PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binary,
String)
'Separates field header
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2,
PosE)
'Separates field content
FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary -
(P)
'Separates header fields from header
GetHeadFields BinaryToString(HeaderContent), Content_Disposition,
FormFielde
'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, PosCloseBoundary +
L)
'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then 'This is not ending boundary - go to next form
f.
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary,
)
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)
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(FileName) -
)
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>
--
I Believe I Can ...
_____________________________________________________
欢迎光临我的主页 Netdreams!
※ 来源:·BBS 荔园晨风站 bbs.szu.edu.cn·[FROM: 192.168.28.86]
[回到开始]
[上一篇][下一篇]
荔园在线首页 友情链接:深圳大学 深大招生 荔园晨风BBS S-Term软件 网络书店