function.asp

功能介绍： 一、会员功能模块 1、站内短信发布(设计中) 2、书架收藏夹 3、发表评论(功能不完善) 4、申请作家(与添书员整合) 5、申请添书员(与作家整合) 6、申请更新员

		RemoteFileUrl=TempArray2(Tempi)
		If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
			ArrSaveFileName = Split(RemoteFileurl,".")
		 strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
			If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
				UploadFiles=""
				ReplaceSaveRemoteFile=ConStr
				Exit Function
			End If

			Randomize
			RanNum=Int(900*Rnd)+100
		 strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" & hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
			Re.Pattern =TempArray(Tempi)
		 response.Write "<br>保存到本地地址:"&InstallPath & strChannelDir & strFileName
		 If SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,TistUrl)=True Then
		 response.Write "<font color=blue>成功</font><br>"
				PathTemp=InstallPath & strChannelDir & strFileName
				ConStr=Re.Replace(ConStr,PathTemp)
				Re.Pattern=InstallPath&strChannelDir
				UploadFiles=UploadFiles & "|" & InstallPath & strChannelDir & strFileName
			Else
				PathTemp=RemoteFileUrl
				ConStr=Re.Replace(ConStr,PathTemp)
			End If
		ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
			Re.Pattern =TempArray(Tempi)
			ConStr=Re.Replace(ConStr,RemoteFileUrl)
		End If
'********************************
	Next	
	Set Re=nothing
	ReplaceSaveRemoteFile=ConStr
End function

'==================================================
'函数名：ReplaceSwfFile
'作  用：解析动画路径
'参  数：ConStr ------ 要替换的字符串
'参  数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSwfFile(ConStr,TistUrl)
	If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
		ReplaceSwfFile=ConStr
		Exit Function
	End If
	Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2

	Set Re = New Regexp 
	Re.IgnoreCase = True 
	Re.Global = True
	Re.Pattern ="<object.+?[^\>]>"
	Set Matches =Re.Execute(ConStr) 
	For Each Match in Matches
		If TempStr<>"" then 
			TempStr=TempStr & "$Array$" & Match.Value
		Else
			TempStr=Match.Value
		End if
	Next
	If TempStr<>"" Then
		TempArray=Split(TempStr,"$Array$")
		TempStr=""
		For Tempi=0 To Ubound(TempArray)
			Re.Pattern ="value\s*=\s*.+?\.swf"
			Set Matches =Re.Execute(TempArray(Tempi)) 
			For Each Match in Matches
				If TempStr<>"" then 
					TempStr=TempStr & "$Array$" & Match.Value
				Else
					TempStr=Match.Value
				End if
			Next
		Next
	End if
	If TempStr<>"" Then
		Re.Pattern ="value\s*=\s*"
		TempStr=Re.Replace(TempStr,"")
	End If
	If TempStr="" or IsNull(TempStr)=True Then
		ReplaceSwfFile=ConStr
		Exit function
	End if
	TempStr=Replace(TempStr,"""","")
	TempStr=Replace(TempStr,"'","")
	TempStr=Replace(TempStr," ","")

	Set Matches=nothing
	Set Re=nothing

	'去掉重复文件开始
	TempArray=Split(TempStr,"$Array$")
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
			TempStr=TempStr & "$Array$" & TempArray(Tempi)
		End If
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempArray=Split(TempStr,"$Array$")
	'去掉重复文件结束

	'转换相对地址开始
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempStr=Replace(TempStr,Chr(0),"")
	TempArray2=Split(TempStr,"$Array$")
	TempStr=""
	'转换相对地址结束

	'替换
	Set Re = New Regexp
	Re.IgnoreCase = True 
	Re.Global = True
	For Tempi=0 To Ubound(TempArray2)
		RemoteFileUrl=TempArray2(Tempi)
		Re.Pattern =TempArray(Tempi)
		ConStr=Re.Replace(ConStr,RemoteFileUrl)
	Next	
	Set Re=nothing
	ReplaceSwfFile=ConStr
End function

'==================================================
'过程名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'参  数：RemoteFileUrl ------ 远程文件URL
'参  数：Referer ------ 远程调用文件（对付防采集的，用内容页地址，没有防的留空）
'==================================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
	 SaveRemoteFile=True
	dim Ads,Retrieval,GetRemoteData
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", RemoteFileUrl, False, "", ""
		if Referer<>"" then .setRequestHeader "Referer",Referer
		On Error Resume Next
		if Err <> 0 then
			Err.Clear
			SaveRemoteFile=False
			Exit Function
		end if
		.Send
		  If .Readystate<>4 then
				SaveRemoteFile=False
				Exit Function
		  End If
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	Set Ads = Server.CreateObject("Adodb.Stream")
	With Ads
		.Type = 1
		.Open
		.Write GetRemoteData
		.SaveToFile server.MapPath(LocalFileName),2
		.Cancel()
		.Close()
	End With
	Set Ads=nothing
end Function 

'==================================================
'函数名：FpHtmlEnCode
'作  用：标题过滤
'参  数：fString ------字符串
'==================================================
Function FpHtmlEnCode(fString)
	If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
		 fString=nohtml(fString)
		 fString=FilterJS(fString)
		 fString = Replace(fString,"&nbsp;"," ")
		 fString = Replace(fString,"&quot;","")
		 fString = Replace(fString,"&#39;","")
		 fString = replace(fString, ">", "")
		 fString = replace(fString, "<", "")
		 fString = Replace(fString, CHR(9), " ")'&nbsp;
		 fString = Replace(fString, CHR(10), "")
		 fString = Replace(fString, CHR(13), "")
		 fString = Replace(fString, CHR(34), "")
		 fString = Replace(fString, CHR(32), " ")'space
		 fString = Replace(fString, CHR(39), "")
		 fString = Replace(fString, CHR(10) & CHR(10),"")
		 fString = Replace(fString, CHR(10)&CHR(13), "")
		 fString=Trim(fString)
		 FpHtmlEnCode=fString
	Else
		 FpHtmlEnCode="$False$"
	End If
End Function

'==================================================
'函数名：GetPaing
'作  用：获取分页
'==================================================
Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
	GetPaing="$False$"
	Exit Function
End If

Dim Start,Over,ConTemp,TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
If Over<=0 Then
	GetPaing="$False$"
	Exit Function
Else
	If IncluR=True Then
		Over=Over+Len(OverStr)
	End If
End If
TempStr=Mid(TempStr,1,Over)
Start=InstrRev(TempStr,StartStr)
If IncluL=False Then
	Start=Start+Len(StartStr)
End If

If Start<=0 Or Start>=Over Then
	GetPaing="$False$"
	Exit Function
End If
ConTemp=Mid(ConStr,Start,Over-Start)

ConTemp=Trim(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Replace(ConTemp,",","")
ConTemp=Replace(ConTemp,"'","")
ConTemp=Replace(ConTemp,"""","")
ConTemp=Replace(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp,"&nbsp;","")
GetPaing=ConTemp
End Function


'***********************************************
'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
	if strUrl="" then
		JoinChar=""
		exit function
	end if
	if InStr(strUrl,"?")<len(strUrl) then 
		if InStr(strUrl,"?")>1 then
			if InStr(strUrl,"&")<len(strUrl) then 
				JoinChar=strUrl & "&"
			else
				JoinChar=strUrl
			end if
		else
			JoinChar=strUrl & "?"
		end if
	else
		JoinChar=strUrl
	end if
end function


'**************************************************
'函数名：CreateKeyWord
'作  用：由给定的字符串生成关键字
'参  数：Constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
Function CreateKeyWord(byval Constr,Num)
	If Constr="" or IsNull(Constr)=True or Constr="$False$" Then
		CreateKeyWord="$False$"
		Exit Function
	End If
	If Num="" or IsNumeric(Num)=False Then
		Num=2
	End If
	Constr=Replace(Constr,CHR(32),"")
	Constr=Replace(Constr,CHR(9),"")
	Constr=Replace(Constr,"&nbsp;","")
	Constr=Replace(Constr," ","")
	Constr=Replace(Constr,"(","")
	Constr=Replace(Constr,")","")
	Constr=Replace(Constr,"<","")
	Constr=Replace(Constr,">","")
	Constr=Replace(Constr,"""","")
	Constr=Replace(Constr,"?","")
	Constr=Replace(Constr,"*","")
	Constr=Replace(Constr,"|","")
	Constr=Replace(Constr,",","")
	Constr=Replace(Constr,".","")
	Constr=Replace(Constr,"/","")
	Constr=Replace(Constr,"\","")
	Constr=Replace(Constr,"-","")
	Constr=Replace(Constr,"@","")
	Constr=Replace(Constr,"#","")
	Constr=Replace(Constr,"$","")
	Constr=Replace(Constr,"%","")
	Constr=Replace(Constr,"&","")
	Constr=Replace(Constr,"+","")
	Constr=Replace(Constr,":","")
	Constr=Replace(Constr,"：","")	
	Constr=Replace(Constr,"‘","")
	Constr=Replace(Constr,"“","")
	Constr=Replace(Constr,"”","")			
	Dim i,ConstrTemp
	For i=1 To Len(Constr)
		ConstrTemp=ConstrTemp & "|" & Mid(Constr,i,Num)
	Next
	If Len(ConstrTemp)<254 Then
		ConstrTemp=ConstrTemp & "|"
	Else
		ConstrTemp=Left(ConstrTemp,254) & "|"
	End If
	CreateKeyWord=ConstrTemp
End Function

Function CheckUrl(strUrl)
	Dim Re
	Set Re=new RegExp
	Re.IgnoreCase =true
	Re.Global=True
	Re.Pattern="http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
	If Re.test(strUrl)=True Then
		CheckUrl=strUrl
	Else
		CheckUrl="$False$"
	End If
	Set Rs=Nothing
End Function

'==================================================
'函数名：ScriptHtml
'作  用：过滤html标记
'参  数：ConStr ------ 要过滤的字符串
'==================================================
Function ScriptHtml(Byval ConStr,TagName,FType)
	 Dim Re
	 Set Re=new RegExp
	 Re.IgnoreCase =true
	 Re.Global=True
	 Select Case FType
	 Case 1
		 Re.Pattern="<" & TagName & "([^>])*>"
		 ConStr=Re.Replace(ConStr,"")
	 Case 2
		 Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
		 ConStr=Re.Replace(ConStr,"")
	 Case 3
		 Re.Pattern="<" & TagName & "([^>])*>"
		 ConStr=Re.Replace(ConStr,"")
		 Re.Pattern="</" & TagName & "([^>])*>"
		 ConStr=Re.Replace(ConStr,"")
	 End Select
	 ScriptHtml=ConStr
	 Set Re=Nothing
End Function

Function CheckDir(byval FolderPath)
	dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If fso.FolderExists(Server.MapPath(folderpath)) then
	'存在
		CheckDir = True
	Else
	'不存在
		CheckDir = False
	End if
	Set fso = nothing
End Function

Function MakeNewsDir(byval foldername)
	dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
		  fso.CreateFolder(Server.MapPath(foldername))
		  If fso.FolderExists(Server.MapPath(foldername)) Then
			  MakeNewsDir = True
		  Else
			  MakeNewsDir = False
		  End If
	Set fso = nothing
End Function

'**************************************************
'函数名：IsObjInstalled
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'		  False ----没有安装
'**************************************************
Function IsObjInstalled(strClassString)
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

'********************************************
'函数名：IsValidEmail
'作  用：检查Email地址合法性
'参  数：email ----要检查的Email地址
'返回值：True  ----Email地址合法
'		  False ----Email地址不合法
'********************************************
function IsValidEmail(email)
	dim names, name, i, c
	IsValidEmail = true
	names = Split(email, "@")
	if UBound(names) <> 1 then
		IsValidEmail = false
		exit function
	end if
	for each name in names
		if Len(name) <= 0 then
			IsValidEmail = false
	 		exit function
		end if
		for i = 1 to Len(name)
			 c = Lcase(Mid(name, i, 1))
			if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
				 IsValidEmail = false
				 exit function
			  end if
		next
		if Left(name, 1) = "." or Right(name, 1) = "." then
	 	  IsValidEmail = false
			exit function
		end if
	next
	if InStr(names(1), ".") <= 0 then
		IsValidEmail = false