uploadx.asp

仿雅虎论坛静态生成html版 后台管理：admin/admin.asp 用户名：admin 密码：admin TOP/top.htm 顶部模板 left.htm 左边树形菜单模板

<%
'********************************************************************************************************
'程序名(Program Name): Allyes 无组件上传程序																*
'功能(Function)：	1.可自行设定上传文件大小																*
'					2.可自行根据主机Fso状态设置Fso的支持状态													*
'					3.可自行设定保存文件的方式(0=唯一方式,1=报错方式,2=覆盖方式)								*
'作者(Author):	Allyes·Mac																				*
'最后修改日期(The Date for last Modify):2003年9月28日														*
'个人站点(WebSite):	http://[e-mail]																*
'使用方式(Option):																						*
'*将上传的文件保存到path所指定的目录下面。																	*
'Formfilefield  上传表单的"file"域名																		*
'Path       要保存文件的服务器绝对路径，形式为："d:\path\subpath"或"d:\path\subpath\"							*
'MaxSize    限制上传文件的最大长度，以KByte为单位															*
'SavType    服务器保存文件的方式：																			*
'           0   唯一文件名方式，如果有同名则自动改名；														*
'           1   报错方式，如果有同名则出错；																*
'           2   覆盖方式，如果有同名则覆盖原来的文件															*
'FsoType	Fso支持模式																					*
'			0   不支持																					*
'			1   支持FSO																					*
'ForbidType	限制文件上传格式																				*
'			0	config.asp文件中的FixFileExt变量列表为不可上传的类型											*
'			1	config.asp文件中的FixFileExt变量列表为可上传的类型											*
'********************************************************************************************************
'Option Explicit
Dim FormData, FormSize, Divider, bCrLf
Dim S_time
Dim E_time

S_time = timer()
FormSize = Request.TotalBytes
FormData = Request.BinaryRead(FormSize)
E_time = timer()
bCrLf = ChrB(13) & ChrB(10)
Divider = LeftB(FormData, InStrB(FormData, bCrLf) - 1)

Function Version()
	Version = Ver
End Function

Function bin2str(binstr)								'Bin to Str
	Dim BytesStream,StringReturn

	Set BytesStream = Server.CreateObject("ADODB.Stream")
		With BytesStream
			.Type = 2
			.Open
			.WriteText binstr
			.Position = 0
			.Charset = "GB2312"
			.Position = 2
			StringReturn = .ReadText
			.close
		End With
		Set BytesStream = Nothing
	bin2str = StringReturn
End Function

Function str2bin(str)									'Str to Bin
	Dim i
    For i = 1 To Len(str)
        str2bin = str2bin & ChrB(Asc(Mid(str, i, 1)))
    Next
End Function

Function GetFormVal(FormName)							'取得如果是表单项目的过程
	Dim StartPos
	Dim Strlen, SearchStr
	Dim ValStart, ValLen, ValContent

    GetFormVal = ""
    StartPos = LenB(Divider) + 2
    FormName = Chr(34) & FormName & Chr(34)
    Do While StartPos > 0
        Strlen = InStrB(StartPos, FormData, bCrLf) - StartPos
        SearchStr = MidB(FormData, StartPos, strlen)
        If InStr(bin2str(SearchStr), FormName) > 0 Then
               ValStart = InStrB(StartPos, FormData, bCrLf & bCrLf) + 4
               ValLen = InStrB(StartPos, FormData, Divider) - 2 - ValStart
                  ValContent = MidB(FormData, ValStart, ValLen)
               If GetFormVal <> "" Then
                GetFormVal = GetFormVal & "," & bin2str(ValContent)
            Else
                GetFormVal = bin2str(ValContent)
            End If
        End If
        If InStrB(StartPos, FormData, Divider) < 1 Then
            Exit Do
        End If
        StartPos = InStrB(StartPos, FormData, Divider) + LenB(Divider) + 2
    Loop
End Function

Function GetFileName(str,path,savtype,fsotype)			'取得文件名
	Dim Fso
	Dim i
	Dim hFileName
	Dim rFileName
	Dim RndStr
	Dim re_FnN
	Dim re_intN
	Dim T_FnN
	
    str = RightB(str,LenB(str)-InstrB(str,str2bin("filename="))-9)
    GetFileName = ""
    FileName = ""
    For i = LenB(str) To 1 Step -1
        If MidB(str, i, 1) = ChrB(Asc("\")) Then
            FileName = MidB(str, i + 1, LenB(str) - i - 1)
            Exit For
        End If
    Next
	
	If savType=0 then									'如果要自动改名
		if fsotype = 1 then								'如果支持FSO,则执行FSO过程的改名方式
			Set Fso = Server.CreateObject("Scripting.FileSystemObject")
			If savtype = 0 and Fso.FileExists(path & bin2str(FileName)) = True Then
				hFileName = FileName
				rFileName = ""
				For i = LenB(FileName) To 1 Step -1
					If MidB(FileName, i, 1) = ChrB(Asc(".")) Then
						hFileName = LeftB(FileName, i-1)
						rFileName = RightB(FileName, LenB(FileName)-i+1)
						Exit For
					End If
				Next
				For i = 0 to 9999 
					If Fso.FileExists(path & bin2str(hFileName) & i & bin2str(rFileName)) = False Then
						FileName = hFileName & str2bin(i) & rFileName
						Exit For
					End If
				Next
			End If
			Set Fso = Nothing
		else											'如果不支持Fso.则执行添加随机数的改名方式
			Randomize
			RndStr = Cstr(clng(Rnd(9)*100000000))
			re_FnN = Split(bin2str(FileName),".")
			re_intN = Ubound(re_FnN)
			T_FnN = ""
			for i=0 to re_intN
				if i = re_intN then
					T_FnN = T_FnN & RndStr &"."& Trim(re_FnN(i))
				else
					T_FnN = T_FnN & Trim(re_FnN(i))
				end if
			next
			FileName = str2bin(T_FnN)
		end if
	End If
	GetFileName = FileName
End Function

Function CheckPath(path)								'检测该目录是否存在，如果不存在，则建立该目录
	Dim Fso
	set Fso = Server.CreateObject("Scripting.FilesystemObject")
	if not Fso.FolderExists(path) then
		Fso.CreateFolder(path)
	end if
	set Fso = nothing
End function

Function CheckFso()										'检测是否支持FSO
	Dim Fso
	On Error Resume Next
	Set Fso = Server.CreateObject("Scripting.FilesystemObject")
	IF Err.number <> 0 then
		CheckFso = false
	Else
		CheckFso = True
	End IF
End Function

Function forbidFileName(tFnN,ForbidType)				'检测文件是否被禁止
	Dim fnN
    Dim intfnN
	Dim FileExtName
    Dim FixFnN
	Dim intFix
	Dim i
	Dim Fflag
	
	Fflag = False
	fnN = Split(tFnN,".")
	intfnN = Ubound(fnN)
	IF intfnN = 0 then
		Fflag = true
	Else
		FileExtName = Lcase(Trim(fnN(intfnN)))
		FixFnN = Split(FixFileExt,"|")
		intFix = Ubound(FixFnN)
		For i = 0 to intFix
			IF ForbidType = 1 then
				Fflag = True
				IF Lcase(Trim(FixFnN(i))) = FileExtName then
					Fflag = false
					exit for
				End if
			Else
				IF Lcase(Trim(FixFnN(i))) = FileExtName Then
					Fflag = True
					Exit For
				End IF
			End if
		Next
	End IF
	forbidFileName = Fflag
End Function


Function SaveFile(FormFileField, Path, MaxSize, SavType, FsoType, ForbidType)			'主处理过程开始
	Dim ObjStream,Allyes_ObjStream
	Dim StartPos
	Dim Strlen, SearchStr
	Dim FileStart, FileLen, FileContent
	Dim Re_SavType
	Dim FsoFlag
	
	IF FsoType = 1 Then
		FsoFlag = CheckFso()
		IF Not FsoFlag Then
			SaveFile = "FsoError|0"
			Exit Function
		End IF
	End IF
	
	If len(trim(MaxSize)) = 0 then
		MaxSize=50*1024									'指定默认最大上传文件为50M
	End if
	
    If Right(Path,1) <> "\" Then						'检测目录参数的完整性
        Path = Path & "\"
    End If
    
	If FsoType = 1 then									'如果支持FSO则检测指定目录是否存在，如果不存在，则自行创建
		CheckPath(path)
	End if

    Set ObjStream = Server.CreateObject("ADODB.Stream")
    Set Allyes_ObjStream = Server.CreateObject("ADODB.Stream")
    ObjStream.Mode = 3
    ObjStream.Type = 1
    Allyes_ObjStream.Mode = 3
    Allyes_ObjStream.Type = 1
    SaveFile = ""
    StartPos = LenB(Divider) + 2
    FormFileField = Chr(34) & FormFileField & Chr(34)

    Do While StartPos > 0								'开始保存每个file文件对象数据
        strlen = InStrB(StartPos, FormData, bCrLf) - StartPos
        SearchStr = MidB(FormData, StartPos, strlen)
        If InStr(bin2str(SearchStr), FormFileField) > 0 Then
            FileName = bin2str(GetFileName(SearchStr,path,SavType,FsoType))
            If FileName <> "" Then
				FileStart = InStrB(StartPos, FormData, bCrLf & bCrLf) + 4
				FileLen = InStrB(StartPos, FormData, Divider) - 2 - FileStart
				IF Not forbidFileName(FileName,ForbidType) Then
					If FileLen <= MaxSize*1024 Then
					    FileContent = MidB(FormData, FileStart, FileLen)
						Allyes_ObjStream.Open
						With ObjStream
							.Open
							.Write FormData
							.Position = FileStart-1
							.CopyTo Allyes_ObjStream,FileLen
						End With

					    If SavType = 0 Then
					        Re_SavType = 1
					    Else
							Re_SavType = SavType
					    End If

					    On error resume next
						Allyes_ObjStream.SaveToFile Path & FileName, Re_SavType
						if Err.Number <> 0 then
							IF FsoType = 0 Then
								IF SavType = 1 then
									FileName = "ReFileError"
								Else
									FileName = "PathError"
								End IF
							Else
								IF SavType = 1 then
									FileName = "ReFileError"		'文件重复(在指定报错模式下)
								Else
									FileName = "PathError"
								End IF
							End IF
						end if
						ObjStream.Close
						Allyes_ObjStream.Close

						If SaveFile <> "" Then
					        SaveFile = SaveFile & ","  & FileName &"|"& FileLen
					    Else
					        SaveFile = FileName &"|"& FileLen
					    End If
					Else
					    If SaveFile <> "" Then
					        SaveFile = SaveFile & ",SizeError|"& FileLen
					    Else
					        SaveFile = "SizeError|"& FileLen
					    End If
					End If
				Else
					If SaveFile <> "" Then
						SaveFile = SaveFile & ",FixError|"& FileLen
					Else
						SaveFile = "FixError|"& FileLen
					End If
				End IF
            End If
        End If
        If InStrB(StartPos, FormData, Divider) < 1 Then
            Exit Do
        End If
        StartPos = InStrB(StartPos, FormData, Divider) + LenB(Divider) + 2
    Loop
    Set ObjStream = Nothing
    Set Allyes_ObjStream = Nothing
End Function
%>