<%@ Language="VBScript" CodePage=65001%>
 <%Option Explicit%>
<%
'Code: 200(上传成功)、504(文件为空)、502(上传上限)、501（表示网络中断）、500(上传错误)、
'505(文件类型禁止上传), 506(未设置允许的文件后缀), 507(未设置上传路径)
'--------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------
Server.ScriptTimeout = 99999999
Response.Buffer = True
Response.Charset = "utf-8"
 Const UPLOAD_PATH = "/upload/"
Class Upload_Cls
Private objUpStream, objConvertStream, objFso
Private lngMaxSize, lngRequestBytes, lngReadChunkBytes
Private strCode
Private strFileSuffix, strFilename, strAllowSuffix, strFilePath, lngFileSize, i
Private Sub Class_Initialize()
Code = 0
MaxSize = 0
lngReadChunkBytes = 131072 '64KB
lngRequestBytes = CLng(Request.TotalBytes)
End Sub
Private Sub Class_Terminate()
If IsObject(objUpStream) Then
objUpStream.Close
Set objUpStream = Nothing
Set objConvertStream = Nothing
End if
End Sub
'------
'定义允许上传的文件格式, 用英文逗号隔开(,) 形如: gif,jpg
'------
Public Property Let AllowSuffix(strVal)
strAllowSuffix = LCase(strVal)
End Property
Public Property Get FileName()
FileName = strFileName
End Property
Public Property Let FileName(strVal)
strFileName = strVal
End Property
'------
'获取上传的文件后缀名
'------
Public Property Get FileSuffix()
FileSuffix = strFileSuffix
End Property
Public Property Let FileSuffix(strVal)
strFileSuffix = strVal
End Property
'------
'获取上传文件大小 单位：KB
'------
Public Property Get FileSize()
FileSize = lngFileSize
End Property
Private Property Let FileSize(lngVal)
lngFileSize = lngVal
End Property
'-------
'获取上传文件相对路径
'-------
Public Property Get FilePath()
FilePath = strFilePath
End Property
'-------
'设置上传文件路径
'-------
Public Sub SetFilePath(strCurpath, n)
Dim intRnd
Select Case n
Case Else
Randomize
intRnd = Int(9000 * Rnd)
Randomize
intRnd = intRnd + Int(100 * Rnd)
strFilePath = strCurpath & FormatTimePattern(Now(), "ymd") & "/"
End Select
Call CreateFolder(Server.MapPath(FilePath))
End Sub
'------
Rem 根据时间生成的文件名
'------
Public Function AutoFilePath()
AutoFilePath = FilePath & FileName
End Function
Public Function FormatTimePattern(dateSTime, strPattern)
Dim dateTime, strVal
dateTime = dateSTime
strVal = strPattern
strVal = Replace(strVal, "y", Year(dateTime))
strVal = Replace(strVal, "m", Fill0Char(Month(dateTime)))
strVal = Replace(strVal, "d", Fill0Char(Day(dateTime)))
strVal = Replace(strVal, "h", Fill0Char(Hour(dateTime)))
strVal = Replace(strVal, "n", Fill0Char(Minute(dateTime)))
strVal = Replace(strVal, "s", Fill0Char(Second(dateTime)))
FormatTimePattern = strVal
End Function
Private Function Fill0Char(strVal)
If Len(strVal) < 2 Then
Fill0Char = "0" & strVal
Else
Fill0Char = strVal
End If
End Function
'------
'设置上传文件大小上限(单位: Bytes), 默认4096KB
'------
Public Property Let MaxSize(lngVal)
lngMaxSize = FormatNum(lngVal, 4194304)
End Property
'------
'返回上传状态代码
'------
Public Property Get Code()
Code = strCode
End Property
Private Property Let Code(strVal)
strCode = strVal
End Property
Public Sub GetFileData()
Dim binCrLf, binBoundary
Dim lngFirstBoundary, lngEndBoundary
Dim strInfoHeader, strFieldName, strContentType, strItemValue
Dim objFileStream
Dim intPos'临时位置
strContentType = ""
If lngRequestBytes < 1 Then
Code = 504
Exit Sub
End If
If lngMaxSize <> 0 And lngRequestBytes > lngMaxSize Then
Code = 502
Exit Sub
End If
Set objUpStream = Server.CreateObject("Adodb.Stream")
objUpStream.Mode = 3
objUpStream.Type = 1
objUpStream.Open
Set objConvertStream = Server.CreateObject("adodb.stream")
objConvertStream.Mode = 3
objConvertStream.Charset = "utf-8"
binCrLf = ChrB(13) & ChrB(10) '换行符
lngFirstBoundary = ParseChunk(objUpStream, binCrLf, 1)
binBoundary = SubBinString(1, lngFirstBoundary - 1) '取得边界串
Set objFileStream = New FileInfo_Cls
Do While StrComp(SubBinString(lngFirstBoundary, 2), binCrLf) = 0
lngFirstBoundary = lngFirstBoundary + 2
Rem Begin 分解表单项目
If strContentType = "" Then
Do While True
lngEndBoundary = ParseChunk(objUpStream, binCrLf, lngFirstBoundary)
strInfoHeader = SubString(lngFirstBoundary, lngEndBoundary - lngFirstBoundary)
lngFirstBoundary = lngEndBoundary + 2
intPos = InStr(strInfoHeader, ":")
If intPos = 0 Then Exit Do
If intPos > 0 Then
If StrComp(Left(strInfoHeader,intPos - 1),"Content-Disposition", 1) = 0 Then
'取表单项名称
strFieldName = ExtractValue(strInfoHeader,intPos + 1,"name")
'取文件路径,取文件名称
FileName = ExtractFileName(ExtractValue(strInfoHeader,intPos + 1,"filename"))
If Not CheckSuffix(FileName) Then Exit Sub
ElseIf StrComp(left(strInfoHeader, intPos - 1),"Content-Type",1) = 0 Then
'取文件类型
strContentType = Trim(Mid(strInfoHeader, intPos + 1))
End If
End If
Loop
End If
Rem End 表单项目结束
If FileName <> "" Then
'掐头后移入流对象
MoveStream objUpStream, objFileStream.Stream, lngFirstBoundary
lngEndBoundary = ParseChunk(objFileStream.Stream, binBoundary & binCrLf, 1)
'流对象去尾
MoveStream objFileStream.Stream, objUpStream, lngEndBoundary
lngFirstBoundary = lngFirstBoundary + 2 + LenB(binBoundary)
Else
lngEndBoundary = ParseChunk(objUpStream, binBoundary, lngFirstBoundary)
strItemValue = SubString(lngFirstBoundary, lngEndBoundary - 2 - lngFirstBoundary)
'移动位置
lngFirstBoundary = lngEndBoundary + LenB(binBoundary)
End If
Loop
Code = 200
FileSize = objFileStream.FileSize
Set objFso = Server.CreateObject("Scripting.FileSystemObject")
Call CheckFile
Set objFso = Nothing
objFileStream.SaveAs(Server.MapPath(AutoFilePath))
Set objFileStream = Nothing
End Sub
Private Sub CheckFile()
If objFso.FileExists(Server.MapPath(AutoFilePath)) Then
FileName = "[1]" & strFileName
Call CheckFile
End If
End Sub
Private Function ExtractValue(strString, startPos, strName)
Dim strVal
Dim strCurPos, intCurPos
Dim n1, n2
strVal = strString
strCurPos = strName & "="""
intCurPos = InStr(startPos, strVal, strCurPos)
If intCurPos > 0 Then
n1 = intCurPos + Len(strCurPos)
n2 = InStr(n1, strVal, """")
if n2 > n1 then ExtractValue = Mid(strVal, n1, n2 - n1)
End If
End Function
Private Function SubBinString(StartPos, ReadLen)
Dim lngStartPos, lngReadLen
Dim binBoundary
lngReadLen = ReadLen
If lngReadLen = 0 Then SubBinString = "" : Exit Function
lngStartPos = StartPos
If objUpStream.Size < lngStartPos + lngReadLen - 1 Then ReadChunk2Stream objUpStream
objUpStream.Position = lngStartPos - 1
binBoundary = objUpStream.Read(lngReadLen)
SubBinString = MidB(binBoundary, 1)
End Function
Private Function SubString(StartPos, ReadLen)
Dim lngStartPos, lngReadLen
Dim binBoundary
lngReadLen = ReadLen
If lngReadLen = 0 Then SubString = "" : Exit Function
lngStartPos = StartPos
If objUpStream.Size < (lngStartPos + lngReadLen - 1) Then ReadChunk2Stream objUpStream
objUpStream.Position = lngStartPos - 1
binBoundary = objUpStream.Read(lngReadLen)
With objConvertStream
.Type = 1
.Open
.Write binBoundary
.Position = 0
.Type = 2
SubString = .ReadText
.Close
End With
End Function
Rem 解析一个块
Private Function ParseChunk(obj, Boundary, StartPos)
'读取块的起始位置， 找到边界的位置(0表示没有)
Dim lngStartPos, lngFoundPos, lngBoundaryLen
Dim binChunk
lngStartPos = StartPos
lngFoundPos = 0
lngBoundaryLen = LenB(Boundary)
Do While lngFoundPos = 0
'数据流长度不够时，读取一个块(lngReadChunkBytes)
If obj.Size < (lngStartPos + lngBoundaryLen - 1) Then ReadChunk2Stream obj
obj.Position = lngStartPos - 1
binChunk = obj.Read
lngFoundPos = InstrB(binChunk, Boundary)
'未找到边界，则向后移动一个位置
If lngFoundPos = 0 Then lngStartPos = lngStartPos + LenB(binChunk) - lngBoundaryLen + 1
Loop
ParseChunk = lngStartpos + lngFoundPos - 1
End Function
Private Sub ReadChunk2Stream(obj)
If Response.IsClientConnected = False then Code = 501 : Exit Sub
obj.Position = obj.Size
obj.Write Request.BinaryRead(lngReadChunkBytes)
End Sub
Private Sub MoveStream(FromStream, ToStream, StartPos)
FromStream.Position = StartPos - 1
ToStream.Position = ToStream.Size
FromStream.CopyTo ToStream
FromStream.Position = StartPos - 1
'将流对象的结束设定到当前 位置
FromStream.SetEOS
End Sub
Private Function ExtractFileName(strString)
Dim strVal
strVal = Replace(strString, Chr(0), "")
strVal = Replace(strVal, " ", "")
strVal = Replace(strVal, "..", "")
strVal = Replace(strVal,"'","")
strVal = Replace(strVal,"[","")
strVal = Replace(strVal,"]","")
strVal = Replace(strVal,"<","")
strVal = Replace(strVal,">","")
strVal = Replace(strVal, "*", "")
strVal = Replace(strVal, "&", "")
ExtractFileName = Mid(strVal, InStrRev(strVal, "") + 1)
End Function
Private Function CheckSuffix(strA)
Dim strSeparate, strTempFileSuffix
CheckSuffix = True
strSeparate = ",asp,asa,cer,aspx,php,cdx,htr,shtm,shtml,stm,idc,"
FileSuffix = LCase(Mid(strA, InStrRev(strA, ".") + 1))
strTempFileSuffix = "," & strFileSuffix & ","
If InStr(strSeparate, strTempFileSuffix) > 0 Then
Code = 505
CheckSuffix = False
Exit Function
End If
End Function
Private Function CreateFolder(strFolderPath)
Dim sPath, i, strTempPath, n, objFso, RootPath
CreateFolder = False
Set objFso = Server.CreateObject("Scripting.FileSystemobject")
If objFso.FolderExists(strFolderPath) Then
CreateFolder = True
Exit Function
End If
RootPath = Server.MapPath("/") & ""
sPath = Split(strFolderPath, "")
strTempPath = ""
n = UBound(Split(RootPath, ""))
For i = n To UBound(sPath)
strTempPath = strTempPath & sPath(i) & ""
If Not objFso.FolderExists(RootPath & strTempPath) Then
objFso.CreateFolder (RootPath & strTempPath)
End If
Next
Set objFso = Nothing
If Err = 0 Then
CreateFolder = True
Else
CreateFolder = False
End If
End Function
Private Function FormatNum(intVal, DefaultVal)
If Not IsNumeric(intVal) Then
FormatNum = Clng(DefaultVal)
Else
FormatNum = Clng(intVal)
End If
End Function
End Class
Class FileInfo_Cls
Private objFileStream
Public Function FileSize()
Dim lngSize
lngSize = objFileStream.Size
FileSize = CLng(lngSize / 1024)
End Function
Public Property Get Stream()
Set Stream = objFileStream
End Property
Public Sub SaveAs(strFilePath)
On Error Resume Next
objFileStream.SaveToFile strFilePath, 2
If Err.Number > 0 Then Response.Write "Upload Err: " & Err.Description & "<br>" : Exit Sub
End Sub
Private Sub Class_Initialize
Set objFileStream = CreateObject("Adodb.Stream")
objFileStream.Mode = 3
objFileStream.Type = 1
objFileStream.Open
End sub
Private Sub Class_Terminate
objFileStream.Close
Set objFileStream = Nothing
End sub
End Class
Dim action
Dim objUpload, objFile
action = Trim(Request.QueryString("action"))
Response.Write "<br>"
Select Case action
Case "save"
Call Save
Case "list"
Call FileList
Case Else
Call Header
End Select
Sub Save()
Dim stime, etime
stime = Timer
Set objUpload = New Upload_Cls
objUpload.AllowSuffix = ""
objUpload.MaxSize = 0
objUpload.SetFilePath UPLOAD_PATH, 1
Call objUpload.GetFileData
etime = Timer
Response.Write "上传执行代码Code:" & objUpload.Code & "<br>"
Response.Write "文件路径:" & objUpload.AutoFilePath & "<br>"
Response.Write "文件大小:" & objUpload.FileSize & "KB<br>"
Response.Write "执行时间：" & FormatNumber((etime - stime), 2) & "second"
Set objUpload = Nothing
Call Header
End Sub
Sub Header()
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title></title>
<table width="600" border="0" cellspacing="0" cellpadding="0">
<br><br><br><br><br>
'Code: 200(上传成功)、504(文件为空)、502(上传上限)、501（表示网络中断）、500(上传错误)、
'505(文件类型禁止上传), 506(未设置允许的文件后缀), 507(未设置上传路径)
<form action="?action=save" method="post" enctype="multipart/form-data" name="form1">
<tr align="center">
<td width="80" height="46">选择地址:</td>
<td width="300">
<input name="uploadfile" type="file" id="uploadfile" size="30"></td>
<td width="60"><input type="submit" name="Submit" value="上 传"></td>
</tr>
<tr align="center">
<td height="20" colspan="3"><input type="button" name="Submit" value="关 闭" onClick="window.close();"></td>
</tr>
</form>
</table>
<%
End Sub
Sub FileList()
Dim strPath
Dim objFso, objUpload
Dim objFolders, objFiles, Folder, File
Dim strThisPath
Set objUpload = New Upload_Cls
strPath = Trim(Request.QueryString("path"))
If Len(strPath) = 0 Then
strThisPath = UPLOAD_PATH & objUpload.FormatTimePattern(Now(), "ymd") & "/"
ElseIf CStr(LCase(strPath)) ="/upload/" Then
strThisPath = UPLOAD_PATH
Else
strThisPath = UPLOAD_PATH & strPath
End If
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title></title>
<br>
<table width="780" align="center" border="0" cellspacing="1" cellpadding="0" bgcolor="#CCCCCC">
<a href="?action=list&path=/upload/">返回上一个路径:</a>
<br><br>
当前路径：<%Response.Write strThisPath%>
<br><br>
<tr bgcolor="#EFEFEF">
<td align="center" class="row-path topic">文件夹/文件名</a></td>
<td align="center" height="30">大小</td>
<td align="center">文件类型</td>
<td align="center">创建时间</td>
<td align="center">修改时间</td>
</tr>
<%
Set objFso = Server.CreateObject("Scripting.FileSystemObject")
Set objFolders = objFso.GetFolder(Server.MapPath(strThisPath))
For Each Folder In objFolders.subFolders
%>
<tr bgcolor="#FFFFFF">
<td height="30"><a href="?action=list&path=<%=Folder.Name%>"><%=Folder.Name%></a></td>
<td align="center"><%=FileSize(Folder.Size)%></td>
<td align="center"><%=Folder.Type%></td>
<td align="center"><a title="创建时间"><%=objUpload.FormatTimePattern(Folder.DateCreated, "y-m-d h:n:s")%></a></td><td><a title="修改时间"><%=objUpload.FormatTimePattern(Folder.DateLastModified, "y-m-d h:n:s")%></a></td>
</tr>
<%
Next
For Each File In objFolders.Files
%>
<tr bgcolor="#FFFFFF">
<td height="30"><a href="<%=strThisPath & "/" & File.Name%>"><%=File.Name%></a></td>
<td align="center"><%=FileSize(File.Size)%></td>
<td align="center"><%=File.Type%></td>
<td align="center"><a title="创建时间"><%=objUpload.FormatTimePattern(File.DateCreated, "y-m-d h:n:s")%></a></td><td><a title="修改时间"><%=objUpload.FormatTimePattern(File.DateLastModified, "y-m-d h:n:s")%></a></td>
</tr>
<%
Next
Set objFolders = Nothing
Set objFso = Nothing
Set objUpload = Nothing
%>
</table>
</body>
</html>
<%
End Sub
Function FileSize(intSize)
FileSize = CLng(intSize / 1024) & "K"
End Function
%>
|
