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
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 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", bTime, 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, formData, bSeparate) = 0 iStart = InStrB(iStart, formData, bSeparate) + LenB(bSeparate) + 14 iLength = InStrB(iStart, formData, 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, dataPart, ChrB(34)) - iStart itemName(iCount) = GetItemName(MidB(dataPart, iStart, iLength)) iStart = InStrB(1, dataPart, bVBCrlf) + 4 iLength = LenB(dataPart) - iStart + 1 If InStrB(1, dataPart, 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, iStart, 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 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, sInfor, Chr(34)) - pStart pContent = Mid(sInfor, pStart, 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, fileType, "|" & 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, 2, Len(fileType) - 1), "|", " ") & "\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 oBoolean = oBoolean And True Else sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件大小 (" & tmpSize & " KB) 超出范围!\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, 2, 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, InStrRev(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) 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
Der Inhalt dieses Artikels wird freiwillig von Internetnutzern beigesteuert und das Urheberrecht liegt beim ursprünglichen Autor. Diese Website übernimmt keine entsprechende rechtliche Verantwortung. Wenn Sie Inhalte finden, bei denen der Verdacht eines Plagiats oder einer Rechtsverletzung besteht, wenden Sie sich bitte an admin@php.cn