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, ">", ">")
fString = replace(fString, " fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), " ")
fString = Replace(fString, CHR(10), " ")
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 if c>255 then
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number0 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) IsValidEmail = false
exit function
end if
for i = 1 to Len(name)
c = Lcase(Mid(name, i, 1))
if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) 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), ".") 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= ""
if ShowTotal=true then
strTemp=strTemp & "共 " & totalnumber & " " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "首页 "
strTemp=strTemp & "上一页 "
end if
if n-currentpage strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "下一页 "
strTemp=strTemp & "尾页"
end if
strTemp=strTemp & " 页次：" & CurrentPage & "/" & n & "页 "
'strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到："
for i = 1 to n
strTemp=strTemp & " if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
strTemp=strTemp & ">第" & i & "页"
next
strTemp=strTemp & ""
end if
strTemp=strTemp & ""
fshowpage=strTemp
end function
'向地址中加入 ? 或 &
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?") if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&") 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 passwordrsLogin("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") 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=""
else
regurl=""
end if
bstr= "站点首页 | 联系我们 | "®url&"博客注册 | 博客登录"
bstr=bstr&""&vbnewline
rem 请尊重版权。
bstr=bstr&"Powered by 888888 1.5 "&vbnewline
bstr=bstr&"© Copyright 2004. All rights reserved. "
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&""
response.Write(bstr)
response.Write vbcrlf &""& vbcrlf
response.Write ""& 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= ""
if ShowTotal=true then
strTemp=strTemp & "共 " & totalnumber & " " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "首页 "
strTemp=strTemp & "上一页 "
end if
if n-currentpage strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "下一页 "
strTemp=strTemp & "尾页"
end if
strTemp=strTemp & " 页次：" & CurrentPage & "/" & n & "页 "
strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到："
for i = 1 to n
strTemp=strTemp & " if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
strTemp=strTemp & ">第" & i & "页"
next
strTemp=strTemp & ""
end if
strTemp=strTemp & ""
response.write strTemp
end sub
sub WriteErrMsg(errmsg)
dim strErr
strErr=strErr & "错误信息" & vbcrlf
strErr=strErr & "" & vbcrlf
strErr=strErr & "" & vbcrlf
strErr=strErr & " 错误信息" & vbcrlf
strErr=strErr & " 产生错误的可能原因：" & errmsg &"" & vbcrlf
strErr=strErr & " << 返回上一页" & vbcrlf
strErr=strErr & "" & vbcrlf
strErr=strErr & "" & 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 = "读取文件失败：" & err.description & "其它可能：确定是否对此文件有读取权限."
err.Clear
Set Fs = Nothing
Exit Function
End If
If Not WriteFile.AtEndOfStream Then
ADODB_LoadFile = WriteFile.ReadAll
If Err Then
GBL_CHK_TempStr = "读取文件失败：" & err.description & "其它可能：确定是否对此文件有读取权限."
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 = "您的主机不支持ADODB.Stream，无法完成操作，请手工进行"
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 = "错误信息：" & err.description & "其它可能：确定是否对此文件有读取权限."
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
%>
