ASP上传类

<%
    Class Upload
        Public  Form, IsFinished
        Private bVBCrlf, bSeparate, formData, fileType, fileSize, folderPath, itemCount, sErrors, sAuthor, sVersion
        Private itemStart(), itemLength(), dataStart(), dataLength(), itemName(), itemData(), extenArr()

        Private Sub Class_Initialize  
            formData = Request.BinaryRead(Request.TotalBytes)
            Set Form = Server.CreateObject("scrīpting.Dictionary")
            sAuthor = "51JS.COM-ZMM"
            sVersion = "Upload Class 2.0"
            Server.scrīptTimeOut = 900
        End Sub
       
        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 Property Let AllowType(byVal sType)
            fileType = sType
        End Property

        Public Property Let MaxSize(byVal sSize)
            If Not IsNumeric(sSize) Then
               fileSize = ""
            Else
               fileSize = CDbl(FormatNumber(CCur(sSize), 2))
            End If
        End Property

        Public Property Let SaveFolder(byVal sFolder)
            folderPath = sFolder
        End Property

        Public Function Start
            IsFinished = False
            bVBCrlf = StrToByte(vbCrlf & vbCrlf)
            bSeparate = StrToByte("-----------------------------")
            itemCount = 0
            sErrors = ""
            Call ItemPosition
        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 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) = FormItemName(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)
                   If Mid(folderPath, Len(folderPath) - 1) = "/" Then
                      itemData(iCount) = folderPath & GetRndName(6) & extenArr(iCount)
                   Else
                      itemData(iCount) = folderPath & "/" & GetRndName(6) & extenArr(iCount) 
                   End If
                   dataStart(iCount) = itemStart(i) + iStart - 2
                   dataLength(iCount) = iLength
                Else
                   extenArr(iCount) = ""
                   itemData(iCount) = ByteToStr(MidB(dataPart, iStart, iLength))
                   dataStart(iCount) = ""
                   dataLength(iCount) = ""
                End If
                iCount = iCount + 1
            Next
            Call SaveUpload
        End Function

        Private Function FormItemName(byVal bName)
            FormItemName = ByteToStr(bName)
        End Function

        Private Function FileExtenName(byVal bInfor)
            Dim pStart, pLength, pContent, regEx
            pStart = InStr(1, ByteToStr(bInfor), "filename=" & Chr(34)) + 10
            pLength = InStr(pStart, ByteToStr(bInfor), Chr(34)) - pStart
            pContent = Mid(ByteToStr(bInfor), pStart, pLength)
            If 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 GetRndName(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
            GetRndName = sTemp
        End Function

        Private Function SaveUpload
            Dim isValidate
            Dim filePath, oStreamGet, oStreamPut
            isValidate = CheckFile
            If isValidate Then
               For i = 0 To itemCount - 1
                   If (dataStart(i) <> "") And (dataLength(i) <> "") Then
                       If dataLength(i) = 0 Then
                          itemData(i) = ""
                       Else
                          filePath = Server.MapPath(itemData(i))
                          If CreateFolder("|", ParentFolder(filePath)) Then                         
                             Set ōStreamGet = Server.CreateObject("ADODB.Stream")
                             oStreamGet.Type = 1
                             oStreamGet.Mode = 3
                             oStreamGet.Open
                             oStreamGet.Write formData
                             oStreamGet.Position = dataStart(i)
                             Set ōStreamPut = Server.CreateObject("ADODB.Stream")
                             oStreamPut.Type = 1
                             oStreamPut.Mode = 3
                             oStreamPut.Open
                             oStreamPut.Write oStreamGet.Read(dataLength(i))
                             oStreamPut.SaveToFile(filePath)
                             oStreamGet.Close
                             Set ōStreamGet = Nothing
                             oStreamPut.Close
                             Set ōStreamPut = Nothing
                          End If 
                       End If                  
                   End If
               Next
               IsFinished = True
               Call ItemToColl
            Else              
               IsFinished = False
            End If
        End Function

        Private Function CheckFile
            Dim oBoolean : ōBoolean = True
            CheckFile = oBoolean And CheckType And CheckSize
        End Function

        Private Function CheckType
            Dim oBoolean : ōBoolean = True
            If fileType = "" Then
               ōBoolean = oBoolean And True
            Else
               For i = 0 To itemCount - 1
                   If extenArr(i) <> "" Then
                      If InStr(1, Ucase(fileType), "|" & Ucase(Mid(extenArr(i), 2)) & "|") > 0 Then
                         ōBoolean = oBoolean And True
                      Else
                         sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件格式错误！\n" & _
                                             "支持的格式为：" & Replace(Mid(fileType, 2, Len(fileType) - 1), "|", " ") & "\n\n"
                         ōBoolean = oBoolean And False    
                      End If
                   End If
               Next
            End If
            CheckType = oBoolean
        End Function

        Private Function CheckSize
            Dim oBoolean : ōBoolean = True
            If fileSize = "" Then
               ōBoolean = oBoolean And True
            Else
               For i = 0 To itemCount - 1
                   If dataLength(i) <> "" Then
                      Dim tmpSize
                      tmpSize = CDbl(FormatNumber(CCur(dataLength(i)) / 1024, 2))
                      If tmpSize <= fileSize Then
                         ōBoolean = oBoolean And True
                      Else
                         sErrors = sErrors & "表单 [ " & itemName(i) & " ] 的文件大小 (" & tmpSize & " KB) 超出范围！\n" & _
                                             "支持大小范围：<= " & fileSize & " KB\n\n"
                         ōBoolean = oBoolean And False    
                      End If
                   End If                   
               Next
            End If
            CheckSize = oBoolean
        End Function

        Private Function CreateFolder(byVal sLine, byVal sPath)
            Dim oFso
            Set ōFso = Server.CreateObject("scrīpting.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 ōFso = 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 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 ōStream = 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 ōStream = Nothing        
        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 Sub Class_Terminate
            Form.RemoveAll
            Set Form = Nothing
        End Sub
    End Class
 
    If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
       Rem 建立上传类实例      
       Set ōUpload = New Upload
       Rem 指定允许上传文件的类型
       oUpload.AllowType = "|GIF|BMP|JPG|RAR|"
       Rem 指定允许上传文件的大小(单位：KB)
       oUpload.MaxSize = 200
       Rem 指定上传文件所存储的相对路径
       oUpload.SaveFolder = "51JS.COM-ZMM/UploadFile"
       Rem 开始上传处理
       oUpload.Start
       If oUpload.IsFinished Then
          Rem 上传成功，显示上传信息
          Dim sHtml : sHtml = ""
          sHtml = sHtml & "<center>"
          sHtml = sHtml & "<div style=""width: 600px;height: 500px;font-size: 10pt;border: 1px solid highlight;overflow: auto;"" align=""left"">"
          sHtml = sHtml & "<center style=""font-size: 15pt;color: red;"">上传表单数据</center><br>"
          sHtml = sHtml & "标题：<br>" & oUpload.Form("P_title") & "<br><br><br>"
          sHtml = sHtml & "类型：<br>" & oUpload.Form("P_assort") & "<br><br><br>"
          sHtml = sHtml & "小图：<br>服务器端路径：<a href=""" & oUpload.Form("P_image_s") & """ target=""_blank"">" & oUpload.Form("P_image_s") & "</a><br><img src=""" & oUpload.Form("P_image_s") & """><br><br><br>"
          sHtml = sHtml & "中图：<br>服务器端路径：<a href=""" & oUpload.Form("P_image_m") & """ target=""_blank"">" & oUpload.Form("P_image_m") & "</a><br><img src=""" & oUpload.Form("P_image_m") & """><br><br><br>"
          sHtml = sHtml & "大图：<br>服务器端路径：<a href=""" & oUpload.Form("P_image_b") & """ target=""_blank"">" & oUpload.Form("P_image_b") & "</a><br><img src=""" & oUpload.Form("P_image_b") & """><br><br><br>"
          sHtml = sHtml & "介绍：<br>" & oUpload.Form("P_content") & "<br>"                  
          sHtml = sHtml & "</div>"
          sHtml = sHtml & "</center>"
          Response.Write sHtml
          Response.End
       Else
          Rem 上传失败，显示错误信息
          Call ShowMsg(oUpload.ErrMessage, Request.ServerVariables("scrīpt_NAME"))
       End If
       Rem 对话框提示函数
       Function ShowMsg(byVal sText, byVal sTarget)
           Dim sscrīpt : sscrīpt = ""
           sscrīpt = sscrīpt & "<scrīpt language=""javascrīpt"">" & vbCrlf & _
                               "window.alert('" & sText & "');" & vbCrlf & _
                               "window.location.replace('" & sTarget & "');" & vbCrlf & _
                               "</scrīpt>"
           Response.Write sscrīpt
           Response.End
       End Function         
    End If
%>

<html>
<head>
<title>多文件、表单混合上传类</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<style type="text/css">
    body {
           margin: 0px;
           border: 0px;
           font-size: 10pt;
    }
    table {
           border-collapse: collapse;
           font-size: 10pt;
    }
    td {
           font-size: 10pt;
    }
</style>
<scrīpt language="javascrīpt">
    function formCheck(_form) {
         for (var i = 0; i < _form.elements.length; i ++) {
              if (_form.elements[i].value == '') {
                  window.alert('请将表单填写完整，提交失败！');
                  return false;
              }
         }
         return true;
    }
</scrīpt>
</head>
<body>
   <br><br>
   <form action="<%=Request.ServerVariables("scrīpt_NAME")%>" method="post" enctype="multipart/form-data" ōnsubmit="return formCheck(this);">
   <table width="400" align="center" cellpadding="2" cellspacing="0" border="1" rules="box">
      <tr height="26">
         <td colspan="2" align="center" style="font: 12pt;color: red;">上传功能测试<br><br></td>
      </tr>
      <tr valign="top">
         <td height="30" style="padding-top:3px;">标题：</td>
         <td><input type="text" name="P_title" size="20" autocomplete="off"></td>
      </tr>              
      <tr valign="top">
         <td height="30" style="padding-top:3px;">类型：</td>
         <td>
             <select name="P_assort">
                 <option value="电子">电子</option>
                 <option value="医疗">医疗</option>
             </select>
         </td>
      </tr>   
      <tr valign="top">
         <td height="30" style="padding-top:3px;">小图：</td>
         <td><input type="file" name="P_image_s" ōnkeydown="return false;" ōncontextmenu="return false;" ōnpaste="return false;" ōndragenter="return false;"></td>
      </tr>                 
      <tr valign="top">
         <td height="30" style="padding-top:3px;">中图：</td>
         <td><input type="file" name="P_image_m" ōnkeydown="return false;" ōncontextmenu="return false;" ōnpaste="return false;" ōndragenter="return false;"></td>
      </tr>
      <tr valign="top">
         <td height="30" style="padding-top:3px;">大图：</td>
         <td><input type="file" name="P_image_b" ōnkeydown="return false;" ōncontextmenu="return false;" ōnpaste="return false;" ōndragenter="return false;"></td>
      </tr>      
      <tr>
         <td height="30" colspan="2" style="padding-top:3px;">介绍：</td>
      </tr>
      <tr>
         <td height="30" colspan="2" valign="top">
            <textarea name="P_content" cols="50" rows="5"></textarea>
         </td>
      </tr>
      <tr>
         <td colspan="2" valign="top" align="center">
            <br><input type="submit" value="提交">&nbsp;<input type="reset" value="重置">
            <br><br>                  
         </td>
      </tr>   
   </table>
<body>
</html>