uploadx.asp

很好的一个OA系统,界面和功能都不错,测试无错~

<%
'****************************************************************************************
'程序名(Program Name): Allyes 无组件上传程序											*
'功能(Function)：	1.可自行设定上传文件大小											*
'					2.可自行根据主机Fso状态设置Fso的支持状态							*
'					3.可自行设定保存文件的方式(0=唯一方式,1=报错方式,2=覆盖方式)		*
'作者(Author):	Allyes·Mac																*
'最后修改日期(The Date for last Modify):2003年6月21日									*
'版本(Version):	1.003 build 205															*
'修改(Modify):	1、添加了显示文件大小(Build 204升级为Build 205)							*
'				2、添加了上传文件格式限制(Build 203 升级为Build 204)					*
'个人站点(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																	*
'****************************************************************************************
Option Explicit

Dim FormData, FormSize, Divider, bCrLf
Dim FixFileExt

FormSize = Request.TotalBytes
FormData = Request.BinaryRead(FormSize)
bCrLf = ChrB(13) & ChrB(10)
Divider = LeftB(FormData, InStrB(FormData, bCrLf) - 1)
FixFileExt="asp|aspx|asa|asax|ascx|ashx|asmx|axd|cdx|cer|config|cs|csproj|licx|rem|resx|shtml|shtm|soap|stm|vb|vbproj|webinfo|cgi|pl|php|phtml|php3"		'限制为只有这些文件可以上传(用"|"号格开)

Function SaveFile(FormFileField, Path, MaxSize, SavType, FsoType)
	If (SavType=0 or SavType=1) and FsoType=0 then
		SaveFile = "modeError"
		Exit function
	End if

    Dim ObjStream,Allyes_ObjStream
	Dim StartPos
	Dim Strlen, SearchStr
	Dim FileStart, FileLen, FileContent
	Dim Re_SavType
	Dim fnN
    Dim intfnN
	Dim FileExtName
    Dim FixFnN
	Dim intFix
	Dim i

    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)
	
	'-----------------------------------检测路径------------------------------------
    If Right(Path,1) <> "\" Then		'检测目录参数的完整性
        Path = Path & "\"
    End If
	If FsoType = 1 then					'如果支持FSO则检测。否则不检测
		CheckPath(path)					'检测指定目录是否存在，如果不存在，则自行创建
	End if
	'-------------------------------------------------------------------------------
	If len(trim(MaxSize)) = 0 then
		MaxSize=50*1024					'指定默认最大上传文件为50M
	End if

    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))
            
            ''----------------文件格式限制------------------------
            fnN = split(fileName,".")
            intfnN = Ubound(fnN)
            FileExtName = trim(fnN(intfnN))
            FixFnN = Split(FixFileExt,"|")
			intFix = Ubound(FixFnN)
			for i = 0 to intFix
				if lcase(FileExtName) = lcase(trim(FixFnN(i))) then
					SaveFile = "fileError"
					exit do
				end if
			next
            '------------------------------------------------------
            
            If FileName <> "" Then
                FileStart = InStrB(StartPos, FormData, bCrLf & bCrLf) + 4
                FileLen = InStrB(StartPos, FormData, Divider) - 2 - FileStart
                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

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

                    On error resume next
					Allyes_ObjStream.SaveToFile Path & FileName, SavType
					if err.number<>0 then
						If Re_SavType=0 or Re_SavType=2 then
							FileName="pathError"
						else
							FileName="refileError"
						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 & ",refileError"
                    Else
                        SaveFile = "sizeError"
                    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
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 bin2str(binstr)
	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)
	Dim i
    For i = 1 To Len(str)
        str2bin = str2bin & ChrB(Asc(Mid(str, i, 1)))
    Next
End Function

Function GetFileName(str,path,savtype,fsotype)
	Dim fs
	Dim i
	Dim hFileName
	Dim rFileName

    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 fsotype=1 then									'如果支持FSO,则执行FSO过程
		Set fs = Server.CreateObject("Scripting.FileSystemObject")
		If savtype = 0 and fs.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 fs.FileExists(path & bin2str(hFileName) & i & bin2str(rFileName)) = False Then
					FileName = hFileName & str2bin(i) & rFileName
					Exit For
				End If
			Next
		End If
		Set fs = Nothing
	End If
	GetFileName = FileName
End Function

Function CheckPath(path)								'检测该目录是否存在，如果不存在，则建立该目录
	Dim Fs
	set Fs=server.CreateObject("scripting.filesystemobject")
	if not fs.FolderExists(path) then
		Fs.CreateFolder(path)
	end if
	set Fs = nothing
End function
%>