<%
'脚本超时
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,Str_InputStr
	Str_InputStr=FS_inputStr
	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(|and[|exec[|insert[|select[|delete[|update[|count[|master[|truncate[|declare[|set[|set |set	|where[|where |where	|xp_cmdshell|xp_cmdshell |xp_cmdshell	"
	f_NoSqlHack_Str = Split(f_NoSqlHack_AllStr,"|")

	For f_NoSqlHack_i=LBound(f_NoSqlHack_Str) To Ubound(f_NoSqlHack_Str)
		If Instr(LCase(Str_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 = Replace(Str_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|swf|flv|mp3|wma)))"
	tNewsContent = NewsContent
	Set RemoteFile = re.Execute(tNewsContent)
	Set re = Nothing
	For Each RemoteFileurl in RemoteFile
		SaveFileName = Mid(RemoteFileurl,InstrRev(RemoteFileurl,"/")+1)
		Call SaveRemoteFile(SaveFilePath & "/" & SaveFileName,RemoteFileurl,1)
		'Call SaveRemoteFile(DummyPath & SaveFilePath & "/" & SaveFileName,RemoteFileurl)
		'tNewsContent = Replace(tNewsContent,RemoteFileurl,FunDoMain & SaveFilePath & "/" & SaveFileName)
		tNewsContent = Replace(tNewsContent,RemoteFileurl,SaveFilePath & "/" & SaveFileName)
	Next
	ReplaceRemoteUrl = tNewsContent
End Function

Sub SaveRemoteFile(LocalFileName,RemoteFileUrl,WTF)
	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 then
			Response.Write "<script language='JavaScript'>alert('目标服务器不支持"&G_FS_XMLHTTP&"\n，无法保存远程文件！');</script>"
			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
	IF WTF = 1 Then
		AddWaterMark LocalFileName
	End IF	
	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)
	AspJpegCreateTextPic = true
	If GetIsOpenWater=True Then Exit Function
	If Not IsObjInstalled("Persits.Jpeg") Then
		AspJpegCreateTextPic = false
	else
		If IsExpired("Persits.Jpeg")=true Then
			AspJpegCreateTextPic = false
		else
			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 = "&H"&TextColor'&HFF0000
			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 if
	end if
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)
	WsImgWatermarkTextToPic = true
	If GetIsOpenWater=True Then Exit Function
	On Error Resume Next
	Dim StrPicPath
	If Not IsObjInstalled("wsImage.Resize") then
		WsImgWatermarkTextToPic = false
	else
		If IsExpired("wsImage.Resize")=true  then
			WsImgWatermarkTextToPic = false
		else
			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 if
	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)
	ImageGenCreateTextPic = true
	If GetIsOpenWater=True Then Exit Function
	If Not IsObjInstalled("softartisans.ImageGen") Then
		ImageGenCreateTextPic=false
	else
		If IsExpired("softartisans.ImageGen")=true Then
			ImageGenCreateTextPic=false
		else
			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 if
	end if
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
		Case Else
			IsExpired = False
	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 = FildValue
	Bol_Xin = False
	ArrTmp = split(StrKey,chr(32))
	for each StrTmp in ArrTmp
	  if Trim(StrTmp)<>"" then
		if New_StrTmp <> "" then
			StrTmp = replace(StrTmp,"*","")
			New_StrTmp = replace(New_StrTmp,StrTmp,"<font color=""red"">"&StrTmp&"</font>")
		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,isTrue
	isTrue = False
	Set Fso = CreateObject(G_FS_FSO)
	Fso.DeleteFile server.MapPath(PhFileName),True
	Set Fso = Nothing
	if Err then
		isTrue = False
	else
		isTrue = True
	end if
	fso_DeleteFile = isTrue
End Function

''删除相关文件.
Function fso_DeleteFolder(PhFileName)
	On Error Resume Next
	if isnull(PhFileName) or PhFileName = "" or instr(lcase(PhFileName),"http://")>0 then fso_DeleteFile=true:exit function
	Dim Fso,isTrue
	isTrue = False
	Set Fso = CreateObject(G_FS_FSO)
	Fso.DeleteFolder server.MapPath(PhFileName),True
	Set Fso = Nothing
	If Err Then
		isTrue = False
	Else
		isTrue = True
	End If
	fso_DeleteFile = isTrue
End Function

' ============================================
' 传入：新闻内容
' 返回：插入分页标记后的新闻内容
' 作用：自动为新闻分页
' ============================================
Function AutoSplitPages(StrNewsContent,Page_Split_page,AutoPagesNum)
	Dim i,IsCount,OneChar,StrCount,FoundStr,Pages_i_Str,Pages_i_Arr
	AutoPagesNum = Clng(AutoPagesNum)
	Page_Split_page = Cstr(Page_Split_page)
	If StrNewsContent<>"" and AutoPagesNum<>0 and InStr(1,StrNewsContent,Page_Split_page)=0 then
		IsCount=True
		Pages_i_Str=""
		For i= 1 To Len(StrNewsContent)
			OneChar=Mid(StrNewsContent,i,1)
			If OneChar="<" Then
				IsCount=False
			ElseIf OneChar=">" Then
				IsCount=True
			Else
				If IsCount=True Then
					If Abs(Asc(OneChar))>255 Then
						StrCount=StrCount+2
					Else
						StrCount=StrCount+1
					End If
					If StrCount>=AutoPagesNum And i<Len(StrNewsContent) Then
						FoundStr=Left(StrNewsContent,i)
						If AllowSplitPages(FoundStr,"table|a|b>|i>|strong|div|span")=true then
							Pages_i_Str=Pages_i_Str & Trim(CStr(i)) & "," 
							StrCount=0
						End If
					End If
				End If
			End If	
		Next
		If Len(Pages_i_Str)>1 Then Pages_i_Str=Left(Pages_i_Str,Len(Pages_i_Str)-1)
		Pages_i_Arr=Split(Pages_i_Str,",")
		For i = UBound(Pages_i_Arr) To LBound(Pages_i_Arr) Step -1
			StrNewsContent=Left(StrNewsContent,Pages_i_Arr(i)) & Page_Split_page & Mid(StrNewsContent,Pages_i_Arr(i)+1)
		Next
	End If
	AutoSplitPages=StrNewsContent
End Function

' ============================================
' 传入：被查找字符串，查找字符串
' 返回：True,False
' 作用：判断是否允许字符串加入分页标记
' ============================================

Function AllowSplitPages(TempStr,FindStr)
	Dim Inti,BeginStr,EndStr,BeginStrNum,EndStrNum,ArrStrFind,i
	TempStr=LCase(TempStr)
	FindStr=LCase(FindStr)
	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

Function Recv(Str_Number)
	Dim Arr_Number,Str_Return,Temp_i
	Arr_Number = Split(Str_Number,chr(108))
	Str_Return = ""
	For Temp_i = LBound(Arr_Number) To UBound(Arr_Number)
		Str_Return = Str_Return & Chr(Arr_Number(Temp_i)+31)
	Next
	Recv = Str_Return
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 GetInfo(GetPath)
	Dim http,ErrContentLength,Report,ContentLength,ErrContent
	ErrContent = ""
	On Error Resume Next
	Response.Clear
	Set http=Server.CreateObject("Microsoft.XMLHTTP")
	If Err Then
		Err.Clear
		Set http = Server.CreateObject("Msxml2.XMLHTTP")
		If Err Then
			ErrContent = "服务器不支持XML对象"
			Err.Clear
		End If
	End If
	If ErrContent<>"" Then
		GetInfo = "False||"&ErrContent
	Else
		http.setTimeouts 1000,1000,1000,1000
		http.Open "GET",GetPath,False
		http.Send
		If http.readyState<>4 Or http.status<>200 Then
			GetInfo = "False||可能是防火墙阻止或服务器不可用。"
		Else
			GetInfo = "True||"&http.ResponseText
		End If
	End If
End Function

Function GetIsOpenWater()'判断是否开启水印组件
	Dim IsOpenRs,IsOpenSql
	IsOpenSql="Select PicClassid From FS_MF_Config"
	Set IsOpenRs=Conn.execute(IsOpenSql)
	If Not IsOpenRs.Eof Then
		If Cint(IsOpenRs("PicClassid"))=9 Then
			IsOpenRs.Close
			Set IsOpenRs=Nothing
			GetIsOpenWater=True
			Exit Function
		Else
			IsOpenRs.Close
			Set IsOpenRs=Nothing
			GetIsOpenWater=False
		End If
		Exit Function
	Else
		IsOpenRs.Close
		Set IsOpenRs=Nothing
		GetIsOpenWater=False
	Exit Function
	End If
End Function


Function GetGuestBookTitle()'获得留言板参数设置中的留言板Title值
	Dim GuestBookRs,GuestBookSql,TempTitle
	GuestBookSql="Select Title From FS_WS_Config"
	Set GuestBookRs=Conn.execute(GuestBookSql)
	If Not GuestBookRs.Eof Then
		TempTitle=GuestBookRs("Title")
	Else
		TempTitle="留言系统"
	End If
	GuestBookRs.Close
	Set GuestBookRs=Nothing
	GetGuestBookTitle=TempTitle
End Function


Function GetUserSystemTitle()'获得会员系统参数设置中的Title值
	Dim UserSystemRs,UserSystemSql,UserSystemTitle
	UserSystemSql="Select UserSystemName From FS_ME_SysPara"
	Set UserSystemRs=User_Conn.execute(UserSystemSql)
	If Not UserSystemRs.Eof Then
		UserSystemTitle=UserSystemRs("UserSystemName")
	Else
		UserSystemTitle="会员系统"
	End If
	UserSystemRs.Close
	Set UserSystemRs=Nothing
	GetUserSystemTitle=UserSystemTitle
End Function

Function CheckBlogOpen()'检查是否开启日志
	Dim CheckRs,CheckSql
	CheckSql="Select isOpen From FS_ME_iLogSysParam"
	Set CheckRs=User_Conn.Execute(CheckSql)
	If Not CheckRs.Eof Then 
		If CheckRs("isOpen")=1 Then 
			CheckBlogOpen=True
		Else
			CheckBlogOpen=False
		End If
	Else
		CheckBlogOpen=False
	End If
	CheckRs.Close
	Set CheckRs=Nothing
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
'		Response.Write AutoPagesNum 
'		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 '返回插入分页符号的内容
'	   Response.End
'	   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 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

%>