www.gusucode.com > CC校友录贴吧 CCBar源码程序asp编程 > inc/inc_pub_func.asp
<%
'===================================================================
'= ASP FILENAME : /inc/pub_func.asp
'= CREATED TIME : AUG,6,2003
'= LAST MODIFIED: AUG,6,2003
'= VERSION INFO : CCASP Framework Ver 2.0.1 ALL RIGHTS RESERVED BY www.cclinux.com
'= DESCRIPTION : 通用主体函数库
'= Change Log:
'===================================================================
%>
<!-- #include file="../inc/inc_debug.asp" -->
<%
'=============== FUNCTION BODY BEGIN ===============================
'===================================================================
'= Sub : SiteHead(strPageName)
'= Time : Created At 9,11,2003
'= Input :
'= Output :
'= Called by : All pages in this website
'= Calls :
'= Description : All page's <head>
'===================================================================
Sub SiteHead(strPageName)
Const CONST_PAGE_STYLE = ",,>> , <<,:: , ::,^-^,^-^,::::::,::::::"
Dim strPageStyle,intStyle
Dim strHtmlCode
'== Style of page's IE title
strPageStyle = split(CONST_PAGE_STYLE,",")
intTitleStyle = GBL_intTitleStyle
Response.Write strHtmlCode
strHtmlCode = ""
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<meta http-equiv="Content-Language" content="zh-cn">
<meta name="description" content="<% =GBL_strSiteName %>">
<meta name="keywords" content="校友网,校友聚会,校友录，校友录,校友,学子，游子,<% =GBL_strClassName %>,<% =CONST_WEB_VER %>">
<title>
<%
=strPageStyle(intTitleStyle*2-2) & GBL_strSiteName & " -- " & strPageName & strPageStyle(intTitleStyle*2-1)
%>
</title>
<link rel="stylesheet" type="text/css" href="<% =GBL_strHomeUrl %>style/<% =GBL_strStyle %>/style.css" >
<style>
</style>
</head>
<%
Call HeadSpecialStyle(strPageName)
End Sub
'================ End of Sub SiteHead() ============================
'===================================================================
'= Sub : HeadSpecialStyle(strPageName)
'= Time : Created At 10,10,2003
'= Input :
'= Output :
'= Called by : All pages in this website
'= Calls :
'= Description : Some page's <head> special style
'===================================================================
Sub HeadSpecialStyle(strPageName)
%>
<!-- 提示窗口 层定义 -->
<div id='divClew' style='Z-INDEX: 2; VISIBILITY: hidden; WIDTH: 1px; POSITION: absolute; HEIGHT: 1px; '></div>
<%
End Sub
'================= End of Sub HeadSpecialStyle() ===================
'===================================================================
'= Sub : SiteBottom(strPageName)
'= Time : Created At 10,11,2003
'= Input :
'= Output :
'= Called by : All pages in this website
'= Calls :
'= Description : All page's bottom infomation(such as copyright)
'===================================================================
Sub SiteBottom(strPageName)
Dim strShowView
strShowView = "从" & FormatDateTime (GBL_strHomeViewBegin,1) & "起已有" & GBL_intHomeViewCount & "人次访问过本页"
If GBL_strUserAuthen = 1 Then
strShowView = strShowView & ",昨日:" & GBL_intHomeLastViewCount & ",今日:" & GBL_intHomeTodayViewCount
End If
%>
<center>
<br>
<a href="#" onClick="window.external.addFavorite('<%=GBL_strSiteHome%>','<%=GBL_strSiteName%>')" title="将<%=GBL_strSiteName%>添加到收藏夹">加入收藏</a> | 关于本站 |
<a href="#" onClick="this.style.behavior='url(#default#homepage)';this.setHomePage('<%=GBL_strSiteHome%>');" title="将设置<%=GBL_strSiteName%>为浏览器首页">设为首页</a> | <a href="mailto:<%=GBL_strAdminEmail%>" title="给<%=GBL_strSiteName%>的管理员发邮件">与我联系</a>
| <a href="<% =GBL_strHomeURL%>admin/index.asp" title="管理员专用">管理入口</a>
<br>
Copyright <font size=2>©</font> 2002-<%=year(date)%> <% =GBL_strClassName %> 版权所有
<a href="http://www.cclinux.com" target=_blank><% =CONST_WEB_VER %></font></a>
<%
'== 04/02
If CONST_PAGE_FILE = "/index1.asp" Then
Response.Write "<br>" & strShowView
End If
%>
<br>
<%
GBL_PageExeTime = FormatNumber(cCur(Timer - GBL_PageExeTime),3,True)
Response.Write " Server:" & GBL_PageExeTime*1000 & "Ms"
If CTL_DB_NUM Then
Response.Write " DB:" & GBL_intDBNum
End If
%>
<script language=javascript>
// end flag of web finished
EndFlag = 1;
</script>
</center>
<%
'== debug for db
Call ShowDBDebug(clsPubDB)
End Sub
'====================================================================
'= Sub : ShowFuncSwitch(strPageName)
'= Time : Created At 9,13,2003
'= Input :
'= Output :
'= Called by : PageMainStyle(strPageName),HomeMainStyle(strPageName)
'= Calls : None
'= Description : 根据不同的页面请求来确定网页栏目显示和数据处理的分拣主函数
'====================================================================
Sub ShowFuncSwitch(strPageName,intFlag)
'== intFlag : 0－MainColumn 1－Title 2－SmallColumn 3－Obligate
Dim strFuncName
Dim arrTmp
Dim intTop,intBg,intBottom
Dim strTop,strBg,strBottom
Dim strMenu,strFunc
If strPageName = "/err.asp" Then
Call ShowFuncSingle("ShowErr")
Exit Sub
End If
If strPageName = "/succ.asp" Then
Call ShowFuncSingle("ShowSucc")
Exit Sub
End If
strFuncName = Trim(Request("action"))
'== web page trans
strFunc = strFuncName
If CONST_TRANS_SHOW = 0 Then
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_TRANS"
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField "TRANS_FUNC_MENU",""
clsPubDB.Where = "TRANS_NAME='" & strFuncName & "' AND TRANS_TYPE=1 AND TRANS_STYLE='" & GBL_strStyle & "'"
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"show func","ES_ERR")
If clsPubDB.intRSNum = 0 Then
Call ResultExecute(10,"show func","ES_ERR")
Exit Sub
End If
strMenu = clsPubDB.objPubRS("TRANS_FUNC_MENU")
Else
strMenu = GBL_strDefMenu
End If
If strMenu <> "" Then
arrTmp = Split(strMenu,"|")
For i = LBound(arrTmp) To UBound(arrTmp)
Call ShowFuncOne(arrTmp(i))
Response.Write "<br>"
Next
End If
Call ShowFuncOne(strFunc)
End Sub
'================ End of Sub ShowFunctionSwitch() ===================
'====================================================================
'= Sub : ShowFuncOne(strFuncName)
'= Time : Created At 9,13,2003
'= Input : 发交易请求名(strPageName)
'= Output :
'= Called by :
'= Calls : None
'= Description : 根据不同的页面请求来确定网页栏目显示和数据处理的分拣主函数
'= Up History : 2004/04/29 去掉本函数功能 提高速度
'====================================================================
Sub ShowFuncOne(strFuncName)
Execute strFuncName & "()"
End Sub
'============== End of Func ShowFuncOne(strFuncName) ===============
Sub ActionView(Action)
Execute Action & "()"
End Sub
'===================================================================
'= Function : ExecFuncSwitch(strPageName)
'= Time : Created At SEP,2,2003
'= Input : The page file name
'= Called by : All index.asp
'= Calls :
'= Description : Data execute(no display)
'===================================================================
Sub ExecFuncSwitch(strPageName)
Dim strGetPost
strGetPost = Trim(Request.QueryString("action"))
'== check page submit from .
If Not CheckPageSubmit Then
Call ResultExecute(E_USER_PUB,"禁止从站点外部提交数据","ES_ERR")
Exit Sub
End If
Execute strGetPost & "()"
End Sub
'============== End of Function BoardExeFunction() ==================
'====================================================================
'= Function : CheckPageSubmit()
'= Time : Created At Apr,18,2003
'= Input : None
'= Output : None
'= Called by :
'= Calls : Server Functions
'= Return : true or false
'= Description : 防止外部页面数据提交
'====================================================================
Function CheckPageSubmit()
Dim strPrePage,strLocalSvr
strPrePage = Cstr(Request.ServerVariables("HTTP_REFERER"))
strLocalSvr = Cstr(Request.ServerVariables("SERVER_NAME"))
If Mid(strPrePage,8,Len(strLocalSvr)) <> strLocalSvr And strPrePage <> "" Then
CheckPageSubmit = FALSE
Else
CheckPageSubmit = TRUE
End If
End Function
'================== End of Func CheckPageSubmit() ===================
'===================================================================
'= Function : CheckPostExist(strInPost)
'= Time : Created At Apr,04,2004
'= Input : The page file name
'= Called by :
'= Calls :
'= Description : check the post is or not exist
'===================================================================
Sub CheckPostExist(strInPost)
Dim arrTmp,strGetPagePost
Dim i
strGetPagePost = Trim(Request.QueryString("action"))
If strGetPagePost = "" Then
Call ResultExecute(E_USER_PUB,"错误的页面栏目请求：<br>NULL","ES_ERR")
Exit Sub
End If
arrTmp = Split(strInPost,",")
For i = LBound(arrTmp) To UBound(arrTmp)
If strGetPagePost = arrTmp(i) Then
Exit Sub
End If
Next
Call ResultExecute(E_USER_PUB,"错误的页面栏目请求：<br>" & strGetPagePost,"ES_ERR")
End Sub
'============== End of Function CheckPostExist() ====================
'====================================================================
'= Sub : ExecOrShowSwitch(strPageName,strShowFunc,strShowDataFunc,strExecFunc)
'= Time : Created At SEP,2,2003
'= Input :
'= Called by : All main page
'= Calls :
'= Description : 用户请求校验与分拣
'===================================================================
Sub ActionFilter(strPageName,Action)
Dim strGetPost
Dim intGetAuthen,intGetType,intGetStatus,strGetDesc
Dim strTmp,strTmp1
strGetDesc = "该功能"
'== 更新在线用户情况
Call GetNowOnline ()
'== Get transation request
strGetPost = Action
If strGetPost = "" Then
Call ResultExecute(10,"","ES_ERR")
Exit Sub
End If
'== check user access
If CTL_USER_ACCESS Then
If GBL_strUserAccess <> "" And IsNumeric(GBL_strUserAccess) Then
GBL_strUserAccess = Cint(GBL_strUserAccess)
If GBL_strUserAccess = 0 And Left(strGetPost,8) = "FormSave" Then
Call ResultExecute(E_USER_PUB,"对不起,您没有提交权限","ES_ERR")
Exit Sub
End If
End If
End If
'== Get this trans code authen,status,type
If CONST_TRANS_CTL = 0 Then
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_TRANS"
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField "TRANS_STATUS,TRANS_AUTHEN,TRANS_TYPE,TRANS_DESC",""
clsPubDB.Where = "TRANS_CODE_TYPE='" & strTCodeType & "' AND TRANS_NAME='" & strGetPost & "' AND TRANS_STYLE='" & GBL_strStyle & "'"
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"get trans","ES_ERR")
If clsPubDB.intRSNum = 0 Then
Call ResultExecute(10,"Now Trans:" & strGetPost,"ES_ERR")
Exit Sub
End If
intGetAuthen = clsPubDB.objPubRS("TRANS_AUTHEN")
intGetStatus = clsPubDB.objPubRS("TRANS_STATUS")
intGetType = clsPubDB.objPubRS("TRANS_TYPE")
strGetDesc = clsPubDB.objPubRS("TRANS_DESC")
Else
strTmp = GetConfig(Application(GBL_strCookieURL & "APP_TRANS"),strGetPost)
If strTmp = "" Then
Call ResultExecute(E_USER_PUB,"错误的页面栏目请求","ES_ERR")
Exit Sub
End If
'== divider 0x1e
strTmp1 = Split(strTmp,CONST_DIVIDER2)
intGetAuthen = Cint(strTmp1(0))
intGetStatus = Cint(strTmp1(1))
intGetType = Cint(strTmp1(2))
End If
'== Check this trans open status
If intGetStatus = 1 Then
Call ResultExecute(16,strGetDesc,"ES_ERR")
Exit Sub
End If
'== Check this trans auThen status
Call AuThenCheck(intGetAuthen)
'== Do function of this trans
If intGetType = 0 Then
'== Update view counter
'Call ViewCount(strPageName)
Call ExecFuncSwitch(strPageName)
ElseIf intGetType = 1 Then
'== Update view counter
Call ViewCount(strPageName)
'== Wide content execute
If Left(CONST_PAGE_FILE, 6) = "forum/" Then
Call PageMainStyleForum(strPageName)
ElseIf CONST_PAGE_FILE = "meet/meet_detail.asp" Then
Call PageMainStyleMeet(strPageName)
Else
Response.Write "sss"
Call PageMainStyle(strPageName)
End If
Else
Call ResultExecute(10,strGetPost,"ES_ERR")
End If
End Sub
'============== End of Sub ExecOrShowSwitch() ======================
'====================================================================
'= Sub : ExecOrShowSwitch(strPageName,strShowFunc,strShowDataFunc,strExecFunc)
'= Time : Created At SEP,2,2003
'= Input :
'= Called by : All main page
'= Calls :
'= Description : Show or execute switch function
'===================================================================
Sub ExecOrShowSwitch(strPageName,strTCodeType)
Dim strGetPost
Dim intGetAuthen,intGetType,intGetStatus,strGetDesc
Dim strTmp,strTmp1
strGetDesc = "该功能"
'== Get now online guest and user
Call GetNowOnline ()
'== Get transation request
strGetPost = Trim(Request.QueryString("action"))
If strGetPost = "" Then
Call ResultExecute(10,"","ES_ERR")
Exit Sub
End If
'== check user access
If CTL_USER_ACCESS Then
If GBL_strUserAccess <> "" And IsNumeric(GBL_strUserAccess) Then
GBL_strUserAccess = Cint(GBL_strUserAccess)
If GBL_strUserAccess = 0 And Left(strGetPost,8) = "FormSave" Then
Call ResultExecute(E_USER_PUB,"对不起,您没有提交权限","ES_ERR")
Exit Sub
End If
End If
End If
'== Get this trans code authen,status,type
If CONST_TRANS_CTL = 0 Then
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_TRANS"
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField "TRANS_STATUS,TRANS_AUTHEN,TRANS_TYPE,TRANS_DESC",""
clsPubDB.Where = "TRANS_CODE_TYPE='" & strTCodeType & "' AND TRANS_NAME='" & strGetPost & "' AND TRANS_STYLE='" & GBL_strStyle & "'"
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"get trans","ES_ERR")
If clsPubDB.intRSNum = 0 Then
Call ResultExecute(10,"Now Trans:" & strGetPost,"ES_ERR")
Exit Sub
End If
intGetAuthen = clsPubDB.objPubRS("TRANS_AUTHEN")
intGetStatus = clsPubDB.objPubRS("TRANS_STATUS")
intGetType = clsPubDB.objPubRS("TRANS_TYPE")
strGetDesc = clsPubDB.objPubRS("TRANS_DESC")
Else
strTmp = GetConfig(Application(GBL_strCookieURL & "APP_TRANS"),strGetPost)
If strTmp = "" Then
Call ResultExecute(E_USER_PUB,"错误的页面栏目请求","ES_ERR")
Exit Sub
End If
'== divider 0x1e
strTmp1 = Split(strTmp,CONST_DIVIDER2)
intGetAuthen = Cint(strTmp1(0))
intGetStatus = Cint(strTmp1(1))
intGetType = Cint(strTmp1(2))
End If
'== Check this trans open status
If intGetStatus = 1 Then
Call ResultExecute(16,strGetDesc,"ES_ERR")
Exit Sub
End If
'== Check this trans auThen status
Call AuThenCheck(intGetAuthen)
'== Do function of this trans
If intGetType = 0 Then
'== Update view counter
'Call ViewCount(strPageName)
Call ExecFuncSwitch(strPageName)
ElseIf intGetType = 1 Then
'== Update view counter
Call ViewCount(strPageName)
'== Wide content execute
If Left(CONST_PAGE_FILE, 6) = "forum/" Then
Call PageMainStyleForum(strPageName)
ElseIf CONST_PAGE_FILE = "meet/meet_detail.asp" Then
Call PageMainStyleMeet(strPageName)
Else
Call PageMainStyle(strPageName)
End If
Else
Call ResultExecute(10,strGetPost,"ES_ERR")
End If
End Sub
'============== End of Sub ExecOrShowSwitch() ======================
'===================================================================
'= Sub : ShowPage(intTotalNumber,intMaxPerPage,intCurrentPage,strFileName)
'= Time : Created At May,17,2003
'= Input : None
'= Called by : ShowBoard(),etc
'= Calls : None
'= Description : Form feed show
'===================================================================
Sub ShowPage(intTotalNumber,intMaxPerPage,intCurrentPage,strFileName)
Dim n
Dim strAddType '== 附加传输值
'== 是否有变量传递
strAddType = Trim(Request.QueryString("pstAddType"))
strAddType = ""
If intToTalNumber Mod intMaxPerPage = 0 Then
n = intToTalNumber \ intMaxPerPage
Else
n = intToTalNumber \ intMaxPerPage + 1
End If
Response.Write "<tr align=right><td><table><tr><td>"
Response.Write "<form method='Post' action=" & strFileName & " name='frmGo' id='frmGo' onsubmit='return CheckGoForm()'>"
Response.Write "<p align=center>"
If intCurrentPage < 2 Then
Response.Write "首页 上一页 "
Else
Response.Write "<a href=" & strFileName & "&intPageNow=1" & strAddType & "> 首页</a> "
Response.Write "<a href=" & strFileName & "&intPageNow=" & intCurrentPage - 1 & strAddType & ">上一页 </a>"
End If
If n - intCurrentPage < 1 Then
Response.Write "下一页 尾页 "
Else
Response.Write "<a href=" & strFileName & "&intPageNow=" & (intCurrentPage + 1) & strAddType & ">"
Response.Write "下一页</a> <a href=" & strFileName & "&intPageNow=" & n & strAddType & ">尾页 </a>"
End If
Response.Write "第<font color=red>" & intCurrentPage & "</font>/" & n & "页 "
Response.Write "" & intTotalNumber & "条 " & intMaxPerPage & "条/页 "
Response.Write " <input type='text' name='intPageNow' size=2 maxlength=4 value=" & intCurrentPage & " >"
Response.Write " <input type='submit' value='Go' name='subGo' class='CSS_IPT_BTN_SMALL'></p></form>"
Response.Write "</td></tr></table></td></tr>"
End Sub
'============== End of Sub ShowPage() ==============================
'===================================================================
'= Sub : ShowPage2(intTotalNumber,intMaxPerPage,intCurrentPage,strFileName,intShowFlag)
'= Time : Created At May,17,2003
'= Input : None
'= Called by : ShowBoard(),etc
'= Calls : None
'= Description : Form feed show
'===================================================================
Sub ShowPage2(intTotalNumber,intMaxPerPage,intCurrentPage,strFileName,intShowFlag)
Dim n
Dim strAddType '== 附加传输值
'== 是否有变量传递
strAddType = Trim(Request.QueryString("pstAddType"))
strAddType = ""
If intToTalNumber Mod intMaxPerPage = 0 Then
n = intToTalNumber \ intMaxPerPage
Else
n = intToTalNumber \ intMaxPerPage + 1
End If
Response.Write "<table width=100% ><tr align=center><td align=center>"
Response.Write "<form action=" & strFileName & " name=frmGo2 id='frmGo2' >"
Response.Write "<p align=center>"
'Response.Write "共" & n & "页 "
If intCurrentPage < 2 Then
Response.Write "上一页 "
Else
'Response.Write "<a href=" & strFileName & "&intPageNow=1" & strAddType & "> 首页</a> "
Response.Write "<a href=" & strFileName & "&intPageNow=" & intCurrentPage - 1 & strAddType & ">上一页</a> "
End If
If n - intCurrentPage < 1 Then
Response.Write "下一页 "
Else
Response.Write "<a href=" & strFileName & "&intPageNow=" & (intCurrentPage + 1) & strAddType & ">"
Response.Write "下一页</a> "
'Response.Write "<a href=" & strFileName & "&intPageNow=" & n & strAddType & ">尾页 </a>"
End If
If intShowFlag = 1 Then
Response.Write "<font color=red>" & intCurrentPage & "</font>/" & n & " "
End If
Response.Write "" & intTotalNumber & "条 " & intMaxPerPage & "条/页 "
If intShowFlag <> 1 Then
Response.Write "<select name=strPageSelect onchange=""document.location.href='" & strFileName & "&intPageNow=" & "'+document.frmGo2.strPageSelect.options[document.frmGo2.strPageSelect.selectedIndex].value"">" & strAddType
For i = 1 To n
If i = intCurrentPage Then
Response.Write "<option value=" & i & " selected>第" & i & "页</option>"
Else
Response.Write "<option value=" & i & ">第" & i & "页</option>"
End If
Next
Response.Write "</select>"
End If
Response.Write "</p></form>"
Response.Write "</td></tr></table>"
End Sub
'============== End of Sub ShowPage2() ==============================
'===================================================================
'= Function : AuThenCheck(intAuThen)
'= Time : Created At Nov,12,2003
'= Input : None
'= Called by :
'= Calls :
'= Description : user check
'===================================================================
Function AuThenCheck(intAuThen)
Dim intAuthenNow
Dim strUser,strPwd
strUser = Trim(Request.Cookies(GBL_strCookieURL)("user"))
strPwd = Trim(Request.Cookies(GBL_strCookieURL)("pass"))
If Not IsEmpty(Session(GBL_strCookieURL & "SEN_strUserAuThen")) Then
If IsNumeric(Session(GBL_strCookieURL & "SEN_strUserAuThen")) Then
intAuthenNow = Cint(Session(GBL_strCookieURL & "SEN_strUserAuThen"))
Else
intAuthenNow = -1
End If
Else
intAuthenNow = -1
End If
'== open for all (include guest)
If intAuThen = 9 Then
If CONST_PAGE_FILE = "user/user_login_form.asp" Or CONST_PAGE_FILE = "user/user_announce.asp" Or CONST_PAGE_FILE = "user/user_reg_form.asp" Then
Exit Function
End If
'== check cookie exsit
If (Not IsEmpty(strUser)) And _
(strUser <> "") And _
Not IsEmpty(strPwd) And _
(strPwd <> "") And _
(IsEmpty(Session(GBL_strCookieURL & "SEN_UserId")) Or _
Session(GBL_strCookieURL & "SEN_UserId") = "") _
Then
If CheckPass(strUser,strPwd,1) Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "user/user_info_show.asp?action=ShowUserAllInfo"
Exit Function
Else
'== destory cookie
Response.Cookies(GBL_strCookieURL)("user") = ""
Response.Cookies(GBL_strCookieURL)("pass") = ""
Response.Cookies(GBL_strCookieURL).Expires = Date - 1
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "user/user_login_form.asp?action=FormUserLogin"
Exit Function
End If
Else
Exit Function
End If
End If
'== check the comm user
If IsEmpty(Session(GBL_strCookieURL & "SEN_strUserRealName")) Or _
IsEmpty(Session(GBL_strCookieURL & "SEN_UserId")) Or _
IsEmpty(Session(GBL_strCookieURL & "SEN_strUserAccount")) Or _
Session(GBL_strCookieURL & "SEN_strUserRealName") = "" Or _
Session(GBL_strCookieURL & "SEN_UserId") = "" Or _
Session(GBL_strCookieURL & "SEN_strUserAccount") = "" Then
If CheckPass(strUser,strPwd,1) Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "user/user_info_show.asp?action=ShowUserAllInfo"
Exit Function
Else
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "user/user_login_form.asp?action=FormUserLogin"
Exit Function
End If
End If
'== check the administrator
If intAuThen = 1 Then
If intAuthenNow <> intAuThen Then
Call ResultExecute(18,"管理员权限","ES_ERR")
Exit Function
End If
End If
End Function
'=============== End of Function AuThenCheck() ======================
'===================================================================
'= Function : CheckPass(strUserName,strUserPassword,intFlag)
'= Time : Created At Jun,16,2004
'= Input : intFlag : 0 -- error redirect
'= 1 -- no error redirect
'= Output :
'= Called by :
'= Calls :
'= Return :
'= Description : check username and pwd by login and cookie
'===================================================================
Function CheckPass(strUserName,strUserPassword,intFlag)
CheckPass = False
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_USER"
clsPubDB.SQLType = "SELECT"
clsPubDB.Where = "USER_ACCOUNT='" & strUserName & "'"
clsPubDB.AddField "USER_REALNAME,USER_ID,USER_IS_MASTER,USER_AUTHEN,USER_PASSWORD,USER_ACCOUNT",""
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"","ES_ERR")
If clsPubDB.intRSNum = 0 Then
If intFlag = 0 Then
Call ResultExecute(2,"check pass1","ES_ERR")
End If
CheckPass = False
Exit Function
Else
If strUserPassword <> clsPubDB.objPubRS("USER_PASSWORD") Then
If intFlag = 0 Then
Call ResultExecute(3,"check pass2","ES_ERR")
End If
CheckPass = False
Exit Function
Else
'== chech whether or not to verify
If clsPubDB.objPubRS("USER_AUTHEN") = 8 Then
If intFlag = 0 Then
Call ResultExecute(E_USER_PUB,"对不起,您还尚未通过校友批准<br>请等待批准或联系管理员","ES_ERR")
End If
CheckPass = False
Exit Function
End If
'== Get login user infomation now
Session.Contents.RemoveAll() '==???
strRealName = clsPubDB.objPubRS("USER_REALNAME")
UserId = clsPubDB.objPubRS("USER_ID")
strAccount = clsPubDB.objPubRS("USER_ACCOUNT")
strAuthen = Cint(clsPubDB.objPubRS("USER_AUTHEN"))
strIsMaster = clsPubDB.objPubRS("USER_IS_MASTER")
'== Check user access
If CTL_USER_ACCESS Then
If Not CheckUserAccess(strUserName,strClew1) Then
Call ResultExecute(E_USER_PUB,strClew1,"ES_ERR")
Exit Function
End If
End If
'== Get login user infomation now
Session(GBL_strCookieURL & "SEN_strUserRealName") = strRealName
Session(GBL_strCookieURL & "SEN_UserId") = UserId
Session(GBL_strCookieURL & "SEN_strUserAccount") = strAccount
Session(GBL_strCookieURL & "SEN_strUserAuthen") = strAuthen
Session(GBL_strCookieURL & "SEN_strIsMaster") = strIsMaster
'== Update login user infomation now
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_USER"
clsPubDB.SQLType = "UPDATE"
clsPubDB.Where = "USER_ACCOUNT='" & strUserName & "'"
clsPubDB.AddField "USER_LAST_TIME",now()
clsPubDB.AddSet "USER_LOGIN_COUNT = USER_LOGIN_COUNT + 1"
'== Get real ip
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") <> "" Then
clsPubDB.AddField "USER_LAST_IP", Request.ServerVariables("HTTP_X_FORWARDED_FOR")
Else
clsPubDB.AddField "USER_LAST_IP", Request.ServerVariables("REMOTE_ADDR")
End If
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"","ES_ERR")
'== Update level
Call UpdateLevel(GBL_intLoginLevel)
CheckPass = True
End If
End If
End Function
'===================================================================
'= Function : CheckUserAccess()
'= Time : Created At Jun,28,2004
'= Called by :
'= Calls :
'= Return :
'= Description : check user access to web
'===================================================================
Function CheckUserAccess(strUserAccount,ByRef strClew)
CheckUserAccess = True
'== check user account
clsPubDB.Clear()
clsPubDB.AllSQL = "SELECT * FROM CLASS_ACCESS WHERE ACCESS_CONTENT= '" & strUserAccount & "' AND ACCESS_ACTION_TYPE=0 "
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"check user access","ES_ERR")
If clsPubDB.intRSNum > 0 Then
If clsPubDB.objPubRS("ACCESS_TYPE") = 1 Then
strClew = "您被禁止登陆,"
If clsPubDB.objPubRS("ACCESS_DESC") <> "" Then
strClew = strClew & "原因是:<br>" & clsPubDB.objPubRS("ACCESS_DESC")
End If
CheckUserAccess = False
Exit Function
ElseIf clsPubDB.objPubRS("ACCESS_TYPE") = 0 Then
Session(GBL_strCookieURL & "SEN_strUserAccess") = 0
CheckUserAccess = True
Exit Function
End If
End If
'== check user ip area
'== Get real ip
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") <> "" Then
strUserIp = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
Else
strUserIp = Request.ServerVariables("REMOTE_ADDR")
End If
arrUserIp = Split(strUserIp,".")
If Not IsArray(arrUserIp) Then
Exit Function
End If
'== check ip exta
clsPubDB.Clear()
clsPubDB.AllSQL = "SELECT * FROM CLASS_ACCESS WHERE ACCESS_CONTENT='" & strUserIp & "' AND ACCESS_ACTION_TYPE=1 "
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"check user access","ES_ERR")
If clsPubDB.intRSNum > 0 Then
If clsPubDB.objPubRS("ACCESS_TYPE") = 1 Then
strClew = "您被禁止登陆,"
If clsPubDB.objPubRS("ACCESS_DESC") <> "" Then
strClew = strClew & "原因是:<br>" & clsPubDB.objPubRS("ACCESS_DESC")
End If
CheckUserAccess = False
Exit Function
ElseIf clsPubDB.objPubRS("ACCESS_TYPE") = 0 Then
Session(GBL_strCookieURL & "SEN_strUserAccess") =_
Cint(clsPubDB.objPubRS("ACCESS_TYPE"))
Exit Function
End If
End If
'== check ip D
clsPubDB.Clear()
clsPubDB.AllSQL = "SELECT * FROM CLASS_ACCESS WHERE ACCESS_CONTENT LIKE '%" & arrUserIp(0) & "." & arrUserIp(1) & "." & arrUserIp(2) & "%' AND ACCESS_ACTION_TYPE=2 "
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"check user access","ES_ERR")
If clsPubDB.intRSNum > 0 Then
If clsPubDB.objPubRS("ACCESS_TYPE") = 1 Then
strClew = "您被禁止登陆,"
If clsPubDB.objPubRS("ACCESS_DESC") <> "" Then
strClew = strClew & "原因是:<br>" & clsPubDB.objPubRS("ACCESS_DESC")
End If
CheckUserAccess = False
Exit Function
ElseIf clsPubDB.objPubRS("ACCESS_TYPE") = 0 Then
Session(GBL_strCookieURL & "SEN_strUserAccess") =_
Cint(clsPubDB.objPubRS("ACCESS_TYPE"))
Exit Function
End If
End If
End Function
'=============== End of Func CheckUserAccess() =====================
'===================================================================
'= Function : AdminCheck()
'= Time : Created At DEC,20,2003
'= Input : None
'= Called by :
'= Calls :
'= Description : adminstrator check
'===================================================================
Function AdminCheck()
If Session(GBL_strCookieURL & "SEN_strUserAuThen") <> 1 Or IsEmpty(Session(GBL_strCookieURL & "SEN_strUserAuThen")) Then
AdminCheck = FALSE
Exit Function
End If
AdminCheck = TRUE
End Function
'=============== End of Function AdminCheck() =======================
'====================================================================
'= Function : AdminCheckExec()
'= Time : Created At Apr,01,2004
'= Input : None
'= Called by :
'= Calls :
'= Description : adminstrator check and execute
'====================================================================
Function AdminCheckExec()
'If Not AdminCheck() Then
' Call ResultExecute(E_USER_PUB,"你不具备管理员权限！！！","ES_ERR")
'End If
End Function
'============== End of Func AdminCheckExec() ========================
'====================================================================
'= Function : ResultExecute(intResultId,strAddInfo,strExecMode)
'= Time : Created At Aug,10,2003
'= Input : intResultId : the error number
'= strAddInfo : the add error information
'= strExecMode : the mode of execute err or succ
'= "ES_DB_NO" -- show error info directly of db
'= "ES_DB_YES" -- redirect err.asp of db
'= "ES_ERR" -- only deal with error
'= "ES_SUCC" -- only deal with success
'= "ES_NORMAL" -- deal with error or succ
'= Output : Redirect err.asp
'= Return : The flag of error execute
'= Calls : None
'= Called by : All functions and subs
'= Description : 错误或成功信息格式化处理
'===================================================================
Function ResultExecute(intResultId,strAddInfo,strExecMode)
Dim strActMode
ResultExecute = False '== Initial result of execute is false
'== for min err info such as order
If Left(CONST_PAGE_FILE,18) = "order/order_admin_" Or Left(CONST_PAGE_FILE,12) = "order/admin_" Or Left(CONST_PAGE_FILE,12) = "admin/admin_" Then
strActMode = "&ACT_MODE=ACT_ERR_MIN"
Else
strActMode = ""
End If
Select Case strExecMode
Case "ES_DB_NO":
If intResultId = 0 Then
ResultExecute = True
Response.Write "<br><p align=center> 本栏目: " & strAddInfo & "记录不存在或已被删除</p>"
End If
Case "ES_DB_YES":
If intResultId = 0 Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeURL & "err.asp?intErrId=1003" & "&strAddInfo=" & strAddInfo & strActMode
End If
Case "ES_SUCC" :
If intResultId <> 0 Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeURL & "succ.asp?intSuccId=" & intResultId & "&strAddInfo=" & strAddInfo & strActMode
End If
Case "ES_SUCC_NO":
If intResultId = 0 Then
ResultExecute = True
Response.Write "<br><p align=center> 本栏目: " & strAddInfo & "</p>"
End If
Case "ES_ERR" :
If intResultId <> 0 Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeURL & "err.asp?intErrId=" & intResultId & "&strAddInfo=" & strAddInfo & "&pstNowPost=" & Trim(Request.QueryString("action")) & strActMode
End If
Case "ES_NORMAL" :
If intResultId <> 0 Then
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "err.asp?intErrId=" & intResultId & "&strAddInfo=" & strAddInfo & strActMode
Else
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "succ.asp?intSuccId=" & intResultId & "&strAddInfo=" & strAddInfo & strActMode
End If
Case Else :
Set clsPubDB = Nothing
Response.Redirect GBL_strHomeUrl & "err.asp?intErrId=14&strAddInfo=" & strExecMode & strActMode
End Select
End Function
'============== End Of Function ResultExecute() ====================
'===================================================================
'= Function : MakeLink(strLink,strText,strTitle)
'= Time : Created At Nov,2,2003
'= Input : strLink : the link address
'= strText : the link's show text
'= strTitle : the link's clew
'= Output :
'= Return : The html code as "<a href=>..</a>"
'= Calls : None
'= Called by : All functions and subs
'= Description : Making link include href,title,text
'===================================================================
Function MakeLink(strLink,strText,strTitle)
Dim strHtmlCode
If Trim(strLink) <> "" Then
strHtmlCode = "<a href='" & GBL_strHomeURL & strLink & "' " & " title='" & strTitle & "' >" & strText & "</a>"
Else
strHtmlCode = "<a href='#' " & " title='" & strTitle & "' >" & strText & "</a>"
End If
MakeLink = strHtmlCode
End Function
'=============== End of Function MakeLink() ========================
'===================================================================
'= Function : MakeLinkClew(strLink,strText,strTitle,strClewAct)
'= Time : Created At Nov,2,2003
'= Input : strLink : the link address
'= strText : the link's show text
'= strTitle : the link's clew
'= Output :
'= Return : The html code as "<a href=>..</a>"
'= Calls : None
'= Called by : All functions and subs
'= Description : Making link include href,title,text with clew
'===================================================================
Function MakeLinkClew(strLink,strText,strTitle,strClewAct)
Dim strHtmlCode
If Trim(strLink) <> "" And Trim(strLink) <> "#" Then
strHtmlCode = "<a href='" & GBL_strHomeURL & strLink & "' " & " title='" & strTitle & "' " & strClewAct &">" & strText & "</a>"
ElseIf Trim(strLink) = "#" Then
strHtmlCode = "<a href='#' " & " title='" & strTitle & "' " & strClewAct &">" & strText & "</a>"
Else
strHtmlCode = "<a href='#' " & " title='" & strTitle & "' >" & strText & "</a>"
End If
MakeLinkClew = strHtmlCode
End Function
'=============== End of Function MakeLinkClew() ====================
'===================================================================
'= Function : MakeImg(strImgPath,strAlt)
'= Time : Created At Nov,4,2003
'= Input : strImgPath : the image's realitively path
'= strAlt : the image's alt
'= Output :
'= Return : The html code as "<img src= alt=>"
'= Calls : None
'= Called by : All functions and subs
'= Description : Making link of image
'===================================================================
Function MakeImg(strImgPath,strAlt)
Dim strHtmlCode
strHtmlCode = "<img src=" & GBL_strHomeURL & strImgPath & " alt='" & strAlt & "' border='0' align='absmiddle' valign='middle'>"
MakeImg = strHtmlCode
End Function
'=============== End of Function MakeImg() =========================
'===================================================================
'= Function : MakeTitle(strTitle)
'= Time : Created At Nov,4,2003
'= Input : strTitle : the title of form or column
'= Output :
'= Return : The html code as "XX title XX"
'= Calls : None
'= Called by : All functions and subs
'= Description : Making decorate of title
'===================================================================
Function MakeTitle(strTitle)
Dim strHtmlCode
strHtmlCode = CONST_TITLE_CHAR & " " & strTitle & " " & CONST_TITLE_CHAR
MakeTitle = strHtmlCode
End Function
'=============== End of Function MakeImg() =========================
Function GetConfig(strAim,strNow)
Const CONST_DIVIDER = "|||"
Dim arrTmp,arrTmp2
Dim i
Dim strTmp
Dim strGetAim,strGetNow
strGetAim = Trim(strAim)
strGetNow = Trim(strNow)
arrTmp = Split(Trim(strGetAim),CONST_DIVIDER)
For i = LBound(arrTmp) To UBound(arrTmp)
arrTmp2 = Split(arrTmp(i),"=")
If arrTmp2(0) = strGetNow Then
strTmp = Replace(Trim(arrTmp(i)),strGetNow,"")
strTmp = Replace(strTmp,"=","")
GetConfig = Trim(strTmp)
Exit Function
End If
Next
GetConfig = ""
End Function
'===================================================================
'= Function : LostConfigExec()
'= Time : Created At Nov,4,2003
'= Input : strTitle : the title of form or column
'= Output :
'= Return : The html code as "XX title XX"
'= Calls : None
'= Called by : All functions and subs
'= Description : Making decorate of title
'===================================================================
Sub LostConfigExec()
End Sub
'=============== End of Sub LostConfigExec() =======================
'===================================================================
'= Function : UpdateLevel(intLevelNum)
'= Time : Created At Nov,10,2003
'= Input : intLevelNum : to add this level
'= Output :
'= Calls : None
'= Called by : the add new record function
'= Table : Upate CLASS_USER.LEVEL
'= Description : Get user now level
'===================================================================
Sub UpdateLevel(intLevelNum)
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_USER"
clsPubDB.SQLType = "UPDATE"
clsPubDB.Where = "USER_ID=" & Session(GBL_strCookieURL & "SEN_UserId") & " AND USER_ACCOUNT='" & Session(GBL_strCookieURL & "SEN_strUserAccount") & "'"
clsPubDB.AddSet "USER_LEVEL=USER_LEVEL+" & intLevelNum
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"Level:" & intLevelNum,"ES_ERR")
End Sub
'=============== End of Sub UpdateLevel()===========================
'===================================================================
'= Function : ConvertLevel(intLevelNum)
'= Time : Created At July,4,2004
'= Input :
'= Output :
'= Calls : None
'= Called by :
'= Description : user level
'===================================================================
Function ConvertLevel(intLevelNum)
Dim intBase
intBase = 50
ConvertLevel = 0
DEF_UserLevelPoints = Array(0,12,25,50,80,150,250,400,700,1000,1500,2500,5000,8000,12000,20000,30000,40000,50000,60000,99999)
For i = Lbound(DEF_UserLevelPoints) To Ubound(DEF_UserLevelPoints)
If i = Ubound(DEF_UserLevelPoints) Then
ConvertLevel = i
Exit For
End If
If intLevelNum >= DEF_UserLevelPoints(i) And intLevelNum < DEF_UserLevelPoints(i+1) Then
ConvertLevel = i
Exit For
End If
Next
End Function
'============== End of Func ConvertLevel() =========================
'===================================================================
'= Function : RecordCounter(strTableName,strField,intCounter,strWhere)
'= Time : Created At Nov,10,2003
'= Input : strTableName : the table name of db
'= strField : the field name to update
'= intCounter : the update value
'= strWhere : the update record's condition
'= Output :
'= Calls : None
'= Called by : the add new record function
'= Table : Upate CLASS_USER.LEVEL
'= Description : Get user now level
'===================================================================
Sub RecordCounter(strTableName,strField,intCounter,strWhere)
clsPubDB.Clear()
clsPubDB.TableName = strTableName
clsPubDB.SQLType = "UPDATE"
clsPubDB.AddSet strField & "=" & strField & "+" & intCounter
clsPubDB.Where = strWhere
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,strField & " update"&clsPubDB.ReturnSQL(),"ES_ERR")
End Sub
'=============== End of Sub RecordCounter() ========================
'===================================================================
'= Function : RecordDel(strTableName,strIdField,RSId)
'= Time : Created At Nov,10,2003
'= Input : strTableName : the table name of db
'= strIdField : the Id field name to delete
'= RSId : the del record's Id condition
'= Output :
'= Calls : None
'= Called by : the add new record function
'= Table : Upate CLASS_USER.LEVEL
'= Description : Get user now level
'===================================================================
Sub RecordDel(strTableName,strIdField,ByRef RSId)
Dim intErrId
Dim strAddInfo
intErrId = 0
strAddInfo = "所要删除" & strTableName & "的"
intErrId = DataCheck("DT_ID",RSId,strAddInfo,"")
Call ResultExecute(intErrId,strAddInfo,"ES_ERR")
clsPubDB.Clear()
clsPubDB.TableName = strTableName
clsPubDB.SQLType = "DELETE"
clsPubDB.Where = strIdField & "=" & RSId
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"del record :" & strIdField,"ES_ERR")
End Sub
'=============== End of Sub RecordDel() ============================
'===================================================================
'= Function : MakeUserClew(UserId,objRSNow,intDBFlag)
'= Time : Created At Nov,10,2003
'= Input : UserId : user's id
'= objRSNow : the record object
'= intDBFlag : whether or not need open rs
'= 1 -- no open ,exist
'= 0 -- need to open
'= Output :
'= Calls : None
'= Called by :
'= Table : Query CLASS_USER
'= Return : Return user's info clew
'= Description : User Info clew
'===================================================================
Function MakeUserClew(UserId,objRSNow,intDBFlag)
Dim strHtmlCode
Dim objRSUser
Dim strUserAuThen
If intDBFlag = 0 Then
objRSUser = objRSNow
Else
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_USER"
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField "*",""
clsPubDB.Where = "USER_ID=" & UserId
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"show user's clew","ES_ERR")
If clsPubDB.intRSNum = 0 Then
MakeUserClew = "目前找不到该用户的任何资料"
Exit Function
End If
objRSUser = clsPubDB.objPubRS
End If
strHtmlCode = "<table><tr>"
strHtmlCode = strHtmlCode & "<td width=100>"
strHtmlCode = strHtmlCode & "[用户]：" & objRSUser("USER_REALNAME")
strHtmlCode = strHtmlCode & "</td><td width=100>"
strHtmlCode = strHtmlCode & "[帐号]：" & objRSUser("USER_ACCOUNT")
strHtmlCode = strHtmlCode & "</td><tr><td colspan=2>"
strHtmlCode = strHtmlCode & "[注册日期]：" & objRSUser("USER_ADD_DATE")
strHtmlCode = strHtmlCode & "</td><tr><td colspan=2>"
strHtmlCode = strHtmlCode & "[最后访问]：" & objRSUser("USER_LAST_TIME")
strHtmlCode = strHtmlCode & "</td><tr><td>"
strHtmlCode = strHtmlCode & "[访问]：" & objRSUser("USER_LOGIN_COUNT") & "次"
strHtmlCode = strHtmlCode & "</td><td>"
strHtmlCode = strHtmlCode & "[留言]：" & objRSUser("USER_BOARD") & "条"
strHtmlCode = strHtmlCode & "</td><tr><td>"
'== Get user auThen
If objRSUser("USER_AUTHEN") = 0 Then
strUserAuThen = "普通用户"
ElseIf objRSUser("USER_AUTHEN") = 1 And objRSUser("USER_ACCOUNT") = GBL_strAdminAccount Then
strUserAuThen = "管理员"
ElseIf objRSUser("USER_AUTHEN") = 1 Then
strUserAuThen = "副管理员"
ElseIf objRSUser("USER_AUTHEN") = 8 Then
strUserAuThen = "尚未批准加入的成员"
End If
strHtmlCode = strHtmlCode & "[权限]：" & strUserAuThen
strHtmlCode = strHtmlCode & "</td><td>"
strHtmlCode = strHtmlCode & "</td><tr><td colspan=2>"
strHtmlCode = strHtmlCode & "[签名图]：" & "<center><img src=" & GBL_strHomeURL & objRSUser("USER_NOW_FACE") & " onload=DrawImage(this," & GBL_strUserFaceWidth & "," & GBL_strUserFaceHeight & ")></center>"
'strHtmlCode = strHtmlCode & "</td><tr><td>"
strHtmlCode = strHtmlCode & "<td></tr></table>"
MakeUserClew = strHtmlCode
End Function
'=============== End of Sub MakeUserClew() =========================
'===================================================================
'= Function : TimeFormat(strTime,strFmt))
'= Time : Created At Nov,10,2003
'= Input : strFmt : the format flag
'= strTime : the time string
'= Output :
'= Calls : None
'= Called by :
'= Table : Query CLASS_USER
'= Return : Return user's info clew
'= Description : User Info clew
'===================================================================
Function TimeFormat(strTime,strFmt)
Dim strTmp
Select Case strFmt
Case "YYMMDD" :
strTmp = DateValue(strTime)
strTmp = Right(strTmp,Len(strTmp) - 2)
Case "YYMMDDHHMI" :
strTmp = Right(strTime,Len(strTime) - 2)
strTmp = Left(strTmp,Len(strTmp) - 3)
Case Else
strTmp = strTime
End Select
TimeFormat = strTmp
End Function
'=============== End of Function TimeFormat() ======================
'===================================================================
'= Function : ViewCount(strTime,strFmt))
'= Time : Created At Nov,10,2003
'= Input : strPageName : the count page name
'= Output :
'= Calls : None
'= Called by :
'= Table : Query CLASS_COUNT
'= Return : Return view
'===================================================================
Function ViewCount(strPageName)
Dim strUserIp
Dim intMonth,intDay,intTotal
Dim intLastMonth,intLastDay
'== 06/24 only count views at homepage
If CONST_PAGE_FILE <> "/index1.asp" Then
Exit Function
End If
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_COUNT"
clsPubDB.SQLType = "SELECT"
clsPubDB.Where = "COUNT_PAGE_NAME='" & CONST_PAGE_FILE & "' AND COUNT_POST_NAME='" & Trim(Request.QueryString("action")) & "'"
clsPubDB.AddField "COUNT_ID",""
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"select count view","ES_ERR")
If clsPubDB.intRSNum <> 1 Then
'== delete all record
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_COUNT"
clsPubDB.SQLType = "DELETE"
clsPubDB.Where = "COUNT_PAGE_NAME='" & CONST_PAGE_FILE & "' AND COUNT_POST_NAME='" & Trim(Request.QueryString("action")) & "'"
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"delete count view","ES_ERR")
'== insert a new formatted record
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_COUNT"
clsPubDB.SQLType = "INSERT"
clsPubDB.AddField "COUNT_PAGE_NAME",CONST_PAGE_FILE
clsPubDB.AddField "COUNT_POST_NAME",Trim(Request("action"))
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"insert count view"&clsPubDB.ReturnSQL(),"ES_ERR")
End If
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_COUNT"
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField "*",""
clsPubDB.Where = "COUNT_PAGE_NAME='" & CONST_PAGE_FILE & "' AND COUNT_POST_NAME='" & Trim(Request.QueryString("action")) & "'"
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"select count view2","ES_ERR")
intLastMonth = clsPubDB.objPubRS("COUNT_LAST_MONTH")
intLastDay = clsPubDB.objPubRS("COUNT_LAST_DAY")
intMonth = clsPubDB.objPubRS("COUNT_MONTH")
intDay = clsPubDB.objPubRS("COUNT_DAY")
intTotal = clsPubDB.objPubRS("COUNT_TOTAL_VIEW")
'== set show value of view count and begin time
GBL_intHomeViewCount = intTotal
GBL_intHomeLastViewCount = intLastDay
GBL_intHomeTodayViewCount = intDay
GBL_strHomeViewBegin = clsPubDB.objPubRS("COUNT_ADD_TIME")
If Cstr(Month(clsPubDB.objPubRS("COUNT_LAST_TIME"))) <> Cstr(Month(Date())) Then
intLastMonth = clsPubDB.objPubRS("COUNT_MONTH")
intMonth = 1
Else
If Cstr(Day(clsPubDB.objPubRS("COUNT_LAST_TIME"))) <> Cstr(Day(Date())) Then
intLastDay = clsPubDB.objPubRS("COUNT_DAY")
intDay = 1
End If
End If
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_COUNT"
clsPubDB.SQLType = "UPDATE"
clsPubDB.Where = "COUNT_PAGE_NAME='" & CONST_PAGE_FILE & "' AND COUNT_POST_NAME='" & Trim(Request.QueryString("action")) & "'"
clsPubDB.AddField "COUNT_TOTAL_VIEW",intTotal + 1
clsPubDB.AddField "COUNT_DAY",intDay + 1
clsPubDB.AddField "COUNT_MONTH",intMonth + 1
clsPubDB.AddField "COUNT_LAST_TIME",Now()
clsPubDB.AddField "COUNT_LAST_MONTH",intLastMonth
clsPubDB.AddField "COUNT_LAST_DAY",intLastDay
'== del real ip record
'If Request.ServerVariables("HTTP_X_FORWARDED_FOR") <> "" Then
' strUserIp = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
'Else
' strUserIp = Request.ServerVariables("REMOTE_ADDR")
'End If
'clsPubDB.AddField "COUNT_LAST_IP",strUserIp
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"update counter","ES_ERR")
End Function
'=============== End of Function ViewCount() =======================
'=====================================================================
'= Function : GetNowOnline()
'= Time : Created At Nov,29,2003
'= Input : None
'= Output : None
'= Called by :
'= Calls :
'= Table : Query CLASS_USER,Update CLASS_ONLINE
'= Return :
'= Description : get now online user and guest and into db
'=====================================================================
Function GetNowOnline()
Dim clsTable
Dim intOnline '== now online all
Dim intOnlineUser '== now online user
Dim intOnlineGuest '== now online guest
Dim strGetIp
'Exit Function '== 04/02
'== 06/27
If CONST_PAGE_FILE <> "/index1.asp" Then
Exit Function
End If
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_ONLINE"
clsPubDB.SQLType = "DELETE"
If CONST_DB_TYPE = 1 Or CONST_DB_TYPE = 2 Then
clsPubDB.Where = "ONLINE_ACTIVE_TIME<'" & Cstr(DateAdd("n",-20,Now())) & "' "
Else
clsPubDB.Where = "ONLINE_ACTIVE_TIME<#" & Cstr(DateAdd("n",-20,Now())) & "# "
End If
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"del timed out online user"&clsPubDB.returnsql,"ES_ERR")
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_ONLINE"
clsPubDB.SQLType = "SELECT"
clsPubDB.Where = "ONLINE_SESSION_ID=" & Session.SessionId
clsPubDB.AddField "*",""
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"check now online user"&clsPubdb.returnsql,"ES_ERR")
If clsPubDB.intRSNum = 0 Then
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_ONLINE"
clsPubDB.SQLType = "INSERT"
clsPubDB.AddField "ONLINE_USER","guest"
clsPubDB.AddField "ONLINE_LOGIN_TIME",Now()
clsPubDB.AddField "ONLINE_USER_AUTHEN",3
clsPubDB.AddField "ONLINE_SESSION_ID",Session.SessionId
clsPubDB.AddField "ONLINE_ACTIVE_TIME",Now()
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"add a new online guest"&clsPubdb.returnsql,"ES_ERR")
Else
intSessionId = clsPubDB.objPubRS("ONLINE_SESSION_ID")
clsPubDB.Clear()
clsPubDB.TableName = "CLASS_ONLINE"
clsPubDB.SQLType = "UPDATE"
clsPubDB.Where = "ONLINE_SESSION_ID=" & intSessionId
If Session(GBL_strCookieURL & "SEN_strUserRealName") = "" Or IsNull(Session(GBL_strCookieURL & "SEN_strUserRealName")) Then
clsPubDB.AddField "ONLINE_USER","guest"
clsPubDB.AddField "ONLINE_USER_AUTHEN",3
Else
clsPubDB.AddField "ONLINE_USER",Session(GBL_strCookieURL & "SEN_strUserRealName")
clsPubDB.AddField "ONLINE_USER_AUTHEN",0
clsPubDB.AddField "ONLINE_USER_ID",GBL_intUserId
End If
clsPubDB.AddField "ONLINE_ACTIVE_TIME",Now()
clsPubDB.SQLExecute()
Call ResultExecute(clsPubDB.intErrNum,"add a new online user"&clsPubDB.ReturnSQL,"ES_ERR")
End If
End Function
'================== End of Function GetNowOnline() =================
'=====================================================================
'= Function : Constellation(tBirths,strConstellation)
'= Time : Created At DEC,21,2003
'= Input : None
'= Output : None
'= Called by :
'= Calls :
'= Return : the img of constellation
'= Description : show user's constellation
'=====================================================================
Function Constellation(tBirths,ByRef strConstellation)
Dim tBirth
Dim tBirthDay,tBirthMonth
tBirth = tBirths
tBirthDay = Day(tBirth)
tBirthMonth = Month(tBirth)
Constellation = "<img width=15 height=15 src=" & GBL_strHomeURL & "images/Constellation/z"
strImg = "<img src=" & GBL_strHomeURL & "images/Constellation/z"
Select Case tBirthMonth
Case 1
If tBirthDay >= 21 Then
Constellation = Constellation & "11.gif alt='水瓶座(" & tBirth & ")<br>" & strImg & "11b.gif>' align=absmiddle>"
strConstellation = "水瓶座"
Else
Constellation = Constellation & "10.gif alt='魔羯座(" & tBirth & ")<br>" & strImg & "10b.gif>' align=absmiddle>"
strConstellation = "魔羯座"
End If
Case 2
If tBirthDay>=20 Then
Constellation = Constellation & "12.gif alt='双鱼座(" & tBirth & ")<br>" & strImg & "12b.gif>' align=absmiddle>"
strConstellation = "双鱼座"
Else
Constellation = Constellation & "11.gif alt='水瓶座(" & tBirth & ")<br>" & strImg & "11b.gif>' align=absmiddle>"
strConstellation = "水瓶座"
End If
Case 3
If tBirthDay>=21 Then
Constellation = Constellation & "1.gif alt='白羊座 (" & tBirth & ")<br>" & strImg & "1b.gif>' align=absmiddle>"
strConstellation = "白羊座"
Else
Constellation = Constellation & "12.gif alt='双鱼座(" & tBirth & ")<br>" & strImg & "12b.gif>' align=absmiddle>"
strConstellation = "双鱼座"
End If
Case 4
If tBirthDay>=21 Then
Constellation = Constellation & "2.gif alt='金牛座 (" & tBirth & ")<br>" & strImg & "2b.gif>' align=absmiddle>"
strConstellation = "金牛座"
Else
Constellation = Constellation & "1.gif alt='白羊座 (" & tBirth & ")<br>" & strImg & "1b.gif>' align=absmiddle>"
strConstellation = "白羊座"
End If
Case 5
If tBirthDay>=22 Then
Constellation = Constellation & "3.gif alt='双子座 (" & tBirth & ")<br>" & strImg & "3b.gif>' align=absmiddle>"
strConstellation = "双子座"
Else
Constellation = Constellation & "2.gif alt='金牛座 (" & tBirth & ")<br>" & strImg & "2b.gif>' align=absmiddle>"
strConstellation = "金牛座"
End If
Case 6
If tBirthDay>=22 Then
Constellation = Constellation & "4.gif alt='巨蟹座 (" & tBirth & ")<br>" & strImg & "4b.gif>' align=absmiddle>"
strConstellation = "巨蟹座"
Else
Constellation = Constellation & "3.gif alt='双子座 (" & tBirth & ")<br>" & strImg & "3b.gif>' align=absmiddle>"
strConstellation = "双子座"
End If
Case 7
If tBirthDay>=23 Then
Constellation = Constellation & "5.gif alt='狮子座 (" & tBirth & ")<br>" & strImg & "5b.gif>' align=absmiddle>"
strConstellation = "狮子座"
Else
Constellation = Constellation & "4.gif alt='巨蟹座 (" & tBirth & ")<br>" & strImg & "4b.gif>' align=absmiddle>"
strConstellation = "巨蟹座"
End If
Case 8
If tBirthDay>=24 Then
Constellation = Constellation & "6.gif alt='处女座 (" & tBirth & ")<br>" & strImg & "6b.gif>' align=absmiddle>"
strConstellation = "处女座"
Else
Constellation = Constellation & "5.gif alt='狮子座 (" & tBirth & ")<br>" & strImg & "5b.gif>' align=absmiddle>"
strConstellation = "狮子座"
End If
Case 9
If tBirthDay>=24 Then
Constellation = Constellation & "7.gif alt='天秤座 (" & tBirth & ")<br>" & strImg & "7b.gif>' align=absmiddle>"
strConstellation = "天秤座"
Else
Constellation = Constellation & "6.gif alt='处女座 (" & tBirth & ")<br>" & strImg & "6b.gif>' align=absmiddle>"
strConstellation = "处女座"
End If
Case 10
If tBirthDay>=24 Then
Constellation = Constellation & "8.gif alt='天蝎座 (" & tBirth & ")<br>" & strImg & "8b.gif>' align=absmiddle>"
strConstellation = "天蝎座"
Else
Constellation = Constellation & "7.gif alt='天秤座 (" & tBirth & ")<br>" & strImg & "7b.gif>' align=absmiddle>"
strConstellation = "天秤座"
End If
Case 11
If tBirthDay>=23 Then
Constellation = Constellation & "9.gif alt='射手座 (" & tBirth & ")<br>" & strImg & "9b.gif>' align=absmiddle>"
strConstellation = "射手座"
Else
Constellation = Constellation & "8.gif alt='天蝎座 (" & tBirth & ")<br>" & strImg & "8b.gif>' align=absmiddle>"
strConstellation = "天蝎座"
End If
Case 12
If tBirthDay>=22 Then
Constellation = Constellation & "10.gif alt='魔羯座 (" & tBirth & ")<br>" & strImg & "10b.gif>' align=absmiddle>"
strConstellation = "魔羯座"
Else
Constellation = Constellation & "9.gif alt='射手座 (" & tBirth & ")<br>" & strImg & "9b.gif>' align=absmiddle>"
strConstellation = "射手座"
End If
Case Else
Constellation=""
End Select
End Function
'============= End of Func Constellatio() ===========================
'=====================================================================
'= Function : DisplayBirthAnimal(tBirthYear,strAnimal)
'= Time : Created At DEC,21,2003
'= Input : None
'= Output : None
'= Called by :
'= Calls :
'= Return : the img of birth animal
'= Description : show user's birth animal
'=====================================================================
Function DisplayBirthAnimal(tBirths,ByRef strAnimal)
Dim intTemp,strTmp
intTemp = Cint(Year(tBirths)) mod 12
strTmp = "<img width=15 height=15 src=" & GBL_strHomeURL & "images/" & "sx/sx"
strTmp1 = "<img src=" & GBL_strHomeURL & "images/" & "sx/sx"
Select Case intTemp
Case 0: strTmp = strTmp & "9s.gif align=absmiddle alt='申猴(" & tBirths & ")<br>" & strTmp1 & "9.gif>' align=absmiddle>"
strAnimal = "申猴"
Case 1: strTmp = strTmp & "10s.gif align=absmiddle alt='酉鸡(" & tBirths & ")<br>" & strTmp1 & "10.gif>' align=absmiddle>"
strAnimal = "酉鸡"
Case 2: strTmp = strTmp & "11s.gif align=absmiddle alt='戌狗(" & tBirths & ")<br>" & strTmp1 & "11.gif>' align=absmiddle>"
strAnimal = "戌狗"
Case 3: strTmp = strTmp & "12s.gif align=absmiddle alt='亥猪(" & tBirths & ")<br>" & strTmp1 & "12.gif>' align=absmiddle>"
strAnimal = "亥猪"
Case 4: strTmp = strTmp & "1s.gif align=absmiddle alt='子鼠(" & tBirths & ")<br>" & strTmp1 & "1.gif>' align=absmiddle>"
strAnimal = "子鼠"
Case 5: strTmp = strTmp & "2s.gif align=absmiddle alt='丑牛(" & tBirths & ")<br>" & strTmp1 & "2.gif>' align=absmiddle>"
strAnimal = "丑牛"
Case 6: strTmp = strTmp & "3s.gif align=absmiddle alt='寅虎(" & tBirths & ")<br>" & strTmp1 & "3.gif>' align=absmiddle>"
strAnimal = "寅虎"
Case 7: strTmp = strTmp & "4s.gif align=absmiddle alt='卯兔(" & tBirths & ")<br>" & strTmp1 & "4.gif>' align=absmiddle>"
strAnimal = "卯兔"
Case 8: strTmp = strTmp & "5s.gif align=absmiddle alt='辰龙(" & tBirths & ")<br>" & strTmp1 & "5.gif>' align=absmiddle>"
strAnimal = "辰龙"
Case 9: strTmp = strTmp & "6s.gif align=absmiddle alt='巳蛇(" & tBirths & ")<br>" & strTmp1 & "6.gif>' align=absmiddle>"
strAnimal = "巳蛇"
Case 10: strTmp = strTmp & "7s.gif align=absmiddle alt='午马(" & tBirths & ")<br>" & strTmp1 & "7.gif>' align=absmiddle>"
strAnimal = "午马"
Case 11: strTmp = strTmp & "8s.gif align=absmiddle alt='未羊(" & tBirths & ")<br>" & strTmp1 & "8.gif>' align=absmiddle>"
strAnimal = "未羊"
Case Else: strTmp = ""
End Select
DisplayBirthAnimal = strTmp
End Function
'=============== End of Func DisplayBirthAnimal() ==================
'===================================================================
'= Function : GetNextRS(strOutField,strTabName,strWhere,strOrder)
'= Time : Created At DEC,28,2003
'= Input : strOutField: out filed
'= strWhere : where
'= strTabName: now table name
'= strOrder : order conditions
'= Output : None
'= Called by : album_func.asp
'= Calls :
'= Return : next id
'= Description : get next or pre rs
'===================================================================
Function GetNextRS(strOutField,strTabName,strWhere,strOrder)
clsPubDB.Clear()
clsPubDB.TableName = strTabName
clsPubDB.SQLType = "SELECT"
clsPubDB.AddField " Top 1 " & strOutField,""
If Trim(strWhere) <> "" Then
clsPubDB.Where = strWhere
End If
If Trim(strOrder) <> "" Then
clsPubDB.Order = strOrder
End If
clsPubDB.SQLRSExecute()
Call ResultExecute(clsPubDB.intErrNum,"get next rs","ES_ERR")
'== no find the record
If clsPubDB.intRSNum <= 0 Then
GetNextRS = -1
Exit Function
Else
GetNextRS = clsPubDB.objPubRS(strOutField)
End If
End Function
'=============== End of Func GetNextId() ===========================
'===================================================================
'= Function : CheckObjInstalled(strClassString,ByRef strClew)
'= Time : Created At DEC,28,2003
'= Input : strClassString : obj name
'= Output : strClew : success or err information of obj
'= Called by :
'= Calls :
'= Return : installed or not flag
'= Description : check obj is or not installed
'===================================================================
Function CheckObjInstalled(strClassString,ByRef strClew)
On Error Resume Next
Dim intInstallFlag
Err = 0
Dim objTmp
Set objTmp = Server.CreateObject(strClassString)
intInstallFlag = Err
If intInstallFlag = 0 Then
CheckObjInstalled = True
strClew = "支持此组件"
ElseIf intInstallFlag = -2147221005 Then
strClew = "组件未安装"
CheckObjInstalled = False
ElseIf intInstallFlag = -2147221477 Then
strClew = "支持此组件"
CheckObjInstalled = True
ElseIf intInstallFlag = 1 Then
strClew = "未知的错误，组件可能未正确安装"
CheckObjInstalled = False
End If
Err.Clear
Set objTmp = Nothing
Err = 0
End Function
'=============== End of Func CheckObjInstalled() ===================
'===================================================================
'= Function : MakeQQShow(intQQ)
'= Time : Created At Jun,22,2004
'= Input : qq
'= Called by :
'= Calls :
'= Return :
'= Description : make qq show
'===================================================================
Function MakeQQShow(intQQ)
MakeQQShow = "http://qqshow-user.tencent.com/" & intQQ & "/10/00/"
End Function
'=============== End Of Func MakeQQShow() ==========================
'===================================================================
'= Function : ReloadStyleInfo(ID)
'= Time : Created At July,3,2004
'= Input : Id :style id
'= Output :
'= Called by :
'= Calls :
'= Return :
'= Description : reload style info of the special
'===================================================================
Sub ReloadStyleInfo(ID)
Dim Rs,Temp
'If GBL_ConFlag = 0 Then Exit Sub
clsPubDB.Clear()
clsPubDB.AllSQL = "Select top 1 T1.StyleID,T1.ScreenWidth,T1.DisplayTopicLength,T1.DefineImage,T1.SiteHeadString,T1.SiteBottomString,T1.TableHeadString,T1.TableBottomString,T1.ShowBottomSure,T1.TempletID,T2.TempletFlag from CLASS_Skin as T1 Left Join CLASS_Templet as T2 on T1.TempletID=T2.ID Where T1.StyleID=" & ID
clsPubDB.SQLRSExeCute()
If clsPubDB.intErrNum < 0 Then
Response.Write "风格设置错误，请联系管理员!!!"
Exit Sub
End If
If clsPubDB.objPubRS.Eof Then
clsPubDB.objPubRS.Close
Set clsPubDB.objPubRS = Nothing
GBL_Board_BoardLimit = 0
Application.Lock
Application(GBL_strCookieURL & "Style" & ID) = "yes"
Application.UnLock
Exit Sub
Else
DEF_WEB_ScreenWidth = clsPubDB.objPubRS(2)
GBL_strHomeURLAlt = "<GBL_strHomeURL>"
GBL_SiteHeadString = Replace(clsPubDB.objPubRS(4),"/leadbbs/",GBL_strHomeURLAlt)
GBL_SiteBottomString = Replace(clsPubDB.objPubRS(5),"/leadbbs/",GBL_strHomeURLAlt)
GBL_TableHeadString = Replace(clsPubDB.objPubRS(6),"/leadbbs/",GBL_strHomeURLAlt)
GBL_TableBottomString = Replace(clsPubDB.objPubRS(7),"/leadbbs/",GBL_strHomeURLAlt)
Temp = clsPubDB.objPubRS.GetRows(1)
Application.Lock
Set Application(GBL_strCookieURL & "Style" & ID) = Nothing
Application(GBL_strCookieURL & "Style" & ID) = Temp
Application.UnLock
Temp = Application(GBL_strCookieURL & "Style" & ID)
'== get image real path 04/07/21
Temp(4,0) = Replace(GBL_SiteHeadString,"/leadbbs/",GBL_strHomeURLAlt)
Temp(5,0) = Replace(GBL_SiteBottomString,"/leadbbs/",GBL_strHomeURLAlt)
Temp(6,0) = Replace(GBL_TableHeadString,"/leadbbs/",GBL_strHomeURLAlt)
Temp(7,0) = Replace(GBL_TableBottomString,"/leadbbs/",GBL_strHomeURLAlt)
Application.Lock
Application(GBL_strCookieURL & "Style" & ID) = Temp
Application.UnLock
clsPubDB.objPubRS.Close
Set clsPubDB.objPubRS = Nothing
End If
End Sub
'=============== End of Sub ReloadStyleInfo() ======================
'=============== FUNCTION BODY END =================================
%>