<div class="codebody" id="code21941"> <% Class MultiUpload REM PUBLIC-VARIANT Public Form,IsFinished Private bVbCrlf,bSeparate,fPassed,formData,fileType,fileSize,folderPath,_ fRename,fIMGOnly,itemCount,chunkSize,bTime,sErrors,sAuthor,sversion Private itemStart(),itemLength(),dataStart(),dataLength(),itemName(),itemData(),extenArr(),httpArr() REM CLASS-INITIALIZE Private Sub Class_Initialize Call Initvariant Server.ScriptTimeOut = 1800 Set Form = Server.CreateObject("Scripting.Dictionary") sAuthor = "51JS.COM-ZMM" sversion = "MultiUpload Class 3.0" End Sub REM CLASS-ATTRIBUTES Public Property Let AllowType(byVal sType) Dim regEx Set regEx = New RegExp regEx.Pattern = "^(\w+|)\w+$" regEx.Global = False regEx.IgnoreCase = True If regEx.Test(sType) Then fileType = "|" & Ucase(sType) & "|" Set regEx = nothing End Property Public Property Let MaxSize(byVal sSize) If IsNumeric(sSize) Then fileSize = CDbl(FormatNumber(CCur(sSize),2)) End Property Public Property Let SaveFolder(byVal sFolder) folderPath = sFolder End Property Public Property Let CommonPassed(byVal bCheck) fPassed = bCheck End Property Public Property Let FileRenamed(byVal bRename) fRename = bRename End Property Public Property Let FileIsAllImg(byVal bOnly) fIMGOnly = bOnly End Property Public Property Get SaveFolder SaveFolder = folderPath End Property Public Property Get FileRenamed FileRenamed = fRename End Property Public Property Get FileIsAllImg FileIsAllImg = fIMGOnly End Property Public Property Get ErrMessage ErrMessage = sErrors End Property Public Property Get ClsAuthor ClsAuthor = sAuthor End Property Public Property Get Clsversion Clsversion = sversion End Property REM CLASS-METHODS Private Function Initvariant IsFinished = False bVbCrlf = StrToByte(vbCrlf & vbCrlf) bSeparate = StrToByte(String(29,"-")) fPassed = False fileType = "" fileSize = "" fRename = True fIMGOnly = True itemCount = 0 chunkSize = 1024 128 bTime = Now sErrors = "" End Function Public Function GetUploadData Dim curRead : curRead = 0 Dim dataLen : dataLen = Request.TotalBytes Dim appName : appName = "PROGRESS" & IPToNum(GetClientIPAddr) Dim streamTmp Set streamTmp = Server.CreateObject("ADODB.Stream") streamTmp.Type = 1 streamTmp.Open do while curRead < dataLen Dim partLen : partLen = chunkSize If partLen + curRead > dataLen Then partLen = dataLen - curRead streamTmp.Write Request.BinaryRead(partLen) curRead = curRead + partLen LetProgress appName,Array(curRead,dataLen,DateDiff("s",Now),folderPath) Loop streamTmp.Position = 0 formData = streamTmp.Read(dataLen) streamTmp.Close Set streamTmp = nothing Call ItemPosition End Function Private Function LetProgress(byVal sName,byVal vArr) Application.Value(sName) = Join(vArr,"|") End Function Private Function DelProgress Application.Contents.Remove("PROGRESS" & IPToNum(GetClientIPAddr)) End Function Private Function ItemPosition Dim iStart,iLength : iStart = 1 Do Until InStrB(iStart,bSeparate) = 0 iStart = InStrB(iStart,bSeparate) + LenB(bSeparate) + 14 iLength = InStrB(iStart,bSeparate) - iStart - 2 If Abs(iStart + 2 - LenB(formData)) > 2 Then ReDim Preserve itemStart(itemCount) ReDim Preserve itemLength(itemCount) itemStart(itemCount) = iStart itemLength(itemCount) = iLength itemCount = itemCount + 1 End If Loop Call FillItemValue End Function Private Function FillItemValue Dim dataPart,bInfor Dim iStart : iStart = 1 Dim iCount : iCount = 0 Dim iCheck : iCheck = StrToByte("filename") For i = 0 To itemCount - 1 ReDim Preserve itemName(iCount) ReDim Preserve itemData(iCount) ReDim Preserve extenArr(iCount) ReDim Preserve httpArr(iCount) ReDim Preserve dataStart(iCount) ReDim Preserve dataLength(iCount) dataPart = MidB(formData,itemStart(i),itemLength(i)) iStart = InStrB(1,dataPart,ChrB(34)) + 1 iLength = InStrB(iStart,ChrB(34)) - iStart itemName(iCount) = GetItemName(MidB(dataPart,iStart,iLength)) iStart = InStrB(1,bVBCrlf) + 4 iLength = LenB(dataPart) - iStart + 1 If InStrB(1,iCheck) > 0 Then bInfor = MidB(dataPart,1,iStart - 5) extenArr(iCount) = FileExtenName(bInfor) httpArr(iCount) = GetHttpContent(bInfor) If Isnothing(extenArr(iCount)) Then itemData(iCount) = "" dataStart(iCount) = "" dataLength(iCount) = "" Else If Mid(folderPath,Len(folderPath) - 1) = "/" Then If fRename Then itemData(iCount) = folderPath & GetRandomName(6) & extenArr(iCount) Else itemData(iCount) = folderPath & GetClientName(bInfor) & extenArr(iCount) End If Else If fRename Then itemData(iCount) = folderPath & "/" & GetRandomName(6) & extenArr(iCount) Else itemData(iCount) = folderPath & "/" & GetClientName(bInfor) & extenArr(iCount) End If End If dataStart(iCount) = itemStart(i) + iStart - 2 dataLength(iCount) = iLength End If Else extenArr(iCount) = "" httpArr(iCount) = "" itemData(iCount) = BytetoStr(MidB(dataPart,iLength)) dataStart(iCount) = "" dataLength(iCount) = "" End If iCount = iCount + 1 Next Call ItemToColl End Function Private Function GetItemName(byVal bName) GetItemName = BytetoStr(bName) End Function Private Function ItemToColl For i = 0 To itemCount - 1 If Not Form.Exists(itemName(i)) Then Form.Add itemName(i),itemData(i) End If Next End Function Private Function FileExtenName(byVal bInfor) Dim pContent,regEx pContent = GetClientPath(bInfor) If Isnothing(pContent) Then FileExtenName = "" Else Set regEx = New RegExp regEx.Pattern = "^.+(.[^.]+)$" regEx.Global = False regEx.IgnoreCase = True FileExtenName = regEx.Replace(pContent,"$1") Set regEx = nothing End If End Function Private Function GetHttpContent(byVal bInfor) Dim sInfor,regEx sInfor = BytetoStr(bInfor) Set regEx = New RegExp regEx.Pattern = "^[\S\s]+Content-Type:([\S\s]+)$" regEx.Global = False regEx.IgnoreCase = True GetHttpContent = Trim(regEx.Replace(sInfor,"$1")) Set regEx = nothing End Function Private Function GetRandomName(byVal sLen) Dim regEx,stemp,arrFields,n : n = 0 Set regEx = New RegExp regEx.Pattern = "[^\d]+" regEx.Global = True regEx.IgnoreCase = True stemp = regEx.Replace(Now,"") & "-" Set regEx = nothing arrFields = Array("0","1","2","3","4","5","6","7","8","9", "a","b","c","d","e","f","g","h","i","j", "k","l","m","n","o","p","q","r","s","t", "u","v","w","x","y","z","A","B","C","D", "E","F","G","H","I","J","K","L","M","N", "O","P","Q","R","S","T","U","V","W","X", "Y","Z") Randomize do while n < sLen stemp = stemp & CStr(arrFields(61 Rnd)) n = n + 1 Loop GetRandomName = stemp End Function Private Function GetClientName(byVal bInfor) Dim pContent,regEx pContent = GetClientPath(bInfor) If Isnothing(pContent) Then GetClientName = "" Else Set regEx = New RegExp regEx.Pattern = "^.\([^.])[^\]+$" regEx.Global = False regEx.IgnoreCase = True GetClientName = regEx.Replace(pContent,"$1") Set regEx = nothing End If End Function Private Function GetClientPath(byVal bInfor) Dim sInfor,pStart,pLength,pContent sInfor = BytetoStr(bInfor) pStart = InStr(1,sInfor,"filename=" & Chr(34)) + 10 pLength = InStr(pStart,Chr(34)) - pStart pContent = Mid(sInfor,pLength) GetClientPath = pContent End Function Public Function SaveUploadFile Dim isValidate Dim filePath,oStreamGet,oStreamput isValidate = fPassed And CheckFile If isValidate Then For i = 0 To itemCount - 1 If Not Isnothing(dataStart(i)) And Not Isnothing(dataLength(i)) Then If dataLength(i) = 0 Then itemData(i) = "" Else filePath = Server.MapPath(itemData(i)) If CreateFolder("|",ParentFolder(filePath)) Then Set oStreamGet = Server.CreateObject("ADODB.Stream") oStreamGet.Type = 1 oStreamGet.Mode = 3 oStreamGet.Open oStreamGet.Write formData oStreamGet.Position = dataStart(i) Set oStreamput = Server.CreateObject("ADODB.Stream") oStreamput.Type = 1 oStreamput.Mode = 3 oStreamput.Open oStreamput.Write oStreamGet.Read(dataLength(i)) oStreamput.SavetoFile filePath,2 oStreamGet.Close Set oStreamGet = nothing oStreamput.Close Set oStreamput = nothing End If End If End If Next IsFinished = True Else IsFinished = False End If End Function Private Function CheckFile Dim oBoolean : oBoolean = True CheckFile = oBoolean And CheckType And CheckSize End Function Private Function CheckType Dim oBoolean : oBoolean = True If fileType = "" Then oBoolean = oBoolean And True Else For i = 0 To itemCount - 1 If Not Isnothing(extenArr(i)) Then If InStr(1,"|" & Ucase(Mid(extenArr(i),2)) & "|") > 0 Then If fIMGOnly Then Dim sAllow : sAllow = "|GIF|PJPEG|X-PNG|BMP|" Dim aCheck : aCheck = Split(UCase(httpArr(i)),"/") Dim iCheck : iCheck = "|" & aCheck(Ubound(aCheck)) & "|" If InStr(1,sAllow,iCheck,1) > 0 Then oBoolean = oBoolean And True Else sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件格式错误!\n" & _ "支持的格式为:" & Replace(Mid(fileType,2,Len(fileType) - 1),"|"," ") & "\n\n" oBoolean = oBoolean And False End If Else oBoolean = oBoolean And True End If Else sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件格式错误!\n" & _ "支持的格式为:" & Replace(Mid(fileType," ") & "\n\n" oBoolean = oBoolean And False End If End If Next End If CheckType = oBoolean End Function Private Function CheckSize Dim oBoolean : oBoolean = True If fileSize = "" Then oBoolean = oBoolean And True Else For i = 0 To itemCount - 1 If Not Isnothing(dataLength(i)) Then Dim tmpSize : tmpSize = CDbl(FormatNumber(CCur(dataLength(i)) / 1024,2)) If tmpSize <= fileSize Then oBoolean = oBoolean And True Else sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件大小 (" & tmpSize & " KB) 超出范围!\n" & _ "支持大小范围:<= " & fileSize & " KB\n\n" oBoolean = oBoolean And False End If End If Next End If CheckSize = oBoolean End Function Private Function CreateFolder(byVal sLine,byVal sPath) Dim oFso Set oFso = Server.CreateObject("Scripting.FileSystemObject") If Not oFso.FolderExists(sPath) Then Dim regEx Set regEx = New RegExp regEx.Pattern = "^(.)\([^\])$" regEx.Global = False regEx.IgnoreCase = True sLine = sLine & regEx.Replace(sPath,"$2") & "|" sPath = regEx.Replace(sPath,"$1") If CreateFolder(sLine,sPath) Then CreateFolder = True Set regEx = nothing Else If sLine = "|" Then CreateFolder = True Else Dim stemp : stemp = Mid(sLine,Len(sLine) - 2) If InStrRev(stemp,"|") = 0 Then sLine = "|" sPath = sPath & "\" & stemp Else Dim Folder : Folder = Mid(stemp,InStrRev(stemp,"|") + 1) sLine = "|" & Mid(stemp,"|") - 1) & "|" sPath = sPath & "\" & Folder End If oFso.CreateFolder sPath If CreateFolder(sLine,sPath) Then CreateFolder = True End if End If Set oFso = nothing End Function Private Function ParentFolder(byVal sPath) Dim regEx Set regEx = New RegExp regEx.Pattern = "^(.)\[^\]$" regEx.Global = True regEx.IgnoreCase = True ParentFolder = regEx.Replace(sPath,"$1") Set regEx = nothing End Function Private Function Isnothing(byVal sVar) Isnothing = CBool(sVar = Empty) End Function Private Function StrPadLeft(byVal sText,byVal sLen,byVal sChar) Dim stemp : stemp = sText do while Len(stemp) < sLen : stemp = sChar & stemp : Loop StrPadLeft = stemp End Function Private Function StrToByte(byVal sText) For i = 1 To Len(sText) StrToByte = StrToByte & ChrB(Asc(Mid(sText,i,1))) Next End Function Private Function BytetoStr(byVal sByte) Dim oStream Set oStream = Server.CreateObject("ADODB.Stream") oStream.Type = 2 oStream.Mode = 3 oStream.Open oStream.WriteText sByte oStream.Position = 0 oStream.CharSet = "gb2312" oStream.Position = 2 BytetoStr = oStream.ReadText oStream.Close Set oStream = nothing End Function Private Function GetClientIPAddr If Isnothing(GetServerVar("HTTP_X_FORWARDED_FOR")) Then GetClientIPAddr = GetServerVar("REMOTE_ADDR") Else GetClientIPAddr = GetServerVar("HTTP_X_FORWARDED_FOR") End If End Function Private Function GetServerVar(byVal sText) GetServerVar = Request.ServerVariables(sText) End Function Private Function IPToNum(byVal sIp) Dim sIp_1,sIp_2,sIp_3,sIp_4 If IsNumeric(Left(sIp,2)) Then sIp_1 = Left(sIp,InStr(sIp,".") - 1) sIp = Mid(sIp,".") + 1) sIp_2 = Left(sIp,".") + 1) sIp_3 = Left(sIp,".") - 1) sIp_4 = Mid(sIp,".") + 1) End If IPToNum = CInt(sIp_1) 256 256 256 + CInt(sIp_2) 256 256 + CInt(sIp_3) 256 + CInt(sIp_4) - 1 End Function REM CLASS-TERMINATE Private Sub Class_Terminate Call DelProgress Form.RemoveAll Set Form = nothing End Sub End Class %>