function.asp

博客模块：Blog是继Email、BBS、ICQ后的第四种网络交流方式

<%
dim username,userlevel

function ReplaceBadChar(strChar)
	if strChar="" then
		ReplaceBadChar=""
	else
		ReplaceBadChar=replace(replace(replace(replace(replace(replace(replace(strChar,"'",""),"*",""),"?",""),"(",""),")",""),"<",""),".","")
	end if
end function

function HTMLEncode(fString)
if not isnull(fString) then
    fString = replace(fString, ">", "&gt;")
    fString = replace(fString, "<", "&lt;")
    fString = Replace(fString, CHR(32), "&nbsp;")
    fString = Replace(fString, CHR(9), "&nbsp;")
    fString = Replace(fString, CHR(34), "&quot;")
    fString = Replace(fString, CHR(39), "&#39;")
    fString = Replace(fString, CHR(13), "")
    fString = Replace(fString, CHR(10) & CHR(10), "&nbsp; ")
    fString = Replace(fString, CHR(10), "&nbsp; ")
    HTMLEncode = fString
end if
end function




'求字符串长度。汉字算两个字符，英文算一个字符。
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

Function InterceptString(txt,length)
	dim x,y,ii
	txt=trim(txt)
	x = len(txt)
	y = 0
	if x >= 1 then
		for ii = 1 to x
			if asc(mid(txt,ii,1)) < 0 or asc(mid(txt,ii,1)) >255 then '如果是汉字
				y = y + 2
			else
				y = y + 1
			end if
			if y >= length then
				txt = left(trim(txt),ii) '字符串限长
				exit for
			end if
		next
		InterceptString = txt
	else
		InterceptString = ""
	end if
End Function


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

'**************************************************
'函数名：fshowpage
'作  用：取出“上一页 下一页”等信息
'参  数：sfilename  ----链接地址
'       totalnumber ----总数量
'       maxperpage  ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'**************************************************
function fshowpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
	dim n, i,strTemp,strUrl
	if totalnumber mod maxperpage=0 then
    	n= totalnumber \ maxperpage
  	else
    	n= totalnumber \ maxperpage+1
  	end if
	strTemp= "<table align='center'><tr><td>"
	if ShowTotal=true then 
		strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "&nbsp;&nbsp;"
	end if
	strUrl=JoinChar(sfilename)
  	if CurrentPage<2 then
    		strTemp=strTemp & "首页 上一页&nbsp;"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a>&nbsp;"
  	end if

  	if n-currentpage<1 then
    		strTemp=strTemp & "下一页 尾页"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
  	end if
   	strTemp=strTemp & "&nbsp;页次：" & CurrentPage & "/" & n & "页 "
    'strTemp=strTemp & "&nbsp;" & maxperpage & "" & strUnit & "/页"
	if ShowAllPages=True then
		strTemp=strTemp & "&nbsp;转到：<select name='page' size='1' onchange=""javascript:window.location='" & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"   
    	for i = 1 to n   
    		strTemp=strTemp & "<option value='" & i & "'"
			if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
			strTemp=strTemp & ">第" & i & "页</option>"   
	    next
		strTemp=strTemp & "</select>"
	end if
	strTemp=strTemp & "</td></tr></table>"
	fshowpage=strTemp
end function


'向地址中加入 ? 或 &
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

function CheckUserLogined()
	dim Logined,Password,rsLogin,sqlLogin
	Logined=True
	UserName=DecodeCookie(Request.Cookies(cookiesname)("UserName"))
	Password=DecodeCookie(Request.Cookies(cookiesname)("Password"))
	userlevel=DecodeCookie(Request.Cookies(cookiesname)("userlevel"))
	if userlevel<>"" then userlevel=cint(userlevel)
	if UserName="" then
		Logined=False
	end if
	if Password="" then
		Logined=False
	end if
	if Logined=True then
		username=ReplaceBadChar(trim(username))
		if ot_user then
			sqlLogin="select * from "&ot_usertable&" where "&ot_username&"='" & username & "' and "&ot_password&"='" & password &"'"
			set rsLogin=ot_conn.execute(sqlLogin)
		else
			sqlLogin="select * from [user] where lockuser='false' and Username='" & username & "' and UserPassword='" & password &"'"
			set rsLogin=conn.execute(sqlLogin)
		end if
		if rsLogin.bof and rsLogin.eof then
			Logined=False
		else
			'if password<>rsLogin("UserPassword") then
				'Logined=False
			'end if
			UserName=rsLogin("userName")
			if ot_user then
				set rslogin=conn.execute("select userlevel from [user] where username='"&username&"'")
			end if
			if not rslogin.eof then
				Userlevel=rsLogin("userlevel")
			else
				dim reguserlevel
				dim rs
				set rs=conn.execute("select reguserlevel,admincheckreg from bloginfo")
				reguserlevel=rs("reguserlevel")
				if rs("admincheckreg")="true" then
					reguserlevel=6
				end if
				set rs=nothing
				dim rsreg
				set rsreg=server.CreateObject("adodb.recordset")
				rsreg.open "select * from [user]",conn,1,3
				rsreg.addnew
				rsreg("username")=username
				rsreg("userpassword")="othertable"
				rsreg("userlevel")=reguserlevel
				rsreg("lockuser")="false"
				rsreg("userisbest")="false"
				rsreg("en_blogteam")="true"
				rsreg("adddate")=now()
				rsreg.update
				conn.execute("update bloginfo set usercount=usercount+1")
				rsreg.close
				set rsreg=nothing
				call PutApplicationValue()
				Response.Cookies(cookiesname)("UserName")=CodeCookie(username)
				Response.Cookies(cookiesname)("Password") = CodeCookie(PassWord)
				Response.Cookies(cookiesname)("UserLevel")=CodeCookie(reguserlevel)
				Userlevel=reguserlevel
			end if
		end if
		set rsLogin=nothing
	end if
	CheckUserLogined=Logined
end function

sub bottom()
dim etime,bstr,regurl
etime=timer()
if Application(cachename&"siterefu")<siterefu_num then
	Application.Lock
	Application(cachename&"siterefu")=siterefu_num
	Application.unlock
end if
Application.Lock
Application(cachename&"siterefu")=Application(cachename&"siterefu")+1
Application.unlock
siterefu_num=Application(cachename&"siterefu")
if ot_user then
	regurl="<a style='color: #444444' href='"&ot_regurl&"' target='_blank'>"
else
	regurl="<a style='color: #444444' href='user_reg.asp'>"
end if
bstr= "<center><a style='color: #444444' href='index.asp'>站点首页</a> | <a style='color: #444444' href='mailto:"&webmasteremail&"'>联系我们</a> | "&regurl&"博客注册</a> | <a style='color: #444444' href='user_login.asp'>博客登录</a><br><br>"
bstr=bstr&"<span style='color: #444444; font-size: 11px; font-family: Tahoma, Arial'>"&vbnewline
rem 请尊重版权。
bstr=bstr&"Powered by <a href='http://www.123.net' style='color: #444444' target='_blank'><b>888888 </b> <b style='color:#CC3300'>1.5 </b></a> "&vbnewline
bstr=bstr&"&copy; Copyright 2004. All rights reserved. <br>"
if blog_showruntime="true" and blog_showrefu="true" then
	bstr=bstr&"Processed in "&FormatNumber((etime-startime),3,True)&" second(s), page refreshed "&siterefu_num&" times."
else
	if blog_showruntime="true" then
		bstr=bstr&"Processed in "&FormatNumber((etime-startime)*1000,3)&" second(s)."
	end if
	if blog_showrefu="true" then
		bstr=bstr& "Page refreshed "&siterefu_num&" times."
	end if
end if
bstr=bstr&"</center>"
response.Write(bstr)
response.Write vbcrlf &"</body>"& vbcrlf
response.Write "</html>"& vbcrlf
call closeconn()
end sub


'**************************************************
'过程名：showpage
'作  用：显示“上一页 下一页”等信息
'参  数：sfilename  ----链接地址
'       totalnumber ----总数量
'       maxperpage  ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'**************************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
	dim n, i,strTemp,strUrl
	if totalnumber mod maxperpage=0 then
    	n= totalnumber \ maxperpage
  	else
    	n= totalnumber \ maxperpage+1
  	end if
  	strTemp= "<table align='center'><tr><td>"
	if ShowTotal=true then 
		strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "&nbsp;&nbsp;"
	end if
	strUrl=JoinChar(sfilename)
  	if CurrentPage<2 then
    		strTemp=strTemp & "首页 上一页&nbsp;"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a>&nbsp;"
  	end if

  	if n-currentpage<1 then
    		strTemp=strTemp & "下一页 尾页"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
  	end if
   	strTemp=strTemp & "&nbsp;页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
    strTemp=strTemp & "&nbsp;<b>" & maxperpage & "</b>" & strUnit & "/页"
	if ShowAllPages=True then
		strTemp=strTemp & "&nbsp;转到：<select name='page' size='1' onchange=""javascript:window.location='" & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"   
    	for i = 1 to n   
    		strTemp=strTemp & "<option value='" & i & "'"
			if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
			strTemp=strTemp & ">第" & i & "页</option>"   
	    next
		strTemp=strTemp & "</select>"
	end if
	strTemp=strTemp & "</td></tr></table>"
	response.write strTemp
end sub


sub WriteErrMsg(errmsg)
	dim strErr
	strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
	strErr=strErr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
	strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf
	strErr=strErr & "  <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf
	strErr=strErr & "  <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & errmsg &"</td></tr>" & vbcrlf
	strErr=strErr & "  <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'>&lt;&lt; 返回上一页</a></td></tr>" & vbcrlf
	strErr=strErr & "</table>" & vbcrlf
	strErr=strErr & "</body></html>" & vbcrlf
	response.write strErr
end sub

Function ChkPost()
	Dim server_v1,server_v2
	Chkpost=False 
	server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
	server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
	If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True 
End Function

Function ADODB_LoadFile(ByVal File)

	On Error Resume Next
	Dim objStream,FSFlag,fs,WriteFile
	FSFlag = 1
	If DEF_FSOString <> "" Then
		Set fs = Server.CreateObject(DEF_FSOString)
		If Err Then
			FSFlag = 0
			Err.Clear
			Set fs = Nothing
		End If
	Else
		FSFlag = 0
	End If
	
	If FSFlag = 1 Then
		Set WriteFile = fs.OpenTextFile(Server.MapPath(File),1,True)
		If Err Then
			GBL_CHK_TempStr = "<br>读取文件失败：" & err.description & "<br>其它可能：确定是否对此文件有读取权限."
			err.Clear
			Set Fs = Nothing
			Exit Function
		End If
		If Not WriteFile.AtEndOfStream Then
			ADODB_LoadFile = WriteFile.ReadAll
			If Err Then
				GBL_CHK_TempStr = "<br>读取文件失败：" & err.description & "<br>其它可能：确定是否对此文件有读取权限."
				err.Clear
				Set Fs = Nothing
				Exit Function
			End If
		End If
		WriteFile.Close
		Set Fs = Nothing
	Else
		Set objStream = Server.CreateObject("ADODB.Stream")
		If Err.Number=-2147221005 Then 
			GBL_CHK_TempStr = "<div align='center'>您的主机不支持ADODB.Stream，无法完成操作，请手工进行</div>"
			Err.Clear
			Set objStream = Noting
			Exit Function
		End If
		With objStream
			.Type = 2
			.Mode = 3
			.Open
			.LoadFromFile Server.MapPath(File)
			.Charset = "GB2312"
			.Position = 2
			ADODB_LoadFile = .ReadText
			.Close
		End With
		Set objStream = Nothing
	End If
	If Err Then
		GBL_CHK_TempStr = "<br>错误信息：" & err.description & "<br>其它可能：确定是否对此文件有读取权限."
		err.Clear
		Set Fs = Nothing
		Exit Function
	End If

End Function

Function CodeCookie(str)
if passcookies then
	Dim i
	Dim StrRtn
	For i = Len(Str) to 1 Step -1
		StrRtn = StrRtn & Ascw(Mid(Str,i,1))
		If (i <> 1) Then StrRtn = StrRtn & "a"
	Next
	CodeCookie = StrRtn
else
	CodeCookie=str
end if
End Function

Function DecodeCookie(Str)
if passcookies then
	Dim i
	Dim StrArr,StrRtn
	StrArr = Split(Str,"a")
	For i = 0 to UBound(StrArr)
		If isNumeric(StrArr(i)) = True Then
			StrRtn = Chrw(StrArr(i)) & StrRtn
		Else
			StrRtn = Str
			Exit Function
		End If
	Next
	DecodeCookie = StrRtn
else
	DecodeCookie=str
end if
End Function

%>