htmlarea_function.asp

以前做的一个j2ee的项目

<%

REM 用户每人一个文件夹
EmployeeBaseRoot="../../file_picture_uploads/"& Session(DEF_MasterCookies &"UserId")

REM 如果文件夹不存在则创建一个
Set fs = CreateObject("Scripting.FileSystemObject")
if Not fs.FolderExists(server.mappath(EmployeeBaseRoot)) then
	fs.CreateFolder(server.mappath(EmployeeBaseRoot))
end if
Set fs=nothing


REM 根据Path路径字串列出文件夹
Sub DirTag(Path)

	dim strUrlPath,strPath,arrPaths
	dim i,j,l
	
	strPath=Path
	strUrlPath=""
	
	if strPath<>"" then
	
		arrPaths=split(strPath,"/")
		l=ubound(arrPaths)
		
		Indent=l+1
		
		for i=0 to l '列出所有文件夹
			
			if strUrlPath="" then
				strUrlPath=arrPaths(i)
			else
				strUrlPath=strUrlPath &"/"& arrPaths(i)
			end if
		
			response.write("<tr><td>")
			for j=0 to i '按照文件夹所在的层次进行缩进
				response.write("<img src=""indent.gif"">")
			next
			
			if i=l then
				response.write("<img src=""opened.gif"" align=""bottom"" border=""0"">")
				response.write("<font color=red><b>")
				response.write arrPaths(i)
				response.write("</b></font>")
			else
				response.write("<a href=""lister.asp?Path=")
				response.write(server.urlencode(strUrlPath) &""">")
				response.write("<img src=""opened.gif"" align=""bottom"" border=""0"">")
				response.write arrPaths(i)
				response.write("</a>")
				response.write("</td><td>&nbsp;</td></tr>")
			end if
			
		next
		
	end if

end Sub

REM 删除指定文件夹
Sub DeletePath(PathName)

	Set fso = CreateObject("Scripting.FileSystemObject")
	if fso.FolderExists(PathName) then
		fso.DeleteFolder(PathName)
	else
		strErrorMsg="文件夹不存在！！"
		call ShowMsgWindow("出错了",strErrorMsg,5000)
		response.write("<Script language=""JavaScript"">"& VbCrLf)
		response.write("window.location.href=window.location.href;"& VbCrLf)
		response.write("</script>"& VbCrLf)
	end if
	
	Set fso=nothing

End Sub

REM 删除指定文件
Sub DeleteFile(PathName)

	Set fso = CreateObject("Scripting.FileSystemObject")
	if fso.FileExists(PathName) then
		fso.DeleteFile(PathName)
	else
		strErrorMsg="文件不存在！！"
		call ShowMsgWindow("出错了",strErrorMsg,5000)
		response.write("<Script language=""JavaScript"">"& VbCrLf)
		response.write("window.location.href=window.location.href;"& VbCrLf)
		response.write("</script>"& VbCrLf)
	end if

	Set fso=nothing

End Sub

REM 创建文件夹
Sub CreateFolder(PathName)
	
	Set fso = CreateObject("Scripting.FileSystemObject")
	if not fso.FolderExists(PathName) then
		fso.CreateFolder(PathName)
	else
		strErrorMsg="文件夹已存在！！"
		call ShowMsgWindow("出错了",strErrorMsg,5000)
		response.write("<Script language=""JavaScript"">"& VbCrLf)
		response.write("window.location.href=window.location.href;"& VbCrLf)
		response.write("</script>"& VbCrLf)
	end if
	Set fso=nothing

End Sub

REM 上传文件
Sub UploadFile(PathName,RenameFile)

	dim blnErrorFlag
	
	blnErrorFlag=false
	
	for each formName in upload.objFile ''列出所有上传了的文件
		
		set file=upload.file(formName)  ''生成一个文件对象
		
		if not CheckUploadFileType(file.FileType) then
			blnErrorFlag=true
			strErrorMsg="只能上传JPG、GIF或PNG格式的图片！！"
			call ShowMsgWindow("无法上传",strErrorMsg,5000)
		end if

		if file.FileSize>DEF_MaxPicturesize and not blnErrorFlag then         ''不能上传超过某大小的图片
			blnErrorFlag=true
			strErrorMsg="图片大小超出"& DEF_MaxPicturesize &"字节限制！！"
			call ShowMsgWindow("无法上传",strErrorMsg,5000)
		end if
		
		if not blnErrorFlag then
				
			if RenameFile="" then
				strSaveFile=PathName & file.filename
			else
			
				if (not instr("."& ExtractFileExt(RenameFile),".gif")) and (not instr("."& ExtractFileExt(RenameFile),".jpg")) and (not instr("."& ExtractFileExt(RenameFile),".png")) then
					RenameFile=FixUploadFileName(file.filetype,RenameFile)
					strErrorMsg="您上传的文件自动命名为："& RenameFile &"！"
					call ShowMsgWindow("提示",strErrorMsg,5000)
				end if
				
				strSaveFile=PathName & RenameFile
				
			end if
			
			Set fso = CreateObject("Scripting.FileSystemObject")
			if not fso.FileExists(strSaveFile) then
				file.SaveAs(strSaveFile)
			else
				strErrorMsg="文件已存在！！"
				call ShowMsgWindow("出错了",strErrorMsg,5000)
				response.write("<Script language=""JavaScript"">"& VbCrLf)
				response.write("window.location.href=window.location.href;"& VbCrLf)
				response.write("</script>"& VbCrLf)
			end if
			Set fso=nothing
		end if
			
		set file=nothing
			
	next


end Sub

REM 检查文件类型是否有效
function CheckUploadFileType(FileType)

	dim arrFileTypes,arrExtentions,i,ret
	arrFileTypes=array("image/gif","image/jpg","image/jpeg","image/pjpeg","image/png","image/x-png")
	arrExtentions=array(".gif",".jpg",".jpg",".jpg",".png",".png")
	
	ret=false
	for i=0 to ubound(arrFileTypes)
		if arrFileTypes(i)=lcase(FileType) then
			ret=true
			i=ubound(arrFileTypes)+1
		end if
	next
	
	CheckUploadFileType=ret
	
end function

REM 将不合文件名规格的文件自动命名
function FixUploadFileName(FileType,FileName)
	dim arrFileTypes,arrExtentions,i,j,ret
	arrFileTypes=array("image/gif","image/jpg","image/jpeg","image/pjpeg","image/png","image/x-png")
	arrExtentions=array(".gif",".jpg",".jpg",".jpg",".png",".png")
	
	j=-1
	ret=""
	
	for i=0 to ubound(arrFileTypes)
		if arrFileTypes(i)=lcase(FileType) then
			j=i
			i=ubound(arrFileTypes)+1
		end if
	next
	
	if j<>-1 then 
		ret=FileName & arrExtentions(j)
	end if
	
	FixUploadFileName=ret
	
end function

%>