上传组件(2)-文章来自httpwww.aspcn.com asp中华网.txt

C&C++论坛精华

作者：cooljack
日期：00-5-29 上午 10:05:27
上传组件（2）  

 
此文件为aspcnUP组件的源程序 
'******************************************************************************************************
'** AspcnUP 0.5 beta 源程序 *
'** 源程序来自 http://www.aspcn.com *
'** 本组件为AspcnUP 由[清水万维工作室] 飞刀 开发，目前版本为 0.5beta *
'** 本程序版权由本人保留，不过大家可以将本源程序修改，升级（只需保留组件名和工程名） *
'** 如果您将本程序修改后发表，敬请您同时公开源代码，为更多的人服务，在此飞刀表示谢谢 *
'** 但是[禁止]将本程序修改后用作商业产品出售，本人开发的初衷也是为了让更多的人了解组件。 *
'** 写出更多更好的属于中国人的组件 *
'** （将别人的程序当自己开发，甚至出售，这种行为也是可恨的。本人遇到过这种情况，所以很反感） *
'** 本程序我已经做了详细的注释，还有不明白的地方，或者建议 *
'** 请发信至 [e-mail] ,或者在本站点的论坛中指出 *
'** 同时，本程序处理中文方面使用了woozhj兄的处理方式，在此表示感谢 *
'******************************************************************************************************
Option Explicit

Private MyScriptingContext As ASPTypeLibrary.ScriptingContext
Private MyResponse As ASPTypeLibrary.Response
Private MyRequest As ASPTypeLibrary.Request
Private MyServer As ASPTypeLibrary.Server

Private lngFieldCount As Long
Private allFieldValuex() As Variant
Private allFieldNamex() As String
Private allFieldSizex() As Long
Private lngOverWritex As Integer
Private lngMaxSizex As Long
Private varPathx As String


Private Const FILE_EXISTS As Long = vbObjectError + 101
Private Const FILE_EMPTY As Long = vbObjectError + 102
Private Const FILENAME_EMPTY As Long = vbObjectError + 103
Private Const FILESIZE_GO_BEYOND As Long = vbObjectError + 104
Private Const FILE_TOTAL_COUNT_BEYOND As Long = vbObjectError + 105
Private Const FIELDNAME_EMPTY As Long = vbObjectError + 106
Private Const NO_FILE_UPLOAD As Long = vbObjectError + 107
Private Const PATH_NAME_ERR As Long = vbObjectError + 108
'以下两个子程序是必须的，为什么要这样，请看看我以前的文章
'参考文章有http://www.aspcn.com/showarticle.asp?id=29
'http://www.aspcn.com/showarticle.asp?id=26
Public Sub OnStartPage(PassedScriptingcontext As ScriptingContext)
Set MyScriptingContext = PassedScriptingcontext
Set MyRequest = MyScriptingContext.Request
Set MyServer = MyScriptingContext.Server
End Sub
Public Sub OnEndPage()
Set MyScriptingContext = Nothing
Set MyRequest = Nothing
Set MyServer = Nothing
End Sub
'upload 子程序是主程序，上载均在此完成,如果在上载过程序出错upload返回错误信息，如果没有返回成功信息
Public Function Upload(Optional ByVal lngMaxSize As Long, Optional ByVal ServerPath As String, Optional ByVal lngOverWrite As Integer) As String
On Error GoTo error_occurs '出现错误后转到error_occurs
Dim i As Long
Dim Pos As Long
Dim lngTotalSize As Long
Dim lngFormCount As Long
Dim varFormType As String
Dim varHeaderValue As Variant
Dim varBoundary As Variant
Dim lngFormHeadStart As Long
Dim lngFormHeadEnd As Long
Dim lngOffSet As Long
Dim lngFieldNameStart As Long
Dim lngFieldNameEnd As Long
Dim varFieldName As String
Dim lngFileNameStart As Long
Dim lngFileNameEnd As Long
Dim varFileName As String
Dim lngFileValueStart As Long
Dim lngFileValueEnd As Long
Dim lngFileValueLength As Long
Dim varFileValue() As Byte
Dim lngBoundaryEnd As Long
Dim Just As Boolean
Dim tmpFileName As Variant
Dim varFieldValue As String
Dim lngFieldValueStart As Long
Dim lngFieldValueEnd As Long
Dim lngFieldValueLength As Long
Dim tmpHeaderValue As Variant
Dim allFieldValue() As Variant
Dim allFieldName() As String
Dim allFieldSize() As Long
'获取文件的大小限制
If lngMaxSizex <> 0 Then
lngMaxSize = lngMaxSizex
Else
If lngMaxSize = 0 Then lngMaxSize = 100000
End If
'判断目标文件存在时，是否覆盖
If lngOverWritex <> 0 Then
lngOverWrite = lngOverWritex
Else
If lngOverWrite = 0 Then lngOverWrite = 1
End If
'处理上载的目录
If Len(varPathx) > 2 Then
ServerPath = varPathx
Else
If Len(ServerPath) < 2 Then ServerPath = "c:\"
End If
If InStr(ServerPath, ":") = 0 Then
Err.Raise PATH_NAME_ERR '如果目录不是绝对路径就出错
End If
lngTotalSize = MyRequest.TotalBytes '获得上载数量的大小
varHeaderValue = MyRequest.BinaryRead(lngTotalSize) '读取上载值
'加1的原因是因为vbCrLf是chr(10)+chr(13) 组成的，所以占了两个字节
lngBoundaryEnd = InStrB(1, varHeaderValue, StoB(vbCrLf)) + 1
varBoundary = LeftB(varHeaderValue, lngBoundaryEnd) '获得分界线的值
'取得表单的个数
tmpHeaderValue = StrConv(varHeaderValue, vbUnicode)
lngFormCount = Len(tmpHeaderValue) - Len(Replace(tmpHeaderValue, "; name=", Mid("; name=", 2)))
lngFieldCount = lngFormCount
'获得表单个数时，本人曾想直接用二进制，但是获得的个数有时对有时错，一气之下用了最原始的文本
ReDim Preserve allFieldName(lngFormCount)
ReDim Preserve allFieldValue(lngFormCount)
ReDim Preserve allFieldSize(lngFormCount)
'以上三个函数分别记录表单项的名字，数据，大小（字节）
If lngFormCount > 255 Then
Err.Raise FILE_TOTAL_COUNT_BEYOND
End If
If lngFormCount = 0 Then
Err.Raise NO_FILE_UPLOAD
End If
'以下处理上载上来的值
lngOffSet = lngBoundaryEnd
For i = 0 To lngFormCount - 1
'取得表单项的名字
lngFieldNameStart = InStrB(lngOffSet, varHeaderValue, StoB("; name=") & ChrB(34))
'取得表单名的末位置
lngFieldNameEnd = InStrB(lngFieldNameStart + LenB(StoB("; name=") & ChrB(34)), varHeaderValue, ChrB(34)) + LenB(ChrB(34))
varFieldName = BtoS(MidB(varHeaderValue, lngFieldNameStart, lngFieldNameEnd - lngFieldNameStart))
varFieldName = Replace(varFieldName, "; name=", vbNullString)
varFieldName = Replace(varFieldName, Chr(34), vbNullString)
'表单名搞定，以下来搞定文件名
'生成一个临时变量，用以查询此表单项的内容是文件还是普通的文本
tmpFileName = MidB(varHeaderValue, lngFieldNameEnd, 15)
If InStrB(tmpFileName, StoB("; filename=")) <> 0 Then
lngFileNameStart = InStrB(lngFieldNameEnd, varHeaderValue, StoB("filename=" & Chr(34))) '取得文件名的首位置
lngFileNameEnd = InStrB(lngFileNameStart + LenB(StoB("filename=" & Chr(34))), varHeaderValue, ChrB(34)) '取得文件名的末位置
varFileName = BtoS(MidB(varHeaderValue, lngFileNameStart, lngFileNameEnd - lngFileNameStart))
If lngFileNameEnd - lngFileNameStart < 2 Then
Err.Raise FILENAME_EMPTY
End If
varFileName = Replace(varFileName, "filename=", vbNullString)
varFileName = Replace(varFileName, Chr(34), vbNullString)
'含路径的文件名已经搞定，现在要分离出真正的文件名
For Pos = Len(varFileName) To 1 Step -1
If Mid(varFileName, Pos, 1) = "\" Or Mid(varFileName, Pos, 1) = ":" Then '发现\或:，表示真正的文件名结束
varFileName = Mid(varFileName, Pos + 1, Len(varFileName) - Pos)
Exit For
End If
Next
'文件名搞定
'下面来搞定文件（表单对象）内容
'加4是因为要除去两个vbCrlf的大小
lngFileValueStart = InStrB(lngFileNameEnd, varHeaderValue, StoB(vbCrLf & vbCrLf)) + 4
lngFileValueEnd = InStrB(lngFileValueStart, varHeaderValue, LeftB(varBoundary, lngBoundaryEnd - 2)) - 2
lngFileValueLength = lngFileValueEnd - lngFileValueStart
If lngFileValueLength < 2 Then
Err.Raise FILE_EMPTY
End If
If lngFileValueLength > lngMaxSize Then
Err.Raise FILESIZE_GO_BEYOND
End If
varFileValue = MidB(varHeaderValue, lngFileValueStart, lngFileValueLength)
allFieldName(i) = CStr(varFieldName)
allFieldSize(i) = CLng(lngFileValueLength)
allFieldValue(i) = CVar(varFileValue)
'内容已经分离出来，下一步就是保存文件了
Just = SaveFile(ServerPath, CStr(varFileName), varFileValue, lngOverWrite)
If Just = False Then
Err.Raise FILE_EXISTS
End If
lngOffSet = lngFileValueEnd + lngBoundaryEnd - 2
Else
'表单项只是普通的文本，就进行如下处理
lngFieldValueStart = lngFieldNameEnd + 4
lngFieldValueEnd = InStrB(lngFieldValueStart, varHeaderValue, LeftB(varBoundary, lngBoundaryEnd - 2)) - 2
lngFieldValueLength = lngFieldValueEnd - lngFieldValueStart
varFieldValue = BtoS(MidB(varHeaderValue, lngFieldValueStart, lngFieldValueLength))
varFieldValue = Replace(varFieldValue, vbCrLf, vbNullString)
allFieldName(i) = CStr(varFieldName)
allFieldSize(i) = CLng(lngFieldValueLength)
allFieldValue(i) = CVar(varFieldValue)
lngOffSet = lngFieldValueEnd + lngBoundaryEnd - 2
End If
Next
allFieldNamex = allFieldName()
allFieldSizex = allFieldSize()
allFieldValuex = allFieldValue()
error_occurs:
If Err.Number <> 0 Then
Select Case Err.Number
Case FILE_EXISTS
Upload = "对不起，目标文件在上载的目录中已经存在，如果需要覆盖，请将[overwrite]属性定义为[2]。(Sorry,the file which you want to upload has already exists.if you want to overwrite it ,please define the property of [overwrite] to [2])"
Exit Function
Case FILENAME_EMPTY
Upload = "对不起，[" & varFieldName & "]表单项中的文件名为空。(Sorry,item [" & varFieldName & "] is empty.)"
Exit Function
Case FILESIZE_GO_BEYOND
Upload = "对不起，文件名为[" & varFileName & "] 的文件大小超出了范围。(Sorry ,the size of file [" & varFileName & "] is beyond.)"
Exit Function
Case FILENAME_EMPTY
Upload = "对不起，第[" & i & "]个表单项名为空。(Sorry ,No." & i & " item is empty.)"
Exit Function
Case FILE_EMPTY
Upload = "对不起，文件名为[" & varFileName & "] 的文件为空。(Sorry,file [" & varFileName & "] is empty.)"
Exit Function
Case FILE_TOTAL_COUNT_BEYOND
Upload = "对不起，文件总数不得超过255(Sorry ,the count of the files must not be over 255.)"
Exit Function
Case NO_FILE_UPLOAD
Upload = "对不起，您没有选择文件上传.(Sorry,you have not selected a file to upload.)"
Exit Function
Case PATH_NAME_ERR
Upload = "对不起，路径必须为绝对路径.(Sorry,the path must be a absolute path)"
Exit Function
Case Else
Upload = Err.Description

Exit Function
End Select
Else
Upload = "OK"
End If
End Function
'count属性用于在ASP中获取上传表单的个数
Public Property Get count() As Variant
count = lngFieldCount
End Property
'设定上传文件的大小限制
Public Property Let MaxSize(ByVal lngNewMaxSize As Long)
If IsNumeric(lngNewMaxSize) Then
lngMaxSizex = lngNewMaxSize
Else
lngMaxSizex = 0
End If
End Property
'设定文件上传的路径
Public Property Let Path(ByVal varNewPath As String)
If Mid(varNewPath, 2, 1) = ":" Then
varPathx = varNewPath
Else
varPathx = ""
End If
End Property
'设定是否覆盖原来的文件
Public Property Let OverWrite(ByVal lngNewOverWrite As Integer)
If IsNumeric(lngNewOverWrite) And lngNewOverWrite > 0 And lngNewOverWrite < 3 Then
lngOverWritex = lngNewOverWrite
Else
lngOverWritex = 0
End If
End Property
'此方法用来取得指定表单项的数据大小
Public Function Size(varFormName As String) As Long
Dim i As Long
Size = 0
For i = 0 To lngFieldCount - 1
If allFieldNamex(i) = varFormName Then
Size = allFieldSizex(i)
Exit Function
End If
Next
End Function
'此方法用来取得指定表单项的数据
Public Function Form(varFormName As String) As Variant
Dim i As Long
Form = ""
For i = 0 To lngFieldCount - 1
If allFieldNamex(i) = varFormName Then
Form = allFieldValuex(i)
Exit Function
End If
Next
End Function