ewupload.asp

AspMaker调用的自定义包

<!--##session upload##-->
<% 
' File upload functions for ASPMaker 5+
' (C) 2006 e.World Technology Ltd.

' Config for file upload
Const EW_UploadDestPath = "<!--##=PROJ.UploadPath##-->" ' upload destination path
Const EW_UploadAllowedFileExt = "<!--##=PROJ.UploadAllowedFileExt##-->" ' allowed file extensions

Const EW_UploadCharset = "<!--##=PROJ.CharSet##-->"

' Function to return path of the uploaded file
'	Parameter: If PhyPath is true(1), return physical path on the server;
'	           If PhyPath is false(0), return relative URL
Function ewUploadPathEx(PhyPath, DestPath)
	Dim Pos
	If PhyPath Then
		ewUploadPathEx = Request.ServerVariables("APPL_PHYSICAL_PATH")
		ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
		ewUploadPathEx = ewUploadPathEx & Replace(DestPath, "/", "\")
	Else
		ewUploadPathEx = Request.ServerVariables("APPL_MD_PATH")
		Pos = InStr(1, ewUploadPathEx, "Root", 1)
		If Pos > 0 Then	ewUploadPathEx = Mid(ewUploadPathEx, Pos+4)
		ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
		ewUploadPathEx = ewUploadPathEx & DestPath
	End If
	ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
End Function

' Function to change the file name of the uploaded file
Function ewUploadFileNameEx(Folder, FileName)
	Dim OutFileName
	
	' By default, ewUniqueFileName() is used to get an unique file name.
	' Amend your logic here
	OutFileName = ewUniqueFileName(Folder, FileName)

	' Return computed output file name
	ewUploadFileNameEx = OutFileName
End Function

' Function to return path of the uploaded file
' returns global upload folder, for backward compatibility only
Function ewUploadPath(PhyPath)
	ewUploadPath = ewUploadPathEx(PhyPath, EW_UploadDestPath)
End Function

' Function to change the file name of the uploaded file
' use global upload folder, for backward compatibility only
Function ewUploadFileName(FileName)
	ewUploadFileName = ewUploadFileNameEx(ewUploadPath(True), FileName)
End Function

' Function to generate an unique file name (filename(n).ext)
Function ewUniqueFileName(Folder, FileName)
	If FileName = "" Then FileName = ewDefaultFileName()

	If FileName = "." Then
		Response.Write "Invalid file name: " & FileName
		Response.End
		Exit Function
	End If
	
	If Folder = "" Then
		Response.Write "Unspecified folder"
		Response.End
		Exit Function
	End If
	
	Dim Name, Ext, Pos
	Name = ""
	Ext = ""
	Pos = InStrRev(FileName, ".")
	If Pos = 0 Then
		Name = FileName
		Ext = ""
	Else
		Name = Mid(FileName, 1, Pos-1)
		Ext = Mid(FileName, Pos+1)
	End If
	
	Folder = ewIncludeTrailingDelimiter(Folder, True)
	
	Dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	
	If Not fso.FolderExists(Folder) Then
		If Not ewCreateFolder(Folder) Then
			Response.Write "Folder does not exist: " & Folder
			Set fso = Nothing
			Exit Function
		End If
	End If
	
	Dim Suffix, Index
	Index = 0
	Suffix = ""
	
	' Check to see if filename exists
	While fso.FileExists(folder & Name & Suffix & "." & Ext)
		Index = Index + 1
		Suffix = "(" & Index & ")"
	Wend
	Set fso = Nothing

	' Return unique file name
	ewUniqueFileName = Name & Suffix & "." & Ext
	
End Function

' Function to create a default file name (yyyymmddhhmmss.bin)
Function ewDefaultFileName
	Dim DT
	DT = Now()
	ewDefaultFileName = ewZeroPad(Year(DT), 4) & ewZeroPad(Month(DT), 2) &  _
		ewZeroPad(Day(DT), 2) & ewZeroPad(Hour(DT), 2) & _
		ewZeroPad(Minute(DT), 2) & ewZeroPad(Second(DT), 2) & ".bin"
End Function

' Function to check the file type of the uploaded file
Function ewUploadAllowedFileExt(FileName)
	If Trim(FileName & "") = "" Then
		ewUploadAllowedFileExt = True
		Exit Function
	End If
	Dim Ext, Pos, arExt, FileExt
	arExt = Split(EW_UploadAllowedFileExt & "", ",")
	Ext = ""
	Pos = InStrRev(FileName, ".")
	If Pos > 0 Then	Ext = Mid(FileName, Pos+1)
	ewUploadAllowedFileExt = False
	For Each FileExt in arExt
	  If LCase(Trim(FileExt)) = LCase(Ext) Then
	    ewUploadAllowedFileExt = True
	    Exit For
	  End If
	Next
End Function

' Function to include the last delimiter for a path
Function ewIncludeTrailingDelimiter(Path, PhyPath)
	If PhyPath Then
		If Right(Path, 1) <> "\" Then Path = Path & "\"
	Else
		If Right(Path, 1) <> "/" Then Path = Path & "/"
	End If
	ewIncludeTrailingDelimiter = Path
End Function

' Function to write the paths for config/debug only
Sub ewWriteUploadPaths
	Response.Write "Request.ServerVariables(""APPL_PHYSICAL_PATH"")=" & _
		Request.ServerVariables("APPL_PHYSICAL_PATH") & "<br>"
	Response.Write "Request.ServerVariables(""APPL_MD_PATH"")=" & _
		Request.ServerVariables("APPL_MD_PATH") & "<br>"
End Sub 

'===============================================================================
' Other functions for file upload (Do not modify)

Function stringToByte(toConv)
	Dim i, tempChar
	For i = 1 to Len(toConv)
		tempChar = Mid(toConv, i, 1)
		stringToByte = stringToByte & ChrB(AscB(tempChar))
	Next
End Function

Private Function ByteToString(ToConv)
	On Error Resume Next
 	For I = 1 to LenB(ToConv)
 	  ByteToString = ByteToString & Chr(AscB(MidB(ToConv,i,1)))
 	Next
End Function

Function ConvertToBinary(RawData)
	Dim oRs
	Set oRs = Server.CreateObject("ADODB.Recordset")
	' Create field in an empty RecordSet
	Call oRs.Fields.Append("Blob", 205, LenB(RawData)) ' Add field with type adLongVarBinary
	Call oRs.Open()
	Call oRs.AddNew()
	Call oRs.Fields("Blob").AppendChunk(RawData & ChrB(0))
	Call oRs.Update()
	' Save Blob Data
	ConvertToBinary = oRs.Fields("Blob").GetChunk(LenB(RawData))
	' Close RecordSet
	Call oRs.Close()
	Set oRs = Nothing
End Function

Function ConvertToUnicode(RawData)
	Dim oRs		
	Set oRs = Server.CreateObject("ADODB.Recordset")
	' Create field in an empty recordset
	Call oRs.Fields.Append("Text", 201, LenB(RawData)) ' Add field with type adLongVarChar
	Call oRs.Open()
	Call oRs.AddNew()
	Call oRs.Fields("Text").AppendChunk(RawData & ChrB(0))
	Call oRs.Update()
	' Save Unicode Data
	ConvertToUnicode = oRs.Fields("Text").Value
	' Close recordset
	Call oRs.Close()
	Set oRs = Nothing
End Function

Function ConvertToText(objStream, iStart, iLength, binData)
	On Error Resume Next
	If EW_UploadCharset <> "" Then
		Dim tmpStream
		Set tmpStream = Server.CreateObject("ADODB.Stream")
		tmpStream.Type = 1 'adTypeBinary
		tmpStream.Mode = 3 'adModeReadWrite
		tmpStream.Open
		objStream.Position = iStart
		objStream.CopyTo tmpStream, iLength
		tmpStream.Position = 0
		tmpStream.Type = 2 'adTypeText
		tmpStream.Charset = EW_UploadCharset
		ConvertToText = tmpStream.ReadText
		tmpStream.Close
		Set tmpStream = Nothing
	Else
		ConvertToText = ByteToString(binData)
	End If
	ConvertToText = Trim(ConvertToText & "")
End Function

Function getValue(dict, name)
	Dim gv
	If dict.Exists(name) Then
		gv = CStr(dict(name).Item("Value"))
		gv = Left(gv, Len(gv)-2)
		getValue = gv
	Else
		getValue = ""
	End If
End Function

Function getFileData(dict, name)
	If dict.Exists(name) Then
		getFileData = dict(name).Item("Value")
		If LenB(getFileData) Mod 2 = 1 Then
			getFileData = getFileData & ChrB(0)
		End If
	Else
		getFileData = ""
	End If
End Function

Function getFileName(dict, name)
	Dim temp, tempPos
	If dict.Exists(name) Then
		temp = dict(name).Item("FileName")
		tempPos = 1 + InStrRev(temp, "\")
		getFileName = Mid(temp, tempPos)
	Else
		getFileName = ""
	End If
End Function

Function getFileSize(dict, name)
	If dict.Exists(name) Then
		getFileSize = LenB(dict(name).Item("Value"))
	Else
		getFileSize = 0
	End If
End Function

Function getFileContentType(dict, name)
	If dict.Exists(name) Then
		getFileContentType = dict(name).Item("ContentType")
	Else
		getFileContentType = ""
	End If
End Function

Function ewFolderExists(Folder)
	Dim fso
	Set fso = CreateObject("Scripting.FileSystemObject")
	ewFolderExists = fso.FolderExists(Folder)
	Set fso = Nothing
End Function

Sub ewDeleteFile(FilePath)
	On Error Resume Next
	Dim fso
	Set fso = CreateObject("Scripting.FileSystemObject")
	If FilePath <> "" And fso.FileExists(FilePath) Then
		fso.DeleteFile(FilePath)
	End If
	Set fso = Nothing
End Sub

Sub ewRenameFile(OldFilePath, NewFilePath)
	On Error Resume Next
	Dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If OldFilePath <> "" And fso.FileExists(OldFilePath) Then
		fso.MoveFile OldFilePath, NewFilePath
	End If
	Set fso = Nothing
End Sub

Function ewCreateFolder(Folder)
	On Error Resume Next
	ewCreateFolder = False
	Dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If Not fso.FolderExists(Folder) Then
		If ewCreateFolder(fso.GetParentFolderName(Folder)) Then
			fso.CreateFolder(Folder)
			If Err.Number = 0 Then ewCreateFolder = True
		End If
	Else
		ewCreateFolder = True
	End If
	Set fso = Nothing
End Function

Function ewSaveFile(Folder, FileName, FileData)
	On Error Resume Next
	ewSaveFile = False
	If ewCreateFolder(Folder) Then
		Set oStream = Server.CreateObject("ADODB.Stream")
		oStream.Type = 1 ' 1=adTypeBinary
		oStream.Open
		oStream.Write ConvertToBinary(FileData)
		oStream.SaveToFile Folder & FileName, 2 ' 2=adSaveCreateOverwrite
		oStream.Close
		Set oStream = Nothing
		If Err.Number = 0 Then ewSaveFile = True
	End If
End Function

Function ewConvertLength(b)
	ewConvertLength = CLng(AscB(LeftB(b, 1)) + (AscB(RightB(b, 1)) * 256))
End Function
Function ewConvertLength2(b)
	ewConvertLength2 = CLng(AscB(RightB(b, 1)) + (AscB(LeftB(b, 1)) * 256))
End Function

' Get image dimension
Sub ewGetImageDimension(img, wd, ht)
	Dim sPNGHeader, sGIFHeader, sBMPHeader, sJPGHeader, sHeader, sImgType
	sImgType = "(unknown)"
	' image headers, do not changed
	sPNGHeader = ChrB(137) & ChrB(80) & ChrB(78)
	sGIFHeader = ChrB(71) & ChrB(73) & ChrB(70)
	sBMPHeader = ChrB(66) & ChrB(77)
	sJPGHeader = ChrB(255) & ChrB(216) & ChrB(255)
	sHeader = MidB(img, 1, 3)
	' Handle GIF
	If sHeader = sGIFHeader Then
		sImgType = "GIF"
		wd = ewConvertLength(MidB(img, 7, 2))
		ht = ewConvertLength(MidB(img, 9, 2))
	' Handle BMP
	ElseIf LeftB(sHeader, 2) = sBMPHeader Then
		sImgType = "BMP"
		wd = ewConvertLength(MidB(img, 19, 2))
		ht = ewConvertLength(MidB(img, 23, 2))
	' Handle PNG
	ElseIf sHeader = sPNGHeader Then
		sImgType = "PNG"
		wd = ewConvertLength2(MidB(img, 19, 2))
		ht = ewConvertLength2(MidB(img, 23, 2))
	' Handle JPG
	Else
		Dim size, markersize, pos, bEndLoop
		size = LenB(img)
		pos = InStrB(img, sJPGHeader)
		If pos <= 0 Then
			wd = -1
			ht = -1
			Exit Sub
		End If
		sImgType = "JPG"
		pos = pos + 2
		bEndLoop = False
		Do While Not bEndLoop and pos < size
			Do While AscB(MidB(img, pos, 1)) = 255 and pos < size
				pos = pos + 1
			Loop
			If AscB(MidB(img, pos, 1)) < 192 or AscB(MidB(img, pos, 1)) > 195 Then
				markersize = ewConvertLength2(MidB(img, pos+1, 2))
				pos = pos + markersize + 1
			Else
				bEndLoop = True
			End If
		Loop
		If Not bEndLoop Then
			wd = -1
			ht = -1
		Else
			wd = ewConvertLength2(MidB(img, pos+6, 2))
			ht = ewConvertLength2(MidB(img, pos+4, 2))
		End If
	End If
End Sub
%>
<!--##/session##-->