黑色海岸线论坛 - Powered by Discuz! Board

Dim myResponse As Response
Dim myRequest As Request
Dim myApplication As Application
Dim myServer As Server
Dim mySession As Session
Public bCrLf As String, ReadBytes As Long, ToRead As Long
Public intSeparator As Integer, strFileData As String, strUpLoadData As String
Public strSeparator As String, strSaveFName As String, strFileSavePath As String
Public File_start As Long, File_end As Long, strDate As String, lngTime As Long
Public strItem As String, strItemName As String, intTemp As Long, strTemp As String
Public strFileType As String, strFileName As String, strFileExt As String, LngFileSize As Long
Public Err_Code As Integer
Dim File_SavePath As String, p_MaxSize As Long, p_FileType As String, p_SavePath As String, p_AutoSave As Integer
';建立ADODB.Stream对象
Public objStream As New ADODB.Stream
Public binItem As New ADODB.Stream
';Dictionary对象，用于保存
Public objForm As New Scripting.Dictionary
';当组件被创建的时候会触发这个事件
Public Sub OnStartPage(myScriptingContent As ScriptingContext)
';进行对象的实例化
Set myResponse = myScriptingContent.Response
Set myRequest = myScriptingContent.Request
Set myServer = myScriptingContent.Server
Set myApplication = myScriptingContent.Application
Set mySession = myScriptingContent.Session
End Sub
';当组件被销毁的时候触发这个事件
Public Sub OnEndPage()
';销毁对象
Set myResponse = Nothing
Set myRequest = Nothing
Set myServer = Nothing
Set myApplication = Nothing
Set mySession = Nothing
End Sub
';初始化上传参数
Public Sub Class_Initialize()
';错误代码初始化：-1表示没有文件上传
Err_Code = -1
';允许的文件大小为150KB
p_MaxSize = 204800
';允许的文件类型为jpg/gif
p_FileType = "jpg/gif"
';文件保存路径为空，即当前目录
p_SavePath = ""
';文件保存方式默认为自动
p_AutoSave = 0
';取当前日期生成字符串
strDate = Replace(CStr(Date), "-", "")
lngTime = CLng(Timer() * 1000)
';比较方式为“文本比较”
objForm.CompareMode = 1
End Sub
';版权属性 Version
Public Property Get Version() As String
Version = "CodeWorld Upload Class V1.0"
End Property
';错误代码 Error
Public Property Get Error() As Integer
Error = Err_Code
End Property
';允许的文件大小 MaxSize
Public Property Get MaxSize() As Long
MaxSize = p_MaxSize
End Property
Public Property Let MaxSize(ByVal LngFSize As Long)
If IsNumeric(LngFSize) Then
p_MaxSize = CLng(LngFSize)
End If
End Property
';允许的文件类型 FileType
Public Property Get FileType() As String
FileType = p_FileType
End Property
Public Property Let FileType(ByVal strType As String)
p_FileType = strType
End Property
';保存路径
Public Property Get SavePath() As String
SavePath = p_SavePath
End Property
Public Property Let SavePath(ByVal strPath As String)
p_SavePath = Replace(strPath, Chr(0), "")
End Property
';是否自动保存
Public Property Get AutoSave() As Integer
AutoSave = p_AutoSave
End Property
Public Property Let AutoSave(ByVal Flag As Integer)
Select Case Flag
Case 0: Flag = 0
Case 1: Flag = 1
Case Else: Flag = 0
End Select
p_AutoSave = Flag
End Property
Public Sub Class_Terminate()
binItem.Close
objStream.Close
Set objStream = Nothing
Set binItem = Nothing
End Sub
Public Sub Upload()
If Err_Code = -1 Then
Err_Code = 0
Else
Exit Sub
End If
';回车换行符的二进制数据
bCrLf = ChrB(13) & ChrB(10)
ReadBytes = 0
';IIS6.0的限制的大小
ToRead = 200000
';指定返回数据类型 adTypeBinary=1,adTypeText=2
objStream.Type = 1
';指定打开模式 adModeRead=1,adModeWrite=2,adModeReadWrite=3
objStream.Mode = 3
objStream.Open
binBytes = myRequest.TotalBytes
If binBytes = 0 Then
';错误输出：没有上传任何数据
Err_Code = -1
Exit Sub
End If
';判断提交的数据是否超过限制，如果没有则按原大小读取
Do While ReadBytes < binBytes
';提交的数据或最后一次所取数据可能不足200K，加个判断即可取得精确数据长度
If ToRead > binBytes - ReadBytes Then
ToRead = binBytes - ReadBytes
End If
objStream.Write myRequest.BinaryRead(ToRead)
ReadBytes = ReadBytes + ToRead
Loop
';设置对象指针位置
objStream.Position = 0
objStream.Type = 2
strUpLoadData = objStream.ReadText
';取得分界符的长度
intSeparator = InStrB(1, strUpLoadData, bCrLf) - 1
';取得分界符
strSeparator = LeftB(strUpLoadData, intSeparator)
';数据块开始位置=分界符长度加上1个回车符，再加上一个文件块的首字符
File_start = intSeparator + 2
';在两个回车符处结束，获得数据头部信息
File_end = InStrB(File_start, strUpLoadData, bCrLf & bCrLf) + 3
';指定binItem对象返回的数据为二进制
binItem.Type = 1
';打开对象
binItem.Open
';设置objStream对象当前指针位置
objStream.Position = File_start
';将objStream中的第一段数据复制入binItem中
objStream.CopyTo binItem, File_end - File_start
binItem.Position = 0
binItem.Type = 2
binItem.Charset = "gb2312"
strItem = binItem.ReadText
binItem.Close
';下一段数据开始位置
File_start = File_end
';下一块的结束位置，注意要减去一个分界符位
File_end = InStrB(File_start, strUpLoadData, strSeparator) - 1
binItem.Type = 1
binItem.Open
';重置objStream指针位置
objStream.Position = File_start
';数据块长度，即文件大小
LngFileSize = File_end - File_start - 2
If LngFileSize = 0 Then
';错误输出：没有上传任何数据
Err_Code = -1
Exit Sub
End If
';将文件数据拷入binItem
objStream.CopyTo binItem, LngFileSize
';下面进行头部分析工作
';39是“Content-Disposition: form-data; name="”的长度，在此后面找到的第一个双引号为表单域名结束
intTemp = InStr(39, strItem, """")
';取得表单域名
strItemName = Mid(strItem, 39, intTemp - 39)
';从表单域名后开始查找文件名
If InStr(intTemp, strItem, "filename=""") <> 0 Then
intTemp = intTemp + 13
';获取文件类型即第一块中“Content-Type: ”的位置+14
strFileType = Mid(strItem, InStr(intTemp, strItem, "Content-Type: ") + 14)
';得到文件完整源路径
strTemp = Mid(strItem, intTemp, InStr(intTemp, strItem, """") - intTemp)
intTemp = InStrRev(strTemp, "\")
';得到文件名
strFileName = Mid(strTemp, intTemp + 1)
End If
';取得文件扩展名
If InStr(intTemp, strTemp, ".") <> 0 Then
strFileExt = Mid(strTemp, InStrRev(strTemp, ".") + 1)
Else
strFileExt = ""
End If
If Not objForm.Exists(strItem & "_From") Then
';将文件类型、文件名、文件本地路径、文件大小保存到对象
objForm.Add strItemName & "_Type", strFileType
objForm.Add strItemName & "_Name", strFileName
objForm.Add strItemName & "_Path", Left(strTemp, intTemp)
objForm.Add strItemName & "_Size", LngFileSize
objForm.Add strItemName & "_Ext", strFileExt
objForm.Add strItemName & "_Err", -1
End If
If InStr(1, LCase("/" & p_FileType & "/"), LCase("/" & strFileExt & "/")) = 0 And p_FileType <> "" Then
';错误输出：文件类型不正确
Err_Code = 2
Exit Sub
End If
';文件大小检查
If LngFileSize > p_MaxSize And p_MaxSize <> 0 Then
';错误输出：文件大小超过限制
Err_Code = 1
Exit Sub
End If
';取文件名
If p_AutoSave = 0 Then
strSaveFName = GetTimeStr()
strSaveFName = strSaveFName & "." & strFileExt
Else
strSaveFName = strFileName
End If
';去除头尾斜杠
p_SavePath = ReMoveBias(p_SavePath)
';过滤不安全字符
p_SavePath = ReplaceFileName(p_SavePath)
';保证保存路径完整性
Call CreateSavePath(p_SavePath)
';安全边界检查，是否越过网站根路径
If Not CheckSavePath(p_SavePath) Then
';错误输出：保存路径出错，越过安全范围
Err_Code = 3
Exit Sub
End If
strFileSavePath = ""
strFileSavePath = "./" & p_SavePath & "/" & strSaveFName
';储存文件
binItem.SaveToFile myServer.MapPath(strFileSavePath)
objForm.Add strItemName & "_SavePath", Right(strFileSavePath, Len(strFileSavePath) - 2)
End Sub
';根据当前日期时间生成文件名
Public Function GetTimeStr()
lngTime = lngTime + 1
GetTimeStr = strDate & lngTime
End Function
';获取对象中保存的数据
Public Function Form(ByVal Item As String)
If objForm.Exists(Item) Then
Form = objForm(Item)
Else
Form = ""
End If
End Function
';保证保存路径完整性
Private Sub CreateSavePath(ByVal strPath As String)
';创建FSO对象
Dim fsoPath As New Scripting.FileSystemObject
Dim strCheckPath As String
strCheckPath = myServer.MapPath("./")
';利用数组保存文件夹
Arr_strPath = Split(strPath, "/")
';从上到下循环建立
For i = 0 To UBound(Arr_strPath)
If Arr_strPath(i) <> "" Then
strCheckPath = strCheckPath & "\" & Arr_strPath(i)
If Not fsoPath.FolderExists(strCheckPath) Then
';如果不存在就创建
fsoPath.CreateFolder (strCheckPath)
End If
End If
Next i
End Sub
';过滤不安全字符
Private Function ReplaceFileName(ByVal strPath As String)
strPath = Replace(strPath, ":", "")
strPath = Replace(strPath, "\", "")
strPath = Replace(strPath, "*", "")
strPath = Replace(strPath, """", "")
strPath = Replace(strPath, "<", "")
strPath = Replace(strPath, ">", "")
strPath = Replace(strPath, "|", "")
ReplaceFileName = strPath
End Function
';去掉头尾“/”或“./”
Private Function ReMoveBias(ByVal strPath As String)
If Asc(Mid(strPath, Len(strPath), 1)) = 47 Then
strPath = Left(strPath, Len(strPath) - 1)
End If
If Asc(Mid(strPath, 1, 1)) = 47 Then
strPath = Right(strPath, Len(strPath) - 1)
End If
If Asc(Mid(strPath, 1, 1)) = 46 And Asc(Mid(strPath, 2, 1)) = 47 Then
strPath = Right(strPath, Len(strPath) - 2)
End If
ReMoveBias = strPath
End Function
';安全边界检查，是否越过网站根路径
Function CheckSavePath(ByVal strSavePath As String) As Boolean
Dim strPath As String, intSplit As Integer, intLayer As Integer
intSplit = 0
';取得当前文件所在路径
strPath = myRequest.ServerVariables("SCRIPT_NAME")
If Asc(Mid(strPath, 1, 1)) = 47 Then
strPath = Right(strPath, Len(strPath) - 1)
End If
arrPath = Split(strPath, "/")
';得到当前文件层次
intLayer = UBound(arrPath)
arrSavePath = Split(strSavePath, "/")
';得到允许层次
For i = 0 To UBound(arrSavePath)
If arrSavePath(i) = ".." Then
intSplit = intSplit + 1
End If
Next
If intSplit > intLayer Then
CheckSavePath = False
Else
CheckSavePath = True
End If
End Function

复制代码