function.asp

这次自已做的美工,可能很难看,但主要是为提高效率,这次全部生成了静态,只有一个链接查看最新文章的列表没有生成,因为我觉得没必要生成,浪费空间大小,那是一个很少用到的功能!这次去掉了很多功能,这个版本主

<%
'********************************************
'函数名：ReplaceShow
'作  用：替换新闻内容
'参  数：Title ----新闻标题
'	dtNews ----新闻时间
'	NewsClass ----新闻类别树
'	Hits ----点击率
'	SiteUrl ----站点名称
'	Author ----发表人
'	Content ----新闻内容
'返回值：字符串  ----替换成新闻内容
'********************************************
Function ReplaceShow(TemplateContent,Title,dtNews,NewsClass,Hits,SiteUrl,Author,Content)
	Template = TemplateContent
	Template = Replace(Template,"$新闻标题$",Title)
	Template = Replace(Template,"$新闻时间$",dtNews)
	Template = Replace(Template,"$新闻类别$",NewsClass)
	Template = Replace(Template,"$点击率$",Hits)
	Template = Replace(Template,"$URL$",SiteUrl)
	Template = Replace(Template,"$新闻作者$",Author)
	Template = Replace(Template,"$新闻内容$",Content)
	ReplaceShow = Template
End Function

'********************************************
'函数名：CreateAllFolder
'作  用：创建新闻所有节点目录
'参  数：ID ----新闻ID
'	dtNews ----新闻时间(用于创建时间目录)
'返回值：字符串  ----替换成新闻相对路径
'********************************************
Function CreateAllFolder(ID,dtNews)
	DatePath = GetStrDate(dtNews,"-")
	sFilePath = Replace(M_FilePath,"[时间目录]",DatePath)
	sFilePath = Replace(sFilePath,"[文件名]",ID)
	sFilePath = Replace(sFilePath,"[扩展名]",M_Expand)
	sFilePathA = Split(sFilePath,"/")

	For i=0 To UBound(sFilePathA) - 1
		If i > 0 Then
			CreateFolder sFilePathA(i-1) & "/" & sFilePathA(i)
		Else
			CreateFolder sFilePathA(i)
		End If
	Next
	CreateAllFolder = sFilePath
	
End Function

'********************************************
'函数名：ReadFile
'作  用：读取文件的内容(Text)
'参  数：FileSpec ----文件的相对路径
'返回值：字符串  ----文件的内容
'********************************************
Function ReadFile(FileSpec)
	Dim Fso, F
	Set Fso = CreateObject(M_FsoName)
	Set F = Fso.OpenTextFile(Server.MapPath(FileSpec), 1)
	ReadFile =  F.ReadAll
	Set F=nothing
	Set Fso=nothing
End Function

'********************************************
'函数名：CreateFolder
'作  用：创建文件夹
'参  数：Folder ----文件夹的相对路径
'返回值：无
'********************************************
Function CreateFolder(Folder)
	Dim Fso, F
	Set Fso = CreateObject(M_FsoName)
	If Fso.FolderExists(Server.MapPath(Folder)) Then Exit Function
	Set F = Fso.CreateFolder(Server.MapPath(Folder))
	Set F = Nothing
	Set Fso = Nothing
End Function

'********************************************
'函数名：WriteToFile
'作  用：创建文件夹
'参  数：FilePath ----文件的相对路径
'	wStr ----要写入的内容
'返回值：无
'********************************************
Function WriteToFile(FilePath,wStr)
	Dim Fso, F
	Set Fso = Server.CreateObject(M_FsoName)
	Set F = fso.CreateTextFile(Server.MapPath(FilePath),True)
	F.Write wStr
	Set F = Nothing
	Set Fso = Nothing
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

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

'***************************************************
'函数名：OkMsg
'作  用：显示成功信息
'参  数：message ----成功消息的内容
'	url ----成功后转入的URL地址
'返回值：无
'***************************************************
Sub OkMsg(message,url)
	Response.Write ("<script>alert('"&message&"');window.location.href='"&url&"';</script>")
	Response.End
End Sub

'***************************************************
'函数名：ErrorMsg
'作  用：显示出错信息
'参  数：message ----错误消息的内容
'返回值：无
'***************************************************
Sub ErrorMsg(message)
	Response.Write ("<script>alert('"&message&"');history.back();</script><script>window.close();</script>")
	Response.End
End Sub

'***************************************************
'函数名：HTMLEncode
'作  用：替换字符串
'参  数：fString ----要替换的字符串
'返回值：替换成功的安符串
'***************************************************
Function HTMLEncode(fString)
	fString=Trim(fString)
	fString=server.htmlencode(fString)
	fString=Replace(fString,"'","&#39;")
	fString=Replace(fString,"""","&#34;")
	fString=replace(fString,"\","&#92;")
	fString=replace(fString,"'","&#39;")
	fString=replace(fString,"--","&#45;&#45;")
	fString=replace(fString,vbCrlf,"<br>")
	fString=replace(fString,"	","")
	HTMLEncode=fString
End Function

'***************************************************
'函数名：CutStr
'作  用：截取字符串
'参  数：Str ----要截取的字符串
'	iLen ----要截取的字符串长度
'返回值：截取成功的安符串
'***************************************************
Function CutStr(Str,iLen)
	Dim l,t,c,i
	l = Len(Str)
	t = 0
	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 >= iLen Then
			CutStr = Left(Str,i)&"..."
			Exit For
		Else
			CutStr = Str
		End If
	Next
	CutStr = Replace(CutStr,chr(10),"")
End Function

'***************************************************
'函数名：GetStrDate
'作  用：分隔日期
'参  数：dtDay ----要分隔的日期
'	strI ----要用来分隔的字符串
'返回值：分隔成功的日期
'***************************************************
Function GetStrDate(dtDay,strI)	'得到日期字符串　strII是分隔符
	GetStrDate = cstr(year(dtDay)) + strI + cstr(month(dtDay)) + strI + cstr(day(dtDay))
End Function

'***************************************************
'函数名：GetValue
'作  用：获取传出的数据
'参  数：Name ----要获取的数据名称
'返回值：数据内容
'***************************************************
Function GetValue(Name)
	GetValue = HTMLEncode(Request(Name))
End Function

'***************************************************
'函数名：GetFormValue
'作  用：获取表单的数据
'参  数：Name ----要获取的数据名称
'返回值：数据内容
'***************************************************
Function GetFormValue(Name)
	GetFormValue = HTMLEncode(Request.Form(Name))
End Function

'***************************************************
'函数名：GetUrlValue
'作  用：获取URL传出的数据
'参  数：Name ----要获取的数据名称
'返回值：数据内容
'***************************************************
Function GetUrlValue(Name)
	GetUrlValue = HTMLEncode(Request.QueryString(Name))
End Function

'***************************************************
'函数名：GetRs
'作  用：获取URL传出的数据
'参  数：SQL ----传入SQL语句
'返回值：返回RecordSet对象
'***************************************************
Function GetRs(SQL)
	Set SetRs = Server.CreateObject("ADODB.RecordSet")
	SetRs.Open SQL,Conn,1
	Set GetRs = SetRs
End Function

'***************************************************
'函数名：UpdateRs
'作  用：传入SQL语句执行
'参  数：SQL ----传入SQL语句
'返回值：返回True或False
'***************************************************
Function UpdateRs(SQL)
	On Error Resume Next
	Conn.Execute(SQL)
	If err Then
		UpdateRs = False
	Else
		UpdateRs = True
	End If
End Function

'***************************************************
'函数名：OutWrite
'作  用：传入要打印在页面的数据
'参  数：str ----要打印在页面的数据
'返回值：无
'***************************************************
Function OutWrite(str)
	Response.Write str
End Function

'***************************************************
'函数名：OutEnd
'作  用：结束要打印在页面的数据
'参  数：无
'返回值：无
'***************************************************
Function OutEnd()
	Response.End()
End Function

'***************************************************
'函数名：OutUrl
'作  用：转入一个新的页面
'参  数：Url ----要转入的页面
'返回值：无
'***************************************************
'''''''''''Response.Redirect字符串''''''''''''''''
Function OutUrl(Url)
	Response.Redirect(Url)
End Function

'***************************************************
'函数名：Backup
'作  用：备份数据库
'参  数：无
'返回值：无
'***************************************************
Function Backup()
	If IsSqlDataBase = 0 Then
		iDay = DateDiff("d",M_dtBak,Now())
		If iDay >= M_iBakSet And M_iBakSet <> 0 Then
			strDataPath = Server.MapPath(DataPath&""&DataFile)
			strBakFile = "#["&GetStrDate(now(),"-")&"]AutoBak.mdb"
			strBakPath = Server.MapPath(BakPath&""&strBakFile)
			set MyFileObject=Server.CreateObject(M_FsoName)
				If MyFileObject.FileExists(strDataPath) Then
				MyFileObject.CopyFile ""&strDataPath&"",strBakPath
				UpdateRs("Insert Into T_Bak (vcBakFile,vcBakType) Values ('"& strBakFile & "','自动备份[成功]')")
			Else
				UpdateRs("Insert Into T_Bak (vcBakFile,vcBakType) Values ('"& strBakFile & "','自动备份[<font color=red>失败</font>]')")
			End If
				UpdateRs("Update T_Config Set M_dtBak = '"& Now() & "'")
		End if
	End If
End Function
'判断文件类型是否合格
Function CheckFileExt (fileEXT)
dim Forumupload
Forumupload="gif,jpg,bmp,jpeg"
Forumupload=split(Forumupload,",")
	for i=0 to ubound(Forumupload)
		if lcase(fileEXT)=lcase(trim(Forumupload(i))) then
			CheckFileExt=true
			exit Function
		else
			CheckFileExt=false
		end if
	next
End Function

'判断路径, 上传中要用
function GetFilePath(FullPath,str)
  If FullPath <> "" Then
    GetFilePath = left(FullPath,InStrRev(FullPath, str))
    Else
    GetFilePath = ""
  End If
End function


%>