char.asp

方舟网免费空间申请程序(自助建站系统) v3.0 1 界面美观 2 后台管理功能强大：A 可以设置多种参数

<%
'------ 过滤HTML代码
Function HTMLEncode(fString)
if not isnull(fString) then
    fString = replace(fString, ">", "&gt;")
    fString = replace(fString, "<", "&lt;")

    fString = Replace(fString, CHR(32), "&nbsp;")
    fString = Replace(fString, CHR(9), "&nbsp;")
    fString = Replace(fString, CHR(34), "&quot;")
    fString = Replace(fString, CHR(39), "&#39;")
    fString = Replace(fString, CHR(13), "")
    fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
    fString = Replace(fString, CHR(10), "<BR> ")
    HTMLEncode = fString
end if
End Function

'----- 过滤表单字符
Function HTMLcode(fString)
if not isnull(fString) then
    fString = Replace(fString, CHR(13), "")
    fString = Replace(fString, CHR(10) & CHR(10), "</P><P>")
    fString = Replace(fString, CHR(10), "<BR>")
    HTMLcode = fString
end if
End Function

'----- 判断发言是否来自外部
Function ChkPost()
	dim server_v1,server_v2
	chkpost=false
	server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
	server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
	if mid(server_v1,8,len(server_v2))<>server_v2 then
		chkpost=false
	else
		chkpost=true
	end if
End Function

'------ 过滤SQL非法字符
Function checkStr(str)
	if isnull(str) then
		checkStr = ""
		exit Function 
	end if
	checkStr=replace(str,"'","''")
End Function
'======================

'--------邮件检查
Function chkemail(strEmailAddr)
    chkemail=False
    Dim RE
    Set RE = new RegExp
    RE.pattern = "^[a-zA-Z][A-Za-z0-9_.-]+@[a-zA-Z0-9_]+?\.[a-zA-Z]{2,3}$"
    chkemail=RE.Test(strEmailAddr)
    Set RE=Nothing
End Function
'---------取扩展名
Function ExtNameS(extss)
	dim StarLocal
		StarLocal=inStrRev(extss,".")
		ExtNameS=mid(extss,StarLocal+1,len(extss)-StarLocal)
End Function

'--------格式文件尺寸显示
Function ByteNum(num) 			
	if Num<1024 then
		ByteNum="1 KB"
	else
		ByteNum=formatNumber(int(Num/1024),0)&" KB"
	end if	
	'	ByteNum=Num&" Byte"
	'elseif Num<1048576 then  
	'	ByteNum=formatNumber(int(Num/1024),0)&" KB"
	'elseif Num<1073374812 then
	'	ByteNum=formatNumber(int(Num/1048576),0)&" MB"
	'elseif Num<1073374812 then
	'else
	'	ByteNum=formatNumber(int(Num/1073374812),0)&" GB"
	'end if
End function 

'========文件目录管理函数=====

Function previewSwith()
	if Preview=0 then 
		CONN.execute "update [userlist] set preview=1 where UserID="&memberid
		Preview=1
	else
		CONN.execute "update [userlist] set preview=0 where UserID="&memberid
		Preview=0
	end if
End Function

Function DelAllSelect()
	dim newSize
	newSize=0
	dim sStr,maxdir,maxfile,i,delselInfo,infos,infos1,infos2,infos3
	maxdir=cint(Request.Form("maxdir"))
	maxfile=cint(Request.Form("maxfile"))
	infos=""
	infos1=""
	infos2=""
	infos3=""
	if SetPower(1,4) then 
		for i=1 to maxdir
			if Request.Form("chidd"&i)<>"" then
				sStr=Request.Form("chidd"&i)
				delselInfo=CheckFolder(GetPath&sStr,1)
					if delselInfo="True" then 
						newSize=newSize+Fso.GetFolder(Server.mappath(GetPath&sStr)).size
						Fso.DeleteFolder Server.MapPath(GetPath&sStr),true
					else
						infos=infos&GetPath&sStr&"<br>"
						infos1=infos1&delselInfo&"<br>"
					end if
			end if
		next
	else
		for i=1 to maxdir
			if Request.Form("chidd"&i)<>"" then
				sStr=Request.Form("chidd"&i)
				infos=infos&GetPath&sStr&"<br>"
			end if
		next
	end if
		if infos<>"" then infos="<br><li>没有权限删除所选目录:<br>"&infos
		if infos1<>"" then infos1="<br><li>删除所选目录出错如下:<br>"&infos1
		sStr=GetAction&"|"&GetPath
	if SetPower(1,3) then 
		for i=1 to maxfile
			if Request.Form("chidf"&i)<>"" then
				sStr=Request.Form("chidf"&i)
				delselInfo=CheckFile(GetPath&sStr,1,"04")
				if delselInfo="True" then 
					newSize=newSize+Fso.GetFile(Server.mappath(GetPath&sStr)).size
					Fso.DeleteFile Server.MapPath(GetPath&sStr),true
				else
					infos2=infos2&GetPath&sStr&"<br>"
					infos3=infos3&delselInfo&"<br>"
				end if
			end if
		next
	else
		for i=1 to maxfile
			if Request.Form("chidf"&i)<>"" then
				sStr=Request.Form("chidf"&i)
				infos2=infos2&GetPath&sStr&"<br>"
			end if			
		next
	end if
		if infos2<>"" then infos2="<br><li>没有权限删除下列文件:<br>"&infos2
		if infos3<>"" then infos3="<br><li>所选文件操作出错如下:<br>"&infos3
		infos=infos+infos1+infos2+infos3
		if infos<>"" then EndProc infos,1,""
		Session("Folderbuffer")=""
		Session("Filebuffer")=""
	Call UpdateUseSize(useSize-newSize)
end Function

Function DelFileS()
	dim newSize
	if SetPower(1,3)=false then EndProc "<br><li>无文件操作权限,删除失败！",1,""
	dim sFile,action
		sFile=GetValue(request.QueryString("file"),"str","")
	if sFile="" then EndProc "<br><li>文件不存在",1,""
		action=CheckFile(GetPath&sFile,1,"04")
	if action<>"True" then EndProc action,1,""
		newSize=Fso.GetFile(Server.mappath(GetPath&sFile)).size
		Fso.DeleteFile Server.mappath(GetPath&sFile)
		Call UpdateUseSize(useSize-newSize)
end Function

Function DelFolderS()
	dim newSize
	if SetPower(1,4)=false then EndProc "<br><li>无目录操作权限,删除失败！",1,""
	dim sFile,action
		sFile=GetValue(request.QueryString("file"),"str","")
	if sFile="" then EndProc "<br><li>目录不存在",1,""
		action=CheckFolder(GetPath&sFile,1)
	if action<>"True" then EndProc action,1,""
		newSize=Fso.GetFolder(Server.mappath(GetPath&sFile)).size
		Fso.DeleteFolder Server.mappath(GetPath&sFile)
		Call UpdateUseSize(useSize-newSize)
End Function

Function RenameFile()
	dim sFrom,sTo,sStr,sObj
		sFrom=GetValue(request.QueryString("from"),"str","") 
		sTo=GetValue(request.QueryString("to"),"str","")
	if sFrom="" or sTo="" then 
		exit Function
	else
		if sTo=sFrom then exit Function
		if SetPower(1,3)=false then EndProc "<br><li>无更改文件名权限,更名失败！",1,""
	end if
		sStr=CheckFile(GetPath&sFrom,1,"04")
	if sStr<>"True" then  EndProc sStr,1,""
		sStr=CheckFile(sTo,0,"04")
	if sStr<>"True" then  EndProc sStr,1,""
	if Fso.FileExists(Server.MapPath(GetPath&sTo)) then EndProc "<br><li>目标文件已存在!",1,""
		set sObj=Fso.GetFile(Server.MapPath(GetPath&sFrom))
		sObj.Move Server.MapPath(GetPath&sTo)
	set sObj=nothing
End Function

Function RenameFolder()
	if SetPower(1,4)=false then EndProc "<br><li>无目录操作权限,更名失败！",1,""
	dim sFrom,sTo,sStr,sObj
		sFrom=GetValue(request.QueryString("from"),"str","") 
		sTo=GetValue(request.QueryString("to"),"str","")
	if sFrom="" or sTo="" then exit Function
		sStr=CheckFolder(GetPath&sFrom,1)
	if sStr<>"True" then  EndProc sStr,1,""
		sStr=CheckFolder(GetPath&sTo,0)
	if sStr<>"True" then  EndProc sStr,1,""
	if Fso.FolderExists(Server.MapPath(GetPath&sTo)) then EndProc "<br><li>目标目录已存在!",1,""
		Fso.MoveFolder Server.MapPath(GetPath&sFrom),Server.MapPath(GetPath&sTo)
	set sObj=nothing
End Function

Function MakeFolder()
	if SetPower(1,4)=false then EndProc "<br><li>无目录操作权限,创建目录失败！",1,""
	dim sTo,sStr
		sTo=GetValue(request.QueryString("to"),"str","")
		sStr=left(sStr,inStrRev(sStr,"/"))
		sStr=CheckFolder(GetPath,1)
	if sStr<>"True" then EndProc sStr,1,""
		sStr=CheckFolder(GetPath&sTo,0)
	if sStr<>"True" then EndProc sStr,1,""
	if Fso.FolderExists(Server.mappath(GetPath&sTo)) then EndProc "<br><li>目录已经存在!",1,""
		Fso.CreateFolder(Server.mappath(GetPath&sTo))
End Function

Function Makefile()
	if SetPower(1,3)=false then EndProc "<br><li>没文件操作权限,创建文本文件失败！",1,""
	Dim sTo,sStr
	Dim MyFile
	sTo=GetValue(request.QueryString("to"),"str","")
	sStr=CheckFile(sTo,0,"04")
	if sStr<>"True" then EndProc sStr,1,""
	if Fso.FileExists(Server.mappath(GetPath&sTo)) then EndProc "<br><li>文件已经存在!",1,""
	Set MyFile = Fso.CreateTextFile(Server.mappath(GetPath&sTo), True)
	MyFile.WriteLine("Create by "&membername&" / "&formatDateTime(now(),1)&" / "&formatDateTime(now(),4))
	MyFile.Close
End Function

Function Do_Copy_Cut()
	if Not SetPower(1,4) and Not SetPower(1,3) then EndProc "<br><li>没文件及目录操作权限执行失败！",1,""
	dim sStr,maxdir,maxfile,i
		sStr=GetAction&"|"&GetPath
		maxdir=cint(Request.Form("maxdir"))
		maxfile=cint(Request.Form("maxfile"))
	for i=1 to maxdir
		if Request.Form("chidd"&i)<>"" then sStr=sStr&"|"&Request.Form("chidd"&i)
	next
		Session("Folderbuffer")=sStr
		sStr=GetAction&"|"&GetPath
	for i=1 to maxfile
		if Request.Form("chidf"&i)<>"" then sStr=sStr&"|"&Request.Form("chidf"&i)
	next
		Session("Filebuffer")=sStr
End Function

Function DoPaste()
	dim newSize
		newSize=0
	dim sStr,sStr1,i,pasteInfo,sArr,chk,sStr2
	dim sTrErr
	dim ubS
	dim fgitbl
	dim errinfo
	dim nameExists
	dim dontDel
	nameExists=false
	if Session("Folderbuffer")="" and Session("Filebuffer")="" then exit Function
		sTrErr=""
		sArr=split(Session("Folderbuffer"),"|")
		ubS=ubound(sArr)
	sStr2=""

	if SetPower(1,4) then
		if sArr(1)=GetPath then  EndProc "<br><li>不能自己覆盖自己!",1,""
		for i=2 to ubS
			sStr=sArr(1)&sArr(i)
			sStr1=GetPath&sArr(i)
			dontDel=false
			'if Fso.FolderExists(Server.MapPath(sStr1)) then EndProc "<br><li>目录:"&sStr1&" 已经存在!",1,""
			if CheckFolder(sStr,1)="True" then
				if Fso.FileExists(Server.mappath(sStr1)) then '--folder1
					errinfo=errinfo&"<li> 存在非目录的文件名 "&sStr1
					nameExists=true
				else '--folder1
					nameExists=false
					if sArr(0)="Cut" then
						if Fso.folderexists(Server.mappath(sStr1)) then
							if request.querystring("fgit")="1" then '覆盖操作
								fgitbl=true
								newSize=newSize+(Fso.GetFolder(Server.mappath(sStr)).size-Fso.GetFolder(Server.mappath(sStr1)).size)
							else 
								fgitbl=false
								dontDel=true '不执行操作
								errinfo=errinfo&"<li> "&sStr&"没有移动,因为存在同名目录而覆盖没有选取" 
							end if
						else
							fgitbl=false
						end if
						
						if fgitbl then
							Fso.CopyFolder Server.MapPath(sStr),Server.MapPath(sStr1),true
							Fso.DeleteFolder Server.mappath(sStr)
						else
							if not dontDel then  Fso.MoveFolder Server.MapPath(sStr),Server.MapPath(sStr1)
						end if
					else
						if Fso.folderexists(Server.mappath(sStr1)) then
							if request.querystring("fgit")="1" then '覆盖操作则如此
								fgitbl=true
								newSize=newSize+(Fso.GetFolder(Server.mappath(sStr)).size-Fso.GetFolder(Server.mappath(sStr1)).size)
							else
								fgitbl=false
								dontDel=true '不执行操作
								errinfo=errinfo&"<li> "&sStr&"没有复制,因为存在同名目录而覆盖没有选取" 
							end if
						else
							fgitbl=true
							newSize=newSize+Fso.GetFolder(Server.mappath(sStr)).size
						end if
						if fgitbl then 
							if not dontDel then Fso.CopyFolder Server.MapPath(sStr),Server.MapPath(sStr1),true
						end if
					end if
				end if '--folder1
			else
				sStr2=sStr2&sStr&"目录操作不被允许<br>"
			end if
		next
		Session("Folderbuffer")=""
	else
		if ubs>1 then
			sTrErr= "<br><li>没目录操作权限,目录粘贴失败："
			for i=2 to ubS
				sTrErr=sTrErr+"<br>"+GetPath&sArr(i)
			next
		end if
		Session("Folderbuffer")=""
	end if
		sArr=split(Session("Filebuffer"),"|")
		ubS=ubound(sArr)
	if SetPower(1,3) then
		for i=2 to ubS
			sStr=sArr(1)&sArr(i)
			sStr1=GetPath&sArr(i)
			chk=CheckFile(sStr,1,"04")
			dontDel=false
			if chk="True" then
				if Fso.FolderExists(Server.mappath(sStr1)) then '--file2
					errinfo=errinfo&"<li> 存在非文件的目录名 "&sStr1
					nameExists=true
				else '--file2
					nameExists=false
					if sArr(0)="Cut" then
							'if Fso.FileExists(Server.MapPath(sStr1)) then EndProc "<br><li>文件 "&sStr1&" 已经存在!",1,""
							if Fso.FileExists(Server.mappath(sStr1)) then
								if request.querystring("fgit")="1" then
									fgitbl=true
									newSize=newSize+(Fso.GetFile(Server.mappath(sStr)).size-Fso.GetFile(Server.mappath(sStr1)).size)
								else
									fgitbl=false
									dontDel=true '不执行操作
									errinfo=errinfo&"<li> "&sStr&"没有移动,因为存在同名文件而覆盖没有选取" 
								end if
							else
								fgitbl=false
							end if
							if fgitbl then '覆盖为先写入再删除
								Fso.CopyFile Server.MapPath(sStr),Server.MapPath(sStr1),true
								Fso.DeleteFile Server.mappath(sStr)
							else
								if not dontDel then 
									Fso.MoveFile Server.MapPath(sStr),Server.MapPath(sStr1)
								end if	
							end if
					else
							if Fso.FileExists(Server.mappath(sStr1)) then
								if request.querystring("fgit")="1" then
									fgitbl=true
									newSize=newSize+(Fso.GetFile(Server.mappath(sStr)).size-Fso.GetFile(Server.mappath(sStr1)).size)
								else
									fgitbl=false
									dontDel=true '不执行操作
									errinfo=errinfo&"<li> "&sStr&"没有复制,因为存在同名文件而覆盖没有选取" 
								end if
							else
								newSize=newSize+Fso.GetFile(Server.mappath(sStr)).size
								fgitbl=false
							end if
								if not dontDel then 
									Fso.CopyFile Server.MapPath(sStr),Server.MapPath(sStr1),true
								end if
					end if
				end if '--file2
			else
				sStr2=sStr2&sStr1&"<br>"
			end if
		next
		Session("Filebuffer")=""
	else
		if ubs>1 then
			sTrErr=sTrErr+"<br><li>没文件操作权限,文件粘贴失败："
			for i=2 to ubS
				sTrErr=sTrErr+"<br>"+GetPath&sArr(i)
			next
		end if
		Session("Filebuffer")=""
	end if
	if sStr2<>"" then 
		call EndProc(sTrErr+"<br><li>粘贴失败的脚本文件：<br>"&sStr2,1,"")
	else
		if sTrErr<>"" then call EndProc(sTrErr,1,"")
	end if
	Call UpdateUseSize(useSize+newSize)
	if errinfo<>"" then
		call EndProc(sTrErr+"<br><li>同名错误:<br>"&errinfo,1,"")
	end if
End Function

function  CastNum(numStr,ctype,defvalue)  
		'数字转换函数,
		'参数ctype 0浮点,1,长整,2四舍五入,3 取整
		'defvalue 是获得缺省值
		dim lnum:lnum=numStr
		dim lN:lN=ctype
		dim lM:lM=defvalue
		if isEmpty(lnum) or trim(lnum)="" then
			CastNum=defvalue
			exit function
		end if
		if isNumeric(lnum) then
			select case lN
			case 0 CastNum=Csng(lnum)
			case 1 CastNum=Clng(lnum)
			case 2 CastNum=round(lnum)
			case 3 CastNum=int(lnum)
			case 4 CastNum=cint(lnum)
			case else response.write "无效的转换参数"	
			end select
		else
			CastNum=lM
		end if
end function
%>