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

 
此文件為aspcnUP組件的源程序 
'******************************************************************************************************
'** AspcnUP 0.5 beta 源程序 *
'** 源程序來自 http://www.aspcn.com *
'** 本組件為AspcnUP 由[清水萬維工作室] 飛刀 開發，目前版本為 0.5beta *
'** 本程序版權由本人保留，不過大家可以將本源程序修改，升級（只需保留組件名和工程名） *
'** 如果您將本程序修改后發表，敬請您同時公開源代碼，為更多的人服務，在此飛刀表示謝謝 *
'** 但是[禁止]將本程序修改后用作商業產品出售，本人開發的初衷也是為了讓更多的人了解組件。 *
'** 寫出更多更好的屬于中國人的組件 *
'** （將別人的程序當自己開發，甚至出售，這種行為也是可恨的。本人遇到過這種情況，所以很反感） *
'** 本程序我已經做了詳細的注釋，還有不明白的地方，或者建議 *
'** 請發信至 feidao@cmmail.com ,或者在本站點的論壇中指出 *
'** 同時，本程序處理中文方面使用了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