数据库编程

开发平台：
ASP/ASPX

Function.asp：源码内容
							<%
	'脚本超时
	Server.ScriptTimeout=600
	Session.Timeout = 50
	Function Add_Root_Dir(f_Path)
		Dim f_All_Path
		If Left(f_Path,1)="/" Then
			f_All_Path = G_VIRTUAL_ROOT_DIR & f_Path
		Else
			f_All_Path = G_VIRTUAL_ROOT_DIR & "/" & f_Path
		End If
		If Trim(G_VIRTUAL_ROOT_DIR) <> "" Then
			f_All_Path = "/" & f_All_Path
		End If
		Add_Root_Dir = f_All_Path
	End Function
	Function Lose_Html(f_Str)
		Dim regEx
		if Not IsNull(f_Str) Then
			f_Str=f_Str&""
			Set regEx = New RegExp
			regEx.Pattern = "</*[^<>]*>"
			regEx.IgnoreCase = True
			regEx.Global = True
			f_Str = regEx.Replace(f_Str,"")
			Lose_Html = f_Str
		Else
			Lose_Html=""
		End If
	End Function
	Function Intercept_Char(f_Str,f_Length,f_Flag)
		'f_Flag为1，一个中文字符的长度算1；f_Flag为2，一个中文字符的长度算2
		Dim f_Str_Total_Len,f_i,f_Str_Curr_Len,f_One_Char
		If f_Length = 0  Or f_Str = "" Or IsNull(f_Str) Then
			Intercept_Char = ""
			Exit Function
		End If
		f_Str=Replace(Replace(Replace(Replace(f_Str,"&nbsp;"," "),"&quot;",Chr(34)),"&gt;",">"),"&lt;","<")
		f_Str_Total_Len = Len(f_Str)
		If f_Flag = 1 Then
			If f_Length>=f_Str_Total_Len Then
				Intercept_Char = f_Str
			Else
				Intercept_Char = Left(f_Str,f_Length)
			End If
		Else
			For f_i = 1 To f_Str_Total_Len
				f_One_Char = Mid(f_Str,f_i,1)
				If Abs(Asc(f_One_Char)) > 255 then
					f_Str_Curr_Len=f_Str_Curr_Len+2
				Else
					f_Str_Curr_Len=f_Str_Curr_Len+1
				End If
				If f_Str_Curr_Len >= f_Length Then
					Intercept_Char = Left(f_Str,f_i)
					Exit For
				End If
			Next
			If f_Str_Curr_Len < f_Length Then
				Intercept_Char = f_Str
			End If
		End If
		Intercept_Char = Replace(Replace(Replace(Replace(Intercept_Char," ","&nbsp;"),Chr(34),"&quot;"),">","&gt;"),"<","&lt;")
	End Function
	Function Mod_IS_Installed_Bool(f_Mod_Str)
		On Error Resume Next
		Mod_IS_Installed_Bool = False
		Err = 0
		Dim f_TestObj
		Set f_TestObj = Server.CreateObject(f_Mod_Str)
		If Err = 0 Then
			Mod_IS_Installed_Bool = True
		End If
		Set f_TestObj = Nothing
		Err = 0
	End Function
	Function SendMail(f_Mailto_Address,f_Mailto_Name,f_Subject,f_Mail_Body,f_From_Name,f_Mail_From,f_Priority)
		On Error Resume Next
		Dim f_JMail,f_True_Mail_From,f_Mail_Server,f_Server_Domain
		Set f_JMail=Server.CreateObject("JMail.Message")
		If Err Then
			SendMail= "<br><li>没有安装JMail组件</li>"
			Err.Clear
			Exit Function
		End If
		f_Mail_Server = Get_Cache_Value("MF","MF_Mail_Server")
		f_True_Mail_From = Get_Cache_Value("MF","MF_Mail_Name")
		f_JMail.Silent = True
		f_JMail.Logging = True
		f_JMail.Charset = "gb2312"
		f_JMail.MailServerUserName = f_True_Mail_From
		f_JMail.MailServerPassword = Get_Cache_Value("MF","MF_Mail_Pass_Word")
		f_JMail.ContentType = "text/html"
		f_True_Mail_From =f_True_Mail_From & "@"
		f_Server_Domain = Left(f_Mail_Server,InStrRev(f_Mail_Server,".")-1)
		f_Server_Domain = Left(f_Server_Domain,InStrRev(f_Server_Domain,"."))
		f_True_Mail_From =f_True_Mail_From & Right(f_Mail_Server,Len(f_Mail_Server)-Len(f_Server_Domain))
		f_JMail.From = f_True_Mail_From
		f_JMail.FromName = f_From_Name & "(" & f_Mail_From & ")"
		f_JMail.Subject = f_Subject
		f_JMail.AddRecipient f_Mailto_Address
		f_JMail.Body = f_Mail_Body
		f_JMail.Priority = 3
		f_JMail.AddHeader "Originating-IP", Request.ServerVariables("REMOTE_ADDR")
		f_JMail = ObjJmail.Send(f_Mail_Server)
		f_JMail.Close
		Set f_JMail=nothing
	End Function
	Function NoSqlHack(FS_inputStr)
		Dim f_NoSqlHack_AllStr,f_NoSqlHack_Str,f_NoSqlHack_i
		f_NoSqlHack_AllStr="*|%|'|;|(|)|and |exec |insert |select |delete |update |count |master |truncate |declare |and	|exec	|insert	|select	|delete	|update	|count	|master	|truncate	|declare	|char(|mid(|chr("
		f_NoSqlHack_Str = Split(f_NoSqlHack_AllStr,"|")
		For f_NoSqlHack_i=LBound(f_NoSqlHack_Str) To Ubound(f_NoSqlHack_Str)
			If Instr(LCase(FS_inputStr),f_NoSqlHack_Str(f_NoSqlHack_i))<>0 Then
				If f_NoSqlHack_Str(f_NoSqlHack_i)="'" Then f_NoSqlHack_Str(f_NoSqlHack_i)=" ' "
				Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
				Response.End
			End if
		Next
		NoSqlHack = FS_inputStr
	End Function
	Function CheckIpSafe(ip)
		Dim test,test_i,test_j,ascnum,safe,iplen
		test=Split(ip,".")
		safe=True
		For test_i=LBound(test) To UBound(test)
			iplen=Len(test(test_i))
			For test_j=1 To iplen
				ascnum=Asc(Mid(test(test_i),test_j,1))
				If Not (ascnum>=48 And ascnum<=57) Then
					Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
					Response.End
				End If
			Next
		Next
		CheckIpSafe=ip
	End Function
	Function NoHtmlHackInput(Str) '过滤跨站脚本和HTML标签
		Dim regEx
		Set regEx = New RegExp
		regEx.IgnoreCase = True
		regEx.Pattern = "<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|eval|t"
		If regEx.Test(LCase(Str)) Then
				Response.Write "<html><title>警告</title><body bgcolor=""EEEEEE"" leftmargin=""60"" topmargin=""30""><font style=""font-size:16px;font-weight:bolder;color:blue;""><li>您提交的数据有恶意字符</li></font><font style=""font-size:14px;font-weight:bolder;color:red;""><br><li>提交的内容不能包括[<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|eval]</li><li>您的数据已经被记录!</li><br><li>您的IP："&Request.ServerVariables("Remote_Addr")&"</li><br><li>操作日期："&Now&"</li></font></body></html><!--Powered by Foosun Inc.,AddTime:"&now&"-->"
				Response.End
		End If
		Set regEx = Nothing
		NoHtmlHackInput = Str
	End Function
	'获得中文字数，1个中文站2个字符，codez by Simpwind
	Function GotTopic(Str,StrLen)
		Dim l,t,c, i,LableStr,regEx,Match,Matches
		If StrLen=0 then
			GotTopic=""
			exit function
		End If
		if IsNull(Str) then
			GotTopic = ""
			Exit Function
		end if
		if Str = "" then
			GotTopic=""
			Exit Function
		end If
		Str=Replace(Replace(Replace(Replace(Str,"&nbsp;"," "),"&quot;",Chr(34)),"&gt;",">"),"&lt;","<")
		l=len(str)
		t=0
		strlen=Clng(strLen)
		for i=1 to l
			c=Abs(Asc(Mid(str,i,1)))
			if c>255 then
				t=t+2
			else
				t=t+1
			end if
			if t>=strlen then
				GotTopic=left(str,i)
				exit for
			else
				GotTopic=str
			end if
		Next
		GotTopic = Replace(Replace(Replace(Replace(GotTopic," ","&nbsp;"),Chr(34),"&quot;"),">","&gt;"),"<","&lt;")
	End Function
	'返回中文字符的前StrLen位字符 By Wen Yongzhong
	Function GetCStrLen(Str,StrLen)
		Dim l,t,c, i,LableStr,regEx,Match,Matches
		If StrLen=0 Then
			GetCStrLen=""
			Exit Function
		End If
		If IsNull(Str) Then
			GetCStrLen = ""
			Exit Function
		End If
		If Str = "" Then
			GetCStrLen=""
			Exit Function
		End If
		l=len(str)
		t=0
		strlen=Clng(strLen)
		For i=1 To l
			c=Abs(Asc(Mid(str,i,1)))
			If c>255 Then
				t=t+2
			Else
				t=t+1
			End If
			If t>=strlen Then
				GetCStrLen=left(str,i)
				Exit For
			Else
				GetCStrLen=str
			End If
		Next
	End Function
	'远程存图
	Function ReplaceRemoteUrl(NewsContent,SaveFilePath,FunDoMain,DummyPath)
		Dim re,RemoteFile,RemoteFileurl,SaveFileName,FileName,FileExtName,SaveImagePath,tNewsContent
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global=True
		re.Pattern = "((http|https|ftp|rtsp|mms):(//|\\){1}((w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(S*/)((S)+[.]{1}(gif|jpg|png|bmp)))"
		tNewsContent = NewsContent
		Set RemoteFile = re.Execute(tNewsContent)
		Set re = Nothing
		For Each RemoteFileurl in RemoteFile
			SaveFileName = Mid(RemoteFileurl,InstrRev(RemoteFileurl,"/")+1)
			Call SaveRemoteFile(DummyPath & SaveFilePath & "/" & SaveFileName,RemoteFileurl)
			tNewsContent = Replace(tNewsContent,RemoteFileurl,FunDoMain & SaveFilePath & "/" & SaveFileName)
		Next
		ReplaceRemoteUrl = tNewsContent
	End Function
	Sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
		LocalFileName=Server.MapPath(replace(LocalFileName,"//","/"))
		'PathExistCheck LocalFileName
		On Error Resume Next
		Dim StreamObj,Retrieval,GetRemoteData
		Set Retrieval = Server.CreateObject(G_FS_XMLHTTP)
		If Err Then
			Response.Write "<script language='JavaScript'>alert('你的系统不支持"&G_FS_XMLHTTP&"n，无法保存远程文件！');</script>"
			Err.clear
			Set Retrieval = Nothing
			Exit Sub
		End If
		With Retrieval
			.Open "Get", RemoteFileUrl, False, "", ""
			.Send
			if Err.Number <> 0 then
				Err.Clear
				Set Retrieval = Nothing
				Exit Sub
			end if
			GetRemoteData = .ResponseBody
		End With
		Set Retrieval = Nothing
		If Err Then Err.clear
		Set StreamObj = Server.CreateObject(G_FS_STREAM)
		If Err Then
			Response.Write "<script language='JavaScript'>alert('你的系统不支持"&G_FS_STREAM&"n，无法保存远程文件！');</script>"
			Err.clear
			Set StreamObj = Nothing
			Exit Sub
		End If
		With StreamObj
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile LocalFileName,2
			.Cancel()
			.Close()
		End With
		Set StreamObj = Nothing
	End Sub
	'创建
	Function CreateDateDir(Path)
		Dim sBuild,FSO
		sBuild=path&""&year(Now())&"-"&month(now())
		Set FSO = Server.CreateObject(G_FS_FSO)
		If FSO.FolderExists(sBuild)=false then
			FSO.CreateFolder(sBuild)
		End IF
		sBuild=sBuild&""&day(Now())
		If FSO.FolderExists(sBuild)=false then
			FSO.CreateFolder(sBuild)
		End IF
		set FSO=Nothing
	End Function
	'创建目录
	Sub savePathdirectory(Path)
		Dim FSO
		Set FSO = Server.CreateObject(G_FS_FSO)
		if Trim(G_VIRTUAL_ROOT_DIR) ="" then
			FSO.CreateFolder(Path)
		Else
			FSO.CreateFolder(G_VIRTUAL_ROOT_DIR)
			FSO.CreateFolder(Path)
		End if
	End Sub
	' 传入：字符串、位置、长度
	' 返回：在字符串指定位置取出指定长度的字符串，如果位置大于等于字符串长度，返回空值
	Function getStrLoc(FS_Str,FS_StrLoc,FS_StrLen)
		Dim FS_CharFind
		If Len(FS_Str)>=FS_StrLoc Then
			FS_CharFind = Mid(FS_Str,FS_StrLoc,FS_StrLen)
			getStrLoc = FS_CharFind
		Else
			getStrLoc = ""
		End If
	End Function
	'======================================================================
	' 用AspJpeg组件建立带有新闻标题的图片
	' 参数说明
	' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，bgColor背景颜色，borderColor图片边框颜色(为空或者0不显示边框)
	' TextColor文字颜色,TextFamily文字字体，BoldTF是否粗体（1为加粗），TextSize文字大小，StrTitle文字内容
	' NumTopMargin文字垂直距离画布的顶边距(横向默认是居中的)，StrSavePath图片保存路径（需要绝对路径）
	' 测试代码如下：
	'	AspJpegCreateTextPic 400,60,&Hcccccc,&H0000ff,&H000000,"宋体",1,40,"文字转换图片AspJpeg",8,server.mappath("frontpage.jpg")
	'	response.write "<img src='frontpage.jpg'><br>"
	'======================================================================
	Function AspJpegCreateTextPic(NumCanvasWidth,NumCanvasHeight,bgColor,borderColor,TextColor,TextFamily,BoldTF,TextSize,StrTitle,NumTopMargin,StrSavePath)
		If Not IsObjInstalled("Persits.Jpeg") Then Response.write "<script>alert('对不起，n您需要先安装AspJpeg组件n操作成功，但生成水印图片失败');window.location.href='javascript:history.back();'</script>":Response.End
		If IsExpired("Persits.Jpeg") Then Response.write "<script>alert('对不起，n您的AspJpeg组件已经过期n操作成功，但生成水印图片失败');window.location.href='javascript:history.back();'</script>":Response.End
		Dim Title,objJpeg,TitleWidth
		Title = StrTitle
		Set objJpeg = Server.CreateObject("Persits.Jpeg")
		objJpeg.New NumCanvasWidth, NumCanvasHeight, bgColor
		If borderColor<>"" And borderColor<>0 Then
			objJpeg.Canvas.Pen.Color = borderColor
			objJpeg.Canvas.Brush.Solid = False
			objJpeg.Canvas.DrawBar 1, 1, objJpeg.Width, objJpeg.Height
		End If
		objJpeg.Canvas.Font.Color = TextColor
		objJpeg.Canvas.Font.Family = TextFamily
		If BoldTF=1 Then objJpeg.Canvas.Font.Bold = True
		objJpeg.Canvas.Font.Size = TextSize
		objJpeg.Canvas.Font.Quality = 4
		TitleWidth = objJpeg.Canvas.GetTextExtent( Title )
		objJpeg.Canvas.Print (objJpeg.Width-TitleWidth)/2, NumTopMargin, Title
		objJpeg.Save StrSavePath
		Set objJpeg = Nothing
	End Function
	'======================================================================
	' 用WsImage组件建立带有新闻标题的图片
	' 参数说明：
	' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，，TextColor文字颜色,TextFamily文字字体，TextSize文字大小
	' NumRotation旋转角度（文字保持水平请填0），StrTitle文字内容
	' NumLeft，文字水平与画布的左边距，NumTop文字垂直距离画布的顶边距，StrSavePath图片保存路径（需要绝对路径）
	' 返回值：
	' 如果发生错误，返回错误代码
	' 测试代码如下：
	'	x = WsImgWatermarkText(440,300,&H0000FF&,"宋体",20,0,110,300,"测试水印WsImage",server.MapPath("apple111.jpg"))
	'	response.write x&server.mappath("../admin/Images/wsimg.jpg")&"<br><img src='../admin/Images/wsimg.jpg'><img src='apple111.jpg'>"
	'======================================================================
	Function WsImgWatermarkTextToPic(NumCanvasWidth,NumCanvasHeight,TextColor,TextFamily,TextSize,NumRotation,NumLeft,NumTop,StrTitle,StrSavePath)
		On Error Resume Next
		Dim StrPicPath
		If Not IsObjInstalled("wsImage.Resize") Then Response.write "<script>alert('对不起，n您需要先安装WsImage组件');</script>":Response.End
		If IsExpired("wsImage.Resize") Then Response.write "<script>alert('对不起，n您的WsImage组件已经过期');</script>":Response.End
		StrPicPath = server.mappath("../Images/wsimg.jpg")
		WsImgIndentPicSize1 StrPicPath,NumCanvasWidth,NumCanvasHeight
		Dim objWsImg,strError
		set objWsImg=server.CreateObject("wsImage.Resize")
		objWsImg.LoadSoucePic StrPicPath
		objWsImg.Quality=75
		objWsImg.TxtMarkFont = TextFamily
		objWsImg.TxtMarkBond = false
		objWsImg.MarkRotate = NumRotation
		objWsImg.TxtMarkHeight = TextSize
		objWsImg.AddTxtMark CStr(StrSavePath), StrTitle, TextColor, NumTop, NumLeft
		strError=objWsImg.errorinfo
		If strError<>"" Then WsImgIndentPicScale = strError
		objWsImg.free:Set objWsImg=Nothing
		IF Err Then
			WsImgWatermarkTextToPic=False
		End If
	End Function
	Function WsImgIndentPicSize1(StrPicPath,NumWidth,NumHeight)
		On Error Resume Next
		Dim objWsImg,strError,NumType
		NumType = 0
		If NumHeight<=0 Then NumHeight=0:NumType=1
		If NumWidth<=0 Then NumWidth=0:NumType=2
		set objWsImg=server.CreateObject("wsImage.Resize")
		objWsImg.LoadSoucePic CStr(StrPicPath)
		objWsImg.Quality=75
		objWsImg.OutputSpic CStr(StrPicPath),NumWidth,NumHeight,NumType
		strError=objWsImg.errorinfo
		If strError<>"" Then WsImgIndentPicSize1 = strError
		objWsImg.free:Set objWsImg=Nothing
	End Function
	'======================================================================
	' 用SA-ImgWriter组件建立带有新闻标题的图片
	' 参数说明
	' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，bgColor背景颜色
	' TextColor文字颜色,TextFamily文字字体，TextSize文字大小，StrTitle文字内容
	' NumleftMargin文字水平与画布的左边距，NumTopMargin文字垂直距离画布的顶边距，StrSavePath图片保存路径（需要绝对路径）
	' 测试代码如下：
	'	ImageGenCreateTextPic 420,60,rgb(255,255,255),rgb(0,0,0),"宋体",40,"文字转换图片ImageGen",8,8,server.mappath("frontpage.jpg")
	'	response.write "<img src='frontpage.jpg'><br>"
	'======================================================================
	Function ImageGenCreateTextPic(NumCanvasWidth,NumCanvasHeight,bgColor,TextColor,TextFamily,TextSize,StrTitle,NumleftMargin,NumTopMargin,StrSavePath)
		If Not IsObjInstalled("softartisans.ImageGen") Then Response.write "<script>alert('对不起，n您需要先安装SA-ImgWriter组件');</script>":Response.End
		If IsExpired("softartisans.ImageGen") Then Response.write "<script>alert('对不起，n您的SA-ImgWriter组件已经过期');</script>":Response.End
		Dim objImageGen,objFont
		Set objImageGen = Server.CreateObject("softartisans.ImageGen")
		'Response.Write "<br>"&NumCanvasWidth &"<br>"& NumCanvasHeight&"<br>"& bgColor
		'Response.end
		objImageGen.CreateImage NumCanvasWidth, NumCanvasHeight, bgColor	'rgb(255,255,255)注意格式
		Set objFont = objImagegen.Font
		objFont.name = TextFamily
		objFont.Color = TextColor	'rgb(0,0,0)	'注意格式
		objFont.height = TextSize
		objImageGen.DrawTextOnImage NumleftMargin, NumTopMargin, objImageGen.Width-NumleftMargin, objImageGen.Height-NumTopMargin, StrTitle
		'Response.Write "<br>" &StrSavePath
		objImageGen.SaveImage 0, 3, StrSavePath
		Set objFont = Nothing
		Set objImageGen = Nothing
	End Function
	Function GetStrLengthE(Str)
	'按英文计算字符串的长度，计算头条新闻图片大小用
		Dim i,StrLenth
		For i = 1 to len(Str)
			If Abs(Asc(Mid(Str,i,1)))>255 Then
				StrLenth=StrLenth+1
			Else
				StrLenth=StrLenth+0.5
			End If
		Next
		GetStrLengthE=StrLenth
	End Function
	'判断组件是否可用
	Function IsObjInstalled(strClassString)
		IsObjInstalled = False
		Dim xTestObj
		On Error Resume Next
		Set xTestObj = Server.CreateObject(strClassString)
		If Err Then
			IsObjInstalled = False
			Err.Clear
		Else
			IsObjInstalled = True
		End If
		Set xTestObj = Nothing
	End Function
	'组件是否过期
	Function IsExpired(strClassString)
		IsExpired = True
		Dim xTestObj
		On Error Resume Next
		Err.Clear
		Set xTestObj = Server.CreateObject(strClassString)
		Select Case LCase(strClassString)
			Case "persits.jpeg"
				If DateDiff("s",xTestObj.Expires,now)<0 Then
					IsExpired = False
				End if
			Case "wsimage.resize"
				If instr(xTestObj.errorinfo,"已经过期") = 0 Then
					IsExpired = False
				End if
			Case "softartisans.imagegen"
				xTestObj.CreateImage 500, 500, rgb(255,255,255)
				If Err Then
					Err.Clear
					IsExpired = False
				End if
		End Select
		Set xTestObj = Nothing
	End Function
	'去掉首尾,号
	Function DelHeadAndEndDot(Str)
		Dim StrLen
		StrLen=Len(Str)
		if StrLen>0 then
			if instr(str,",")=1 then
				Str=right(str,StrLen-1)
			end if
			StrLen=Len(Str)
			if instrrev(str,",")=StrLen then
				Str=left(str,StrLen-1)
			end if
		end if
		DelHeadAndEndDot=Str
	End Function
	'验证字符串是否合法,匹配到即为合法
	Function IsValidStr(Str,FilterStr)
		IsValidStr=False
		If Str<>"" Then
			Dim regEx
			Set regEx = New RegExp
			regEx.IgnoreCase = True
			regEx.Pattern = FilterStr
			If regEx.Test(LCase(Str)) Then
				IsValidStr=True
			End If
			Set regEx = Nothing
		End If
	End Function
	'检查是否外部输入
	Function IsSelfRefer()
		Dim sHttp_Referer, sServer_Name
		sHttp_Referer = CStr(Request.ServerVariables("HTTP_REFERER"))
		sServer_Name = CStr(Request.ServerVariables("SERVER_NAME"))
		If Mid(sHttp_Referer, 8, Len(sServer_Name)) = sServer_Name Then
			IsSelfRefer = True
		Else
			IsSelfRefer = False
		End If
	End Function
	'得到多少位数的随机函数
	Function GetRamCode(f_number)
		Randomize
		Dim f_Randchar,f_Randchararr,f_RandLen,f_Randomizecode,f_iR
		f_Randchar="0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
		f_Randchararr=split(f_Randchar,",")
		f_RandLen=f_number '定义密码的长度或者是位数
		for f_iR=1 to f_RandLen
			f_Randomizecode=f_Randomizecode&f_Randchararr(Int((21*Rnd)))
		next
		GetRamCode = f_Randomizecode
	End Function
	'检查英文名称是否合法
	Function chkinputchar(f_char)
		Dim f_name, i, c
		f_name = f_char
		chkinputchar = True
		If Len(f_name) <= 0 Then
			chkinputchar = False
			Exit Function
		End If
		For i = 1 To Len(f_name)
		   c = Mid(f_name, i, 1)
			If InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ@,.0123456789|-_", c) <= 0  Then
			   chkinputchar = False
			Exit Function
		   End If
	   Next
	End Function
	''替换成自己想显示的信息
	''格式:Replacestr(Hs_Rs("FloorType"),"1:多层,2:单层")
	''格式:Replacestr(Rs("Audited"),"1:已通过审核,0:<span class=""tx"">未通过审核</span>")
	Function Replacestr(dbvalue,strlist)
		Dim f_oldstr,f_tmpstr,f_tmparr,f_tmparr1
		f_oldstr = strlist
		if isnull(dbvalue) then dbvalue=""
		f_tmparr = split(f_oldstr,",")
		for each f_tmpstr in f_tmparr
			f_tmparr1 = split(f_tmpstr,":")
			if ubound(f_tmparr1) = 1 then
				if trim(dbvalue) = trim(f_tmparr1(0)) then
					f_oldstr = trim(f_tmparr1(1)) : exit for
				elseif trim(f_tmparr1(0)) = "else" then
					f_oldstr = trim(f_tmparr1(1))
				else
					f_oldstr = dbvalue
				end if
			else
			end if
		next
		Replacestr = f_oldstr
	End Function
	''显示下拉
	''格式PrintOption(rs("language"),":<font color=#999999>请选择</font>,英语:英语,日语:日语,法语:法语")
	Function PrintOption(Equvalue,valuelist)
		Dim f_oldstr,f_tmpstr,f_tmparr,f_tmparr1,isselected
		isselected=false:f_oldstr=""
		if isnull(Equvalue) then Equvalue=""
		f_tmparr = split(valuelist,",")
		for each f_tmpstr in f_tmparr
			f_tmparr1 = split(f_tmpstr,":")
			if ubound(f_tmparr1) = 1 then
				if trim(Equvalue) = trim(f_tmparr1(0)) and isselected=false then
					f_oldstr = f_oldstr & "<option value="""&f_tmparr1(0)&""" selected>"&f_tmparr1(1)&"</option>"
					isselected=true
				elseif trim(f_tmparr1(0))+trim(f_tmparr1(1))<>"" then
					f_oldstr = f_oldstr & "<option value="""&f_tmparr1(0)&""">"&f_tmparr1(1)&"</option>"
				end if
			else
			end if
		next
		PrintOption = f_oldstr
	End Function
	''文本框查询处理，方式可 “A B*”“A *B*”“A B”
	''查询的时候 FildValue为空，显示的时候的 FildValue 不为空，则会将关键字颜色替换
	Function Search_TextArr(StrKey,FildName,FildValue)
		Dim StrTmp,ArrTmp,New_StrTmp,Bol_Xin
		StrTmp = "" : New_StrTmp = ""
		Bol_Xin = False
		ArrTmp = split(StrKey,chr(32))
		for each StrTmp in ArrTmp
		  if Trim(StrTmp)<>"" then
			if FildValue <> "" then
				StrTmp = replace(StrTmp,"*","")
				StrTmp = replace(StrTmp,"*","")
				FildValue = replace(FildValue,StrTmp,"<font color=""red"">"&StrTmp&"</font>")
				New_StrTmp = FildValue
			else
				if left(StrTmp,1) = "*" then StrTmp = "%"&mid(StrTmp,2) : Bol_Xin = True
				if right(StrTmp,1) = "*" then StrTmp = mid(StrTmp,1,len(StrTmp) - 1)&"%" : Bol_Xin = True
				if not Bol_Xin then StrTmp = "%"&StrTmp&"%"
				New_StrTmp = New_StrTmp & " And "&FildName&" like '"&StrTmp&"' "
			end if
		  end if
		  Bol_Xin = False
		next
		''去掉得sql模式时的第一个and
		if FildValue="" and New_StrTmp<>"" then New_StrTmp = " ("&mid(New_StrTmp,len(" And ")+1)&") "
		Search_TextArr = New_StrTmp
	End Function
	''暂不支持中文
	'可配合server.URLEncode如：server.URLEncode(Encrypt(防止被转化成'报错。
	Function Encrypt(ecode)
	''加密
	dim texts
	dim i
	for i=1 to len(ecode)
	texts=texts & chr(asc(mid(ecode,i,1))+3)
	next
	Encrypt = texts
	End Function
	''暂不支持中文
	Function Decrypt(dcode)
	''解密
	dim texts
	dim i
	for i=1 to len(dcode)
	texts=texts & chr(asc(mid(dcode,i,1))-3)
	next
	Decrypt=texts
	End Function
	Function and_where(sql)
		if instr(lcase(sql)," where ")>0 then
			and_where = sql & " and "
		else
			and_where = sql & " where "
		end if
	End Function
	Function Get_Date(f_getDate,f_datestyle)
		dim tmp_f_datestyle
		tmp_f_datestyle = f_datestyle
		if instr(1,f_datestyle,"YY02",1)>0 then
			tmp_f_datestyle= replace(tmp_f_datestyle,"YY02",right(year(f_getDate),2))
		end if
		if instr(f_datestyle,"YY04")>0 then
			tmp_f_datestyle= replace(tmp_f_datestyle,"YY04",year(f_getDate))
		end if
		if instr(f_datestyle,"MM")>0 then
			if month(f_getDate)<10 then
				tmp_f_datestyle= replace(tmp_f_datestyle,"MM","0"&month(f_getDate))
			else
				tmp_f_datestyle= replace(tmp_f_datestyle,"MM",month(f_getDate))
			end if
		end if
		if instr(f_datestyle,"DD")>0 then
			if day(f_getDate)<10 then
				tmp_f_datestyle= replace(tmp_f_datestyle,"DD","0"&day(f_getDate))
			else
				tmp_f_datestyle= replace(tmp_f_datestyle,"DD",day(f_getDate))
			end if
		end if
		if instr(f_datestyle,"HH")>0 then
			if hour(f_getDate)<10 then
				tmp_f_datestyle= replace(tmp_f_datestyle,"HH","0"&hour(f_getDate))
			else
				tmp_f_datestyle= replace(tmp_f_datestyle,"HH",hour(f_getDate))
			end if
		end if
		if instr(f_datestyle,"MI")>0 then
			if minute(f_getDate)<10 then
				tmp_f_datestyle= replace(tmp_f_datestyle,"MI","0"&minute(f_getDate))
			else
				tmp_f_datestyle= replace(tmp_f_datestyle,"MI",minute(f_getDate))
			end if
		end if
		if instr(f_datestyle,"SS")>0 then
			if second(f_getDate)<10 then
				tmp_f_datestyle= replace(tmp_f_datestyle,"SS","0"&second(f_getDate))
			else
				tmp_f_datestyle= replace(tmp_f_datestyle,"SS",second(f_getDate))
			end if
		end if
		Get_Date = tmp_f_datestyle
	End Function
		'html转换函数
	Function Encode(str)
		str=Replace(str,"&","&amp;")
		str=Replace(str,"'","''")
		str=Replace(str,"""","&quot;")
		str=Replace(str," ","&nbsp;")
		str=Replace(str,"<","&lt;")
		str=Replace(str,">","&gt;")
		str=Replace(str,"n","<br>")
		Encode=str
	End Function
	''删除相关文件.
	Function fso_DeleteFile(PhFileName)
		On Error Resume Next
		if isnull(PhFileName) or PhFileName = "" or instr(lcase(PhFileName),"http://")>0 then fso_DeleteFile=true:exit function
		Dim Fso,MyFile,isTrue
		isTrue = False
		Set Fso = CreateObject(G_FS_FSO)
		If Fso.FileExists(server.MapPath(PhFileName)) Then
			set MyFile = Fso.GetFile(server.MapPath(PhFileName))
				MyFile.Delete(True)
			set MyFile = nothing
			isTrue = True
		End If
		Set Fso = Nothing
		if Err.number<>0 then
			isTrue = False
		else
			isTrue = True
		end if
		fso_DeleteFile = isTrue
	End Function
	''长新闻自动分页
	Function AutoSplitPages(StrNewsContent,Page_Split_page,AutoPagesNum)
		Dim Inti,StrTrueContent,iPageLen,DLocation,XLocation,FoundStr
		 If StrNewsContent<>"" and AutoPagesNum<>0 and instr(1,StrNewsContent,Page_Split_page)=0 then
		  Inti=instr(1,StrNewsContent,"<")
		  If inti>=1 then '新闻中存在Html标记
		   StrTrueContent=left(StrNewsContent,Inti-1)
		   iPageLen=IStrLen(StrTrueContent)
		   inti=inti+1
		  Else   '新闻中不存在Html标记，对内容直接分页即可
		   dim i,c,t
		   do while i< len(StrNewsContent)
		   i=i+1
			c=Abs(Asc(Mid(StrNewsContent,i,1)))
			if c>255 then '判断为汉字则为两个字符，英文为一个字符
			 t=t+2
			else
			 t=t+1
			end if
			if t>=AutoPagesNum then  '如果字数达到了分页的数量则插入分页符号
			 StrNewsContent=left(StrNewsContent,i)&Page_Split_page&mid(StrNewsContent,i+1)
			 i=i+6
			 t=0
			end if
		   loop
		   AutoSplitPages=StrNewsContent '返回插入分页符号的内容
		   Exit Function
		  End If
		  iPageLen=0
		''新闻中存在Html标记时，则用下面的语句来处理
		do while instr(Inti,StrNewsContent,">")<>0
		   DLocation=instr(Inti,StrNewsContent,">")  '只计算Html标记之外的字符数量
		   XLocation=instr(DLocation,StrNewsContent,"<")
		   If XLocation>DLocation+1 then
			Inti=XLocation
			StrTrueContent=mid(StrNewsContent,DLocation+1,XLocation-DLocation-1)
			iPageLen=iPageLen+IStrLen(StrTrueContent) '统计Html之外的字符的数量
			If iPageLen>AutoPagesNum then    '如果达到了分页的数量则插入分页字符
			 FoundStr=Lcase(left(StrNewsContent,XLocation-1))
			 If AllowSplitPages(FoundStr,"table|a|b>|i>|strong|div")=true then
			  StrNewsContent=left(StrNewsContent,XLocation-1)&Page_Split_page&mid(StrNewsContent,XLocation)
			  iPageLen=0        '重新统计Html之外的字符
			 End If
			End If
		   ElseIf XLocation=0 then       '在后面再也找不到<，即后面没有Html标记了
			Exit Do
		   ElseIf XLocation=DLocation+1 then    '找到的Html标记之间的内容为空，则继续向后找
			Inti=XLocation
		   End If
		  loop
		 End If
		AutoSplitPages=StrNewsContent
	End Function
	Function IStrLen(TempStr)
		Dim iLen,i,StrAsc
		iLen=0
		for i=1 to len(TempStr)
				StrAsc=Abs(Asc(Mid(TempStr,i,1)))
				if StrAsc>255 then
					iLen=iLen+2
				else
					iLen=iLen+1
				end if
		next
		IStrLen=iLen
	End Function
	Function AllowSplitPages(TempStr,FindStr)
		Dim Inti,BeginStr,EndStr,BeginStrNum,EndStrNum,ArrStrFind,i
		If TempStr<>"" and FindStr<>"" then
			ArrStrFind=split(FindStr,"|")
			For i = 0 to Ubound(ArrStrFind)
				BeginStr="<"&ArrStrFind(i)
				EndStr  ="</"&ArrStrFind(i)
				Inti=0
				do while instr(Inti+1,TempStr,BeginStr)<>0
					Inti=instr(Inti+1,TempStr,BeginStr)
					BeginStrNum=BeginStrNum+1
				Loop
				Inti=0
				do while instr(Inti+1,TempStr,EndStr)<>0
					Inti=instr(Inti+1,TempStr,EndStr)
					EndStrNum=EndStrNum+1
				Loop
				If EndStrNum=BeginStrNum then
					AllowSplitPages=true
				Else
					AllowSplitPages=False
					Exit Function
				End If
			Next
		Else
			AllowSplitPages=False
		End If
	End Function
%>

						