function.asp

小说站源代码文件

'函数名：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," ","")
	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
		exit function
	end if
	i = Len(names(1)) - InStrRev(names(1), ".")
	if i <> 2 and i <> 3 then
		IsValidEmail = false
		exit function
	end if
	if InStr(email, "..") > 0 then
		IsValidEmail = false
	end if
end function

'**************************************************
'函数名：strLength
'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
'参  数：str  ----要求长度的字符串
'返回值：字符串长度
'**************************************************
function strLength(str)
	ON ERROR RESUME NEXT
	dim WINNT_CHINESE
	WINNT_CHINESE	 = (len("中国")=2)
	if WINNT_CHINESE then
		  dim l,t,c
		  dim i
		  l=len(str)
		  t=l
		  for i=1 to l
		  	c=asc(mid(str,i,1))
				if c<0 then c=c+65536
				if c>255 then
					 t=t+1
				end if
		  next
		  strLength=t
	 else 
		  strLength=len(str)
	 end if
	 if err.number<>0 then err.clear
end function


'****************************************************
'函数名：CreateMultiFolder
'作  用：创建多级目录，可以创建不存在的根目录
'参  数：要创建的目录名称，可以是多级
'返回逻辑值：True成功，False失败
'创建目录的根目录从当前目录开始
'****************************************************
Function CreateMultiFolder(ByVal CFolder)
	Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
	Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
	BlInfo = False
	CreateFolder = CFolder
	On Error Resume Next
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	If Err Then
		Err.Clear()
		Exit Function
	End If
	CreateFolder = Replace(CreateFolder,"\","/")
	If Left(CreateFolder,1)="/" Then
		'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
	End If
	If Right(CreateFolder,1)="/" Then
		CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
	End If
	CreateFolderArray = Split(CreateFolder,"/")
	For i = 0 to UBound(CreateFolderArray)
		CreateFolderSub = ""
		For ii = 0 to i
			CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
		Next
		PhCreateFolderSub = Server.MapPath(CreateFolderSub)

'response.Write PhCreateFolderSub&"<br>"

		If Not objFSO.FolderExists(PhCreateFolderSub) Then
			objFSO.CreateFolder(PhCreateFolderSub)
		End If
	Next
	If Err Then
		Err.Clear()
	Else
		BlInfo = True
	End If
	Set objFSO=nothing
	CreateMultiFolder = BlInfo
End Function

'**************************************************
'函数名：FSOFiledel
'作  用：使用FSO删除文件内容的函数
'参  数：filename  ----文件名称
'返回值：文件内容
'**************************************************
  function FSOFiledel(filename) 
  Dim objFSO,objCountFile,FiletempData 
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  	if objFSO.FileExists(Server.MapPath(filename)) = True Then
  		Set objCountFile = objFSO.GetFile(Server.MapPath(filename)) 
			objCountFile.delete
	  		Response.Write "删除文件"&filename
			if Err <> 0 then
				Response.Write Err.Description&"<br>文件 "&filename&" 没有被清除，请检查FSO操作权限！<br>"
				Err.Clear
			else
			Response.Write "<font color='blue'> √ </font><br>"
			end if
  		Set objCountFile = Nothing
  	end if
  Set objFSO = Nothing 
  End Function 

'**************************************************
'函数名：FSOFileRead
'作  用：使用FSO读取文件内容的函数
'参  数：filename  ----文件名称
'返回值：文件内容
'**************************************************
  function FSOFileRead(filename) 
  Dim objFSO,objCountFile,FiletempData 
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject") 
	  Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True) 
		  FSOFileRead = objCountFile.ReadAll 
		  objCountFile.Close 
	  Set objCountFile=Nothing 
  Set objFSO = Nothing 
  End Function 

'**************************************************
'函数名：FSOlinedit
'作  用：使用FSO读取文件某一行的函数
'参  数：filename  ----文件名称
'		  lineNum	----行数
'返回值：文件该行内容
'**************************************************
  function FSOlinedit(filename,lineNum) 
  if linenum < 1 then exit function 
	  dim fso,f,temparray,tempcnt 
	  set fso = server.CreateObject("scripting.filesystemobject") 
	  if not fso.fileExists(server.mappath(filename)) then exit function 
	  set f = fso.opentextfile(server.mappath(filename),1) 
	  if not f.AtEndofStream then 
		  tempcnt = f.readall 
		  f.close 
	  set f = nothing 
	  temparray = split(tempcnt,chr(13)&chr(10)) 
	  if lineNum>ubound(temparray)+1 then 
		  exit function 
	  else 
		  FSOlinedit = temparray(lineNum-1) 
	  end if 
  end if 
  end function 

'**************************************************
'函数名：FSOlinewrite
'作  用：使用FSO写文件某一行的函数
'参  数：filename	 ----文件名称
'		  lineNum	  ----行数
'		  Linecontent ----内容
'返回值：无
'**************************************************
  function FSOlinewrite(filename,lineNum,Linecontent) 
  if linenum < 1 then exit function 
	  dim fso,f,temparray,tempCnt 
	  set fso = server.CreateObject("scripting.filesystemobject") 
	  if not fso.fileExists(server.mappath(filename)) then exit function 
	  set f = fso.opentextfile(server.mappath(filename),1) 
	  if not f.AtEndofStream then 
		  tempcnt = f.readall 
		  f.close 
		  temparray = split(tempcnt,chr(13)&chr(10)) 
		  if lineNum>ubound(temparray)+1 then 
			  exit function 
		  else 
			  temparray(lineNum-1) = lineContent 
		  end if 
		  tempcnt = join(temparray,chr(13)&chr(10)) 
		  set f = fso.createtextfile(server.mappath(filename),true) 
		  f.write tempcnt 
	  end if 
	  f.close 
	  set f = nothing 
  end function 
'**************************************************