Microsoft VBScript 运行时错误错误 '800a0009'

下标越界: '[number: 0]'

/bbs/inc/Dv_ClsMain.asp，行661

代码如下：

=========================================================

' File: Dv_ClsMain.asp

' Version:7.0 sp3

' Date: 2004-6-30

' Script Written by dvbbs.net

'=========================================================

' Web: http://www.aspsky.net,http://www.dvbbs.net

' Email: eway@aspsky.net

'=========================================================

'是否商业版，非官方SQL版本请在此设置为0以及在Conn中设置论坛为SQL数据库，否则显示不正常

Const IsBuss=1

Const Dvbbs_Server_Url = "http://server.dvbbs.net/"

Class Cls_Forum

Rem Const

Public BoardID,SqlQueryNum,Forum_Info,Forum_Setting,Forum_user,Forum_Copyright,Forum_ads,Forum_ChanSetting,Forum_UploadSetting

Public Forum_sn,Forum_Version,Stats,StyleName,ErrCodes,NowUseBBS,Cookiepath,ScriptFolder

Public lanstr,mainhtml,mainsetting,sysmenu,mainpic

Public MyUserInfo,UserToday,BoardJumpList,BoardList,CacheData,Maxonline

Public UserGroupID,Lastlogin,GroupSetting,FoundUserPer,UserInfoCount,UserGroupParent,UserGroupParentID

Public VipGroupUser,Vipuser,Boardmaster,Superboardmaster,Master,FoundIsChallenge,FoundUser

Public ScriptName,MemberName,MemberWord,MemberClass,UserHidden,UserID,UserTrueIP,UserPermission

Public sendmsgnum,sendmsgid,sendmsguser,Page_Admin,Forum_AdLoop3

Public BadWords,rBadWord,Forum_emot,Forum_PostFace,Forum_UserFace,SkinID,Forum_PicUrl

Private adcode_1,adcode_2,adcode_4,ScriptTrueUrl,Forum_CSS,Main_Sid,Nowstats,CssID

Public Reloadtime,CacheName,savelog

Private LocalCacheName,Cache_Data,IsTopTable,CookiesSid,BoardInfoData,ShowErrType

Public Board_Setting,boarduser,LastPost,Board_Ads,Board_user,BoardType,IsGroupSetting,BoardMasterList,Board_Data,Sid,Boardreadme,BoardRootID,BoardParentID

Private Is_Isapi_Rewrite,iArchiverUrl

Public ModHtmlLinked,ArchiverUrl,ArchiverType

Public Browser,version ,platform,IsSearch

Public BoardXML,BoardNode,NodeUpdate

Public IsUserPermissionOnly,IsUserPermissionAll

Rem Sub

Private Sub Class_Initialize()

If Not Response.IsClientConnected Then Response.End

IsUserPermissionOnly = 0

IsUserPermissionAll = 0

ShowErrType = 0 '错误信息显示模式

savelog=0'设置为1的时候会记录攻击或错误错信息。

SqlQueryNum = 0

Reloadtime=28800

CacheName=Replace(Replace(Replace(Server.MapPath("index.asp"),"index.asp",""),":",""),"\","")

IsTopTable = 0

Forum_sn = Replace(CacheName,"_","")

VipGroupUser = False

Vipuser = False:Boardmaster = False

Superboardmaster = False:Master = False:FoundIsChallenge = False:FoundUser = False

BoardID = Request("BoardID")

If IsNumeric(BoardID) = 0 or BoardID = "" Then BoardID = 0

BoardID = Clng(BoardID)

MemberName = checkStr(Trim(Request.Cookies(Forum_sn)("username")))

MemberWord = checkStr(Trim(Request.Cookies(Forum_sn)("password")))

UserHidden = Trim(Request.Cookies(Forum_sn)("userhidden"))

UserID = Trim(Request.Cookies(Forum_sn)("UserID"))

If IsNumeric(UserHidden) = 0 or Userhidden = "" Then UserHidden = 2

If IsNumeric(UserID) = 0 Or UserID="" Then UserID=0

UserID = Clng(UserID)

UserTrueIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")

If UserTrueIP = "" Then UserTrueIP = Request.ServerVariables("REMOTE_ADDR")

UserTrueIP = CheckStr(UserTrueIP)

Dim Tmpstr

Tmpstr = Request.ServerVariables("PATH_INFO")

Tmpstr = Split(Tmpstr,"/")

ScriptName = Lcase(Tmpstr(UBound(Tmpstr)))

ScriptFolder = Lcase(Tmpstr(UBound(Tmpstr)-1)) & "/"

MemberClass = checkStr(Request.Cookies(Forum_sn)("userclass"))

Page_Admin=False

If InStr(ScriptName,"showerr")>0 Or InStr(ScriptName,"login")>0 Or InStr(ScriptName,"admin_")>0 Then Page_Admin=True

sendmsgnum=0:sendmsgid=0:sendmsguser=""

'模拟HTML部分开始

Is_Isapi_Rewrite = 0

If Is_Isapi_Rewrite = 0 Then ModHtmlLinked = "?"

ArchiverType = 0

If InStr(ScriptName,"indexhtml.asp") > 0 Then

iArchiverUrl = Lcase(Request.ServerVariables("QUERY_STRING"))

If iArchiverUrl <> "" Then

ArchiverUrl = iArchiverUrl

iArchiverUrl = Split(iArchiverUrl,"_")

If iArchiverUrl(0) = "list" And Ubound(iArchiverUrl) = 5 Then

If IsNumeric(iArchiverUrl(1)) Then

ArchiverType = 1

BoardID = Clng(iArchiverUrl(1))

End If

'模拟HTML部分结束

'Response.Write Server.MapPath("index.asp")

'response.end

NodeUpdate=False

End Sub

Private Sub class_terminate()

If NodeUpdate Then

Application.lock

Set Application(CacheName&"_Boradlist")=BoardXML.cloneNode(True)

Application.unlock

End If

Set BoardXML = Nothing

If IsObject(Conn) Then Conn.Close : Set Conn = Nothing

If IsObject(Plus_Conn) Then Plus_Conn.Close : Set Plus_Conn = Nothing

End Sub

Public Property Let Name(ByVal vNewValue)

LocalCacheName = LCase(vNewValue)

Cache_Data=Application(CacheName & "_" & LocalCacheName)

End Property

Public Property Let Value(ByVal vNewValue)

If LocalCacheName<>"" Then

ReDim Cache_Data(2)

Cache_Data(0)=vNewValue

Cache_Data(1)=Now()

Application.Lock

Application(CacheName & "_" & LocalCacheName) = Cache_Data

Application.unLock

Else

Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName."

End If

End Property

Public Property Get Value()

If LocalCacheName<>"" Then

If IsArray(Cache_Data) Then

Value=Cache_Data(0)

Else

'Err.Raise vbObjectError + 1, "DvbbsCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."

End If

Else

Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName."

End If

End Property

Public Function ObjIsEmpty()

ObjIsEmpty=True

If Not IsArray(Cache_Data) Then Exit Function

If Not IsDate(Cache_Data(1)) Then Exit Function

If DateDiff("s",CDate(Cache_Data(1)),Now()) < (60*Reloadtime) Then ObjIsEmpty=False

End Function

Public Sub Checkcache()

Name="Date"

Dim iScriptName

iScriptName = Request.ServerVariables("Script_Name")

If InStr(Lcase(iScriptName),"admin/") > 0 Then

iScriptName = "admin/index.asp"

Else

iScriptName = ""

End If

If ObjIsEmpty() Then

If iScriptName <> "" Then

Session("LoadCache")=iScriptName

Response.Redirect "../LoadCache.asp"

Else

If Request.ServerVariables("QUERY_STRING")<>"" Then

Session("LoadCache")=ScriptName&"?"&Request.ServerVariables("QUERY_STRING")

Else

Session("LoadCache")=ScriptName

End If

Response.Redirect "LoadCache.asp"

End If

Else

If Cstr(value) <> Cstr(Date()) Then

If iScriptName <> "" Then

Session("LoadCache")=iScriptName

Response.Redirect "../LoadCache.asp"

Else

If Request.ServerVariables("QUERY_STRING")<>"" Then

Session("LoadCache")=ScriptName&"?"&Request.ServerVariables("QUERY_STRING")

Else

Session("LoadCache")=ScriptName

End If

Response.Redirect "LoadCache.asp"

End If

End Sub

'取得基本设置数据

Public Sub GetForum_Setting()

Name="setup"

CacheData=value

Dim Setting

Setting=CacheData(1,0)

Setting = Split(Setting,"|||")

Forum_Info = Setting(0)

Forum_Info = Split (Forum_Info,",")

Forum_Setting = Setting(1)

Forum_Setting = Split (Forum_Setting,",")

Forum_UploadSetting = Split(Forum_Setting(7),"|")

Forum_user = Setting(2)

Forum_user = Split (Forum_user,",")

Forum_Copyright = Setting(3)

Forum_ChanSetting = CacheData(24,0)

Forum_ChanSetting = Split(Forum_ChanSetting,",")

Forum_Version = CacheData(18,0)

BadWords = Split(CacheData(3,0),"|")

rBadWord = Split(CacheData(4,0),"|")

Main_Sid=CacheData(17,0)

Maxonline = CacheData(5,0)

NowUseBBS = CacheData(19,0)

Cookiepath = CacheData(26,0)

If ScriptFolder = Lcase(CacheData(33,0)) Then Page_Admin = True

'IP锁定

If Request.Cookies(Forum_sn & "Kill")("kill") = "1" Then

If Not Page_Admin Then Response.Redirect "showerr.asp?action=iplock"

ElseIf Not ( Request.Cookies(Forum_sn & "Kill")("kill") = "0" And Not IsEmpty(Session(CacheName & "UserID")) ) Then

Call ChecKIPlock

If Request.Cookies(Forum_sn & "Kill")("kill") = "1" Then

If Not Page_Admin Then Response.Redirect "showerr.asp?action=iplock"

End If

'关闭论坛相关部分

'判断BoardID的值，获取对应的设置

If Forum_Setting(21)="1" And Not Page_Admin Then Response.redirect "showerr.asp?action=stop"

Dim OpenTime,ischeck

Set BoardXML=Application(CacheName&"_Boradlist").cloneNode(True)

'If (Dvbbs.Forum_ChanSetting(13)="1" And Dvbbs.Forum_ChanSetting(0)="1") Or Dvbbs.Forum_ChanSetting(3)="0" Then MyForumPay = True

If BoardID>0 Then

Dim Nodelist,node

Set Nodelist=BoardXML.documentElement.getElementsByTagName("board")

For Each Node in nodelist

If Cstr(BoardId)=Node.attributes.getNamedItem("boardid").text Then

Set BoardNode=Node

Exit For

End If

Set Nodelist=Nothing

If Not IsObject(BoardNode) Then

Response.Write "错误的版面参数"

Response.End

ElseIf BoardNode is Nothing Then

Response.Write "错误的版面参数"

Response.End

End If

boarduser = Split(BoardNode.attributes.getNamedItem("boarduser").text,",")

Forum_ads = Split(BoardNode.attributes.getNamedItem("board_ads").text,"$")

Forum_user = Split(BoardNode.attributes.getNamedItem("board_user").text,",")

'Forum_user = Board_User

board_Setting = Split(BoardNode.attributes.getNamedItem("board_setting").text,",")

LastPost = Split(BoardNode.attributes.getNamedItem("lastpost").text,"$")

BoardType = BoardNode.attributes.getNamedItem("boardtype").text

IsGroupSetting = BoardNode.attributes.getNamedItem("isgroupsetting").text

BoardMasterList = BoardNode.attributes.getNamedItem("boardmaster").text

BoardRootID = BoardNode.attributes.getNamedItem("rootid").text

If BoardNode.parentNode.attributes.getNamedItem("boardid") is Nothing Then

BoardParentID="0"

Else

BoardParentID=BoardNode.parentNode.attributes.getNamedItem("boardid").text

End If

Sid = BoardNode.attributes.getNamedItem("sid").text

Boardreadme=BoardNode.attributes.getNamedItem("readme").text

If Len(Board_Setting(22))< 24 Then Board_Setting(22)="1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1"

OpenTime=Split(Board_Setting(22),"|")

setting=Board_Setting(21)

ischeck=Clng(Board_Setting(18))

If Board_Setting(50)<>"0" And Board_Setting(50)<>"" Then Response.Redirect Board_Setting(50)

Else

Forum_ads = CacheData(2,0)

Forum_ads = Split(Forum_ads,"$")

If Len(Forum_Setting(70))< 24 Then Forum_Setting(70)="1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1"

OpenTime=Split(Forum_Setting(70),"|")

setting=Forum_Setting(69)

ischeck=Forum_Setting(26)

If Not IsNumeric(ischeck) Then ischeck=0

ischeck=CLng(ischeck)

End If

'定时开放判断

If Not Page_Admin And Cint(setting)=1 Then

If OpenTime(Hour(Now))="1" Then Response.redirect "showerr.asp?action=stop&boardid="&Dvbbs.BoardID&""

End If

'在线人数限制

If ischeck > 0 And Not Page_Admin Then

If MyBoardOnline.Forum_Online > ischeck And BoardID=0 Then

If Not IsONline(Membername,1) Then Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck

End If

If BoardID > 0 Then

If (Not IsONline(Membername,1)) And MyBoardOnline.Board_Online > ischeck Then Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck

End If

CookiesSid = Request.Cookies("skin")("skinid_"&BoardID)

If Not IsNumeric(CookiesSid) Or CookiesSid = "" Then

If BoardID = 0 Then

SkinID = Main_Sid

Else

SkinID = Sid

End If

Else

SkinID=CookiesSid

End If

End Sub

Public Function IsReadonly()

IsReadonly=False

Dim TimeSetting

If Forum_Setting(69)="2" Then

TimeSetting=split(Forum_Setting(70),"|")

If TimeSetting(Hour(Now))="1" Then

IsReadonly=True

Exit Function

End If

If BoardID>0 Then

If Board_Setting(21)="2" Then

TimeSetting=split(Board_Setting(22),"|")

If TimeSetting(Hour(Now))="1" Then IsReadonly=True

End If

End Function

Public Function IsONline(UserName,action)

IsONline=False

If Trim(UserName)="" Then Exit Function

If IsArray(Session(CacheName & "UserID")) And action=1 Then

If Session(CacheName & "UserID")(0)="Dvbbs" Then

IsONline=True:Exit Function

End If

Dim Rs

Set Rs =Execute("Select Count(*) From Dv_Online Where Username='"&UserName&"'")

If Rs(0)<> 0 Then IsONline=True

Set rs=Nothing

End Function

Public Sub LoadTemplates(Page_Fields)

Dim Style_Pic,Main_Style,TempStyle

SkinID=CLng(SkinID)

'风格换肤修改

TempStyle = CacheData(35,0)

TempStyle = Split(TempStyle,"@@@")

If SkinID > UBound(Split(TempStyle(1),"|||"))-1 Then SkinID = 0

Forum_CSS = Split(TempStyle(1),"|||")(SkinID) '风格内容

Forum_PicUrl = Split(TempStyle(2),"|||")(SkinID) '图片路径

CssID = SkinID

SkinID = Split(TempStyle(3),"|||")(SkinID) '采用模板ID

Name = "Main_Style"&SkinID

Main_Style = Replace(value,"{$PicUrl}",Forum_PicUrl) '风格图片路径替换

Name="StyleName"&SkinID

StyleName=value

If Not (Instr(ScriptName,"index")>0 Or Page_Admin) Then

Name = "Style_Pic"&SkinID

Style_Pic = Replace(value,"{$PicUrl}",Forum_PicUrl) '风格图片路径替换

Style_Pic = Split(Style_Pic,"@@@")

Forum_UserFace = Style_Pic(0)

Forum_PostFace = Style_Pic(1)

Forum_Emot = Style_Pic(2)

End If

If Page_Fields<>"" Then

Name="page_"&Page_Fields&SkinID

Template.value = value

End If

Main_Style = Split(Main_Style,"@@@")

mainhtml = Split(Main_Style(0),"|||")

lanstr = Split(Main_Style(1),"|||")

mainpic = Split(Main_Style(2),"|||")

mainsetting = Split(mainhtml(0),"||")

Forum_CSS = Replace(Forum_CSS,"{$width}",mainsetting(0))

Forum_CSS = Replace(Forum_CSS,"{$PicUrl}",Forum_PicUrl)

End Sub

Rem 判断发言是否来自外部

Public 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

'更新总设置表部分缓存数组，入口：更新内容、数组位置

Public Sub ReloadSetupCache(MyValue,N)

CacheData(N,0) = MyValue

Name="setup"

value=CacheData

End Sub

'更新用户资料缓存(缓存用户名,是否需要添加)[0=不添加,只作清理,1=需要添加]

Public Sub NeedUpdateList(username,act)

Dim Tmpstr,TmpUsername

Name="NeedToUpdate"

If ObjIsEmpty() Then Value=""

Tmpstr=Value

TmpUsername=","&username&","

Tmpstr=Replace(Tmpstr,TmpUsername,",")

Tmpstr=Replace(Tmpstr,",,",",")

IF act=1 Then

If IsONline(username,0) Then

If Tmpstr="" Then

Tmpstr=TmpUsername

Else

Tmpstr=Tmpstr&TmpUsername

End If

Tmpstr=Replace(Tmpstr,",,",",")

Value=Tmpstr

End Sub

'写入客人session

Public Sub LetGuestSession()

Dim StatUserID,UserSessionID

StatUserID = checkStr(Trim(Request.Cookies(Forum_sn)("StatUserID")))

If IsNumeric(StatUserID) = 0 or StatUserID = "" Then

StatUserID = Replace(UserTrueIP,".","")

UserSessionID = Replace(Startime,".","")

If IsNumeric(StatUserID) = 0 or StatUserID = "" Then StatUserID = 0

StatUserID = Ccur(StatUserID) + Ccur(UserSessionID)

End If

StatUserID = Ccur(StatUserID)

Response.Cookies(Forum_sn).Expires=DateAdd("s",3600,Now())

Response.Cookies(Forum_sn).path=cookiepath

Response.Cookies(Forum_sn)("StatUserID") = StatUserID

'客人=SessionID+活动时间+发帖时间+版面ID

StatUserID = StatUserID & "_" & Now & "_" & Now & "_" & BoardID

Session(CacheName & "UserID") = Split(StatUserID,"_")

End Sub

'根据页面来判断是否需要执行TrueCheckUserLogin

Public Function NeedChecklongin()

NeedChecklongin=True

If UserID>0 Then

If InStr(ScriptName,"admin_")>0 Then Exit Function

Dim pagelist

pagelist=",post.asp,usermanager.asp,mymodify.asp,modifypsw.asp,modifyadd.asp,usersms.asp,"

pagelist=pagelist & "friendlist.asp,favlist.asp,myfile.asp,friendlist.asp,recycle.asp,"

pagelist=pagelist & "fileshow.asp,bbseven.asp,dispuser.asp,savepost.asp,"

If InStr(pagelist,","&ScriptName&",")>0 Then Exit Function

End If

NeedChecklongin=False

End Function

'验证用户登陆

Public Sub CheckUserLogin()

If Not IsArray(Session(CacheName & "UserID")) Then

If UserID > 0 Then

TrueCheckUserLogin

Else

Call LetGuestSession()

End If

Else

If UserID >0 Then

Dim NeedToUpdate,toupdate

toupdate=False

Name="NeedToUpdate"

If Not ObjIsEmpty() Then

NeedToUpdate=","&Value&","

If InStr(NeedToUpdate,","&MemberName&",")>0 Then

Call NeedUpdateList(MemberName,0)

toupdate=True

End If

If NeedChecklongin Or (UserID >0 And Not Ubound(Session(CacheName & "UserID"))=45) Or toupdate Then TrueCheckUserLogin

End If

If Session(CacheName & "UserID")(0) = "Dvbbs" Then

GetCacheUserInfo

Else

MyUserInfo = Session(CacheName & "UserID")

UserGroupID = 7

Lastlogin = Now()

End If

GetGroupSetting

End Sub

'系统分配随机密码

Public Function Createpass()

Dim Ran,i,LengthNum

LengthNum=16

Createpass=""

For i=1 To LengthNum

Randomize

Ran = CInt(Rnd * 2)

Randomize

If Ran = 0 Then

Ran = CInt(Rnd * 25) + 97

Createpass =Createpass& UCase(Chr(Ran))

ElseIf Ran = 1 Then

Ran = CInt(Rnd * 9)

Createpass = Createpass & Ran

ElseIf Ran = 2 Then

Ran = CInt(Rnd * 25) + 97

Createpass =Createpass& Chr(Ran)

End If

End Function

'更新用户验证密码

Public Sub NewPassword()

If UserID=0 Then Exit Sub

Response.Write "<iframe width=""0"" height=""0"" src=""newpass.asp"" name=""Dvnewpass""></iframe>"

End Sub

Public Sub TrueCheckUserLogin()

'Session(CacheName & "UserID")用户资料=0dvbbs+1刷新时间+2发帖时间+3所在版面ID+4用户ID+5用户名+6用户密码+7用户邮箱+8用户文章数+9用户主题数+10用户性别+11用户头像+12用户头像宽+13用户头像高+14用户注册时间+15用户最后登陆时间+16用户登陆次数+17用户状态+18用户等级+19用户组ID+20用户组名+21用户金钱+22用户积分UserEp+23用户魅力UserCp+24用户威望+25用户生日+26最后登陆IP+27用户被删除数+28用户精华数+29用户隐身状态+30用户短信情况+31用户阳光会员+32用户手机+33用户组图标+34用户头衔+35验证密码+36用户今日信息+37用户金币+38用户点券+ 39跟踪用户ID+40VIP登记时间+41VIP截止时间+42是否存在全局自定义权限IsUserPermissionAll+43是否有多属性用户组IsUserPermissionOnly+44临时数据+45Dvbbs

Dim Rs,SQL,FoundMyGroupID

FoundMyGroupID = 0

Sql="Select UserID,UserName,UserPassword,UserEmail,UserPost,UserTopic,UserSex,UserFace,UserWidth,UserHeight,JoinDate,LastLogin,UserLogins,Lockuser,Userclass,UserGroupID,UserGroup,userWealth,userEP,userCP,UserPower,UserBirthday,UserLastIP,UserDel,UserIsBest,UserHidden,UserMsg,IsChallenge,UserMobile,TitlePic,UserTitle,TruePassWord,UserToday,UserMoney,UserTicket,FollowMsgID,Vip_StarTime,Vip_EndTime"

Sql=Sql+" From [Dv_User] Where UserID = " & UserID

Set Rs = Execute(Sql)

If Rs.Eof And Rs.Bof Then

Rs.Close:Set Rs = Nothing

UserID = 0

EmptyCookies

LetGuestSession()

Else

MyUserInfo=Rs.GetString(,1, "|||","","")

If IsArray(Session(CacheName & "UserID")) Then

If Session(CacheName & "UserID")(0)="Dvbbs" Then '修正防刷新的问题,轻飘飘

If Cint(Session(CacheName & "UserID")(19)) <> Cint(Split(MyUserInfo,"|||")(15)) Then FoundMyGroupID = Cint(Session(CacheName & "UserID")(19))

If FoundMyGroupID > 0 Then

MyUserInfo = "Dvbbs|||"& Session(CacheName & "UserID")(1) & "|||"& Session(CacheName & "UserID")(2) &"|||"& BoardID &"|||"& MyUserInfo &"|||"&FoundUserPermission_All()&"|||"&Split(MyUserInfo,"|||")(15)&"|||"& Session(CacheName & "UserID")(Ubound(Session(CacheName & "UserID"))-1) &"|||Dvbbs"

Else

MyUserInfo = "Dvbbs|||"& Session(CacheName & "UserID")(1) & "|||"& Session(CacheName & "UserID")(2) &"|||"& BoardID &"|||"& MyUserInfo &"|||"&FoundUserPermission_All()&"|||0|||"& Session(CacheName & "UserID")(Ubound(Session(CacheName & "UserID"))-1) &"|||Dvbbs"

End If

Else

MyUserInfo = "Dvbbs|||"& Now & "|||" & DateAdd("s",-3600,Now()) &"|||"& BoardID &"|||"& MyUserInfo &"|||"&FoundUserPermission_All()&"|||0||||||Dvbbs"

End If

Else

MyUserInfo = "Dvbbs|||"& Now & "|||" & DateAdd("s",-3600,Now()) &"|||"& BoardID &"|||"& MyUserInfo &"|||"&FoundUserPermission_All()&"|||0||||||Dvbbs"

End If

Rs.Close:Set Rs = Nothing

MyUserInfo = Split(MyUserInfo,"|||")

If FoundMyGroupID > 0 Then MyUserInfo(19) = FoundMyGroupID

If Trim(MyUserInfo(35)) = Memberword And Trim(MyUserInfo(5)) =Membername Then

Session(CacheName & "UserID") = MyUserInfo

Memberword = MyUserInfo(35)

GetCacheUserInfo()

Else

If IsArray(Session(CacheName & "UserID")) Then

If Session(CacheName & "UserID")(0)="Dvbbs" Then

If Trim(Session(CacheName & "UserID")(4))=Trim(MyUserInfo(4)) And Trim(Session(CacheName & "UserID")(5))=Trim(MyUserInfo(5)) And Trim(Session(CacheName & "UserID")(6))=Trim(MyUserInfo(6)) Then

If Request.ServerVariables("QUERY_STRING")<>"" Then

Session("LoadCache")=ScriptName&"?"&Request.ServerVariables("QUERY_STRING")

Else

Session("LoadCache")=ScriptName

End If

Response.Redirect "newpass.asp"

End If

Else

UserID = 0

EmptyCookies

LetGuestSession()

End If

Else

UserID = 0

EmptyCookies

LetGuestSession()

End If

End Sub

'用户登录成功后，采用本函数读取用户数组并判断一些常用信息

Public Sub GetCacheUserInfo()

MyUserInfo = Session(CacheName & "UserID")

UserInfoCount = Ubound(Session(CacheName & "UserID"))

UserID = Clng(MyUserInfo(4))

MemberName = MyUserInfo(5)

Lastlogin = MyUserInfo(15)

If Not IsDate(LastLogin) Then LastLogin = Now()

UserGroupID = Cint(MyUserInfo(19))

If Trim(MyUserInfo(36))="" Then

Execute("Update [Dv_User] Set UserToday='0|0|0|0|0' Where UserID = " & UserID)

MyUserInfo(36) = "0|0|0|0|0"

UserToday = Split(MyUserInfo(36),"|")

Else

UserToday = Split(MyUserInfo(36),"|")

If Ubound(UserToday) <> 4 Then

Execute("Update [Dv_User] Set UserToday='0|0|0|0|0' Where UserID = " & UserID)

MyUserInfo(36) = "0|0|0|0|0"

UserToday = Split(MyUserInfo(36),"|")

End If

'判断是否VIP组成员

If Not IsNull(MyUserInfo(41)) or MyUserInfo(41)<>"" Then

If IsDate(MyUserInfo(41)) Then

If DateDiff("d",Now(),MyUserInfo(41))>0 Then

VipGroupUser = True

Else

Dim tRs

'将已过期的VIP用户移回注册组并清空有效时间

If UserGroupID>8 Then

Set tRs=Execute("Select Top 1 * From Dv_UserGroups Where ParentGID=3 And MinArticle<="&MyUserInfo(8)&" Order By MinArticle Desc")

If not tRs.Eof Then

Execute("Update Dv_User Set UserClass='"&tRs("UserTitle")&"',TitlePic='"&tRs("GroupPic")&"',UserGroupID="&tRs("UserGroupID")&",Vip_StarTime=null,Vip_EndTime=null Where UserID="&UserID)

End If

Set tRs=Nothing

Else

Execute("Update Dv_User Set Vip_StarTime=null,Vip_EndTime=null Where UserID="&UserID)

End If

MyUserInfo(40) = ""

MyUserInfo(41) = ""

Session(CacheName & "UserID") = MyUserInfo

End If

Select Case UserGroupID

Case 8

Vipuser = True

Case 3

Boardmaster = True

Case 2

Superboardmaster = True

Case 1

Master = True

End Select

If MyUserInfo(31) = "1" Then FoundIsChallenge = True

If DateDiff("d",LastLogin,Now())<>0 Then

Execute("Update [Dv_User] Set UserToday='0|0|0|0|0',LastLogin = " & SqlNowString & " Where UserID = " & UserID)

MyUserInfo(36) = "0|0|0|0|0"

LastLogin = Now()

End If

If Userhidden = 2 and DateDiff("s",Lastlogin,Now())>Clng(Forum_Setting(8))*60 Then

Execute("Update [Dv_User] Set UserLastIP = '" & UserTrueIP & "',LastLogin = " & SqlNowString & " Where UserID = " & UserID)

Lastlogin = Now()

End If

sendmsgnum=0:sendmsgid=0:sendmsguser=""

If MyUserInfo(30)<>"" Then

Dim Usermsg

Usermsg=Split(MyUserInfo(30),"||")

If Ubound(Usermsg)=2 Then

sendmsgnum=Usermsg(0)

sendmsgid=Usermsg(1)

sendmsguser=Usermsg(2)

End If

If IsNull(MyUserInfo(39)) Then

MyUserInfo(39)=""

Else

MyUserInfo(39) = Replace(Trim(MyUserInfo(39))&"",Chr(13),"")

End If

'跟踪用户处理

If MyUserInfo(39)<>"" Then

Dim ToolsFollowUserID,i,Rs,Tools_inceptid,Tools_newincept,Tools_msginfo

ToolsFollowUserID = Split(MyUserInfo(39),",")

For i=0 To Ubound(ToolsFollowUserID)

If Len(ToolsFollowUserID(i))>0 and Len(ToolsFollowUserID(i))<50 and ToolsFollowUserID(i)<>"" Then

ToolsFollowUserID(i) = CheckStr(ToolsFollowUserID(i))

Execute("Insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"& ToolsFollowUserID(i)&"','系统消息','您跟踪的用户"&Dvbbs.MemberName&"已登录','您使用了论坛道具“狗仔队”，您所跟踪的用户 "&Dvbbs.Membername&" 于 "&Now()&" 登录了论坛，请您及时和该用户取得联系，感谢您采用我们的服务。',"&SqlNowString&",0,1)")

Set Rs=Execute("Select top 1 id,sender From Dv_Message Where incept ='"& ToolsFollowUserID(i) &"'")

Tools_inceptid=Rs(0) &"||"& Rs(1)

Set Rs=Execute("Select Count(id) From Dv_Message Where Flag=0 and issend=1 and delR=0 And incept='"& ToolsFollowUserID(i) &"'")

Tools_newincept = Rs(0)

Set Rs=Nothing

If IsNull(Tools_newincept) Then Tools_newincept=0

Tools_msginfo=Tools_newincept & "||" & Tools_inceptid

Execute("update [dv_user] set UserMsg='"&CheckStr(Tools_msginfo)&"' where username='"&ToolsFollowUserID(i)&"'")

End If

MyUserInfo(39) = ""

Execute("UpDate Dv_User Set FollowMsgID='' Where UserID="&UserID)

End If

FoundUser=True

MyUserInfo(15)=Lastlogin

'用户头像处理

Dim iUserMagicFace

iUserMagicFace = Split(MyUserInfo(11),"|")

If Ubound(iUserMagicFace) = 1 Then MyUserInfo(11) = iUserMagicFace(1)

Session(CacheName & "UserID")=MyUserInfo

End Sub

Public Sub EmptyCookies()

Response.Cookies(Forum_sn)("usercookies") = 0

Response.Cookies(Forum_sn).path=cookiepath

Response.Cookies(Forum_sn)("username") = ""

Response.Cookies(Forum_sn)("UserID") = 0

Response.Cookies(Forum_sn)("userclass") = ""

Response.Cookies(Forum_sn)("userhidden") = 2

Response.Cookies(Forum_sn)("password") = ""

End Sub

Private Sub GetGroupSetting()

Dim tGroupSetting

Name = "GroupSetting_" & UserGroupID

tGroupSetting = Split(value,"§§§")

GroupSetting = Split(tGroupSetting(0),",")

UserGroupParent = Cint(tGroupSetting(1))

UserGroupParentID = Split(tGroupSetting(2),"|")

IsUserPermissionAll = MyUserInfo(Ubound(MyUserInfo)-3)

If Cint(GroupSetting(0))=0 And Not Page_Admin Then AddErrCode "8":Showerr()

If BoardID > 0 And Not ScriptName="showerr.asp" Then BoardInfoData=CheckBoardInfo()

If UserID > 0 And BoardID=0 Then

If IsUserPermissionAll="1" Then LoadUserPermission_All()

End If

End Sub

'输出缓存用户组GroupSetting(58)设置（用户名在帖子内容中显示标记）组ID,姓名代码|||

Public Function GroupSetting_UserName()

Name="GroupSetting_UserName"

GroupSetting_UserName = value

End Function

'用户是否存在论坛全局自定义权限

Public Function FoundUserPermission_All()

Dim PerRs

FoundUserPermission_All = 0

Set PerRs=Execute("Select Uc_Setting From Dv_UserAccess Where Uc_Boardid=0 And uc_UserID="&UserID)

If Not (PerRs.Eof And PerRs.Bof) Then FoundUserPermission_All = 1

PerRs.Close:Set PerRs=Nothing

End Function

Public Sub LoadUserPermission_All()

Dim Rs

Set Rs=Dvbbs.execute("Select Uc_Setting From Dv_UserAccess Where Uc_Boardid=0 And uc_UserID="&UserID)

If Not(Rs.Eof And Rs.Bof) Then

UserPermission=Split(Rs(0),",")

GroupSetting = Split(Rs(0),",")

FoundUserPer=True

End If

Set Rs=Nothing

End Sub

Public Sub ActiveOnline()

Dim ReflashPageLastTime,LastVisiBoardID

ReflashPageLastTime = Session(CacheName & "UserID")(1)

LastVisiBoardID = Clng(Session(CacheName & "UserID")(3))

If Not IsDate(ReflashPageLastTime) Then ReflashPageLastTime = Now()

'当在120秒内刷新同一个页面则不更新online数据

If DateDiff("s",ReflashPageLastTime,Now()) < 120 And LastVisiBoardID = BoardID And Not InStr(ScriptName,"showerr")>0 Then Exit Sub

'更新数组

ReflashPageLastTime = Session(CacheName & "UserID")

ReflashPageLastTime(1) = Now()

ReflashPageLastTime(3) = Dvbbs.BoardID

Session(CacheName & "UserID") = ReflashPageLastTime

UserActiveOnline

End Sub

Private Sub UserActiveOnline()

Dim Actcome,SQl,Rs

Dim uip,StatsStr

uip = UserTrueIP

StatsStr = Stats

StatsStr = Replace(StatsStr, "'", "")

StatsStr = Replace(StatsStr, Chr(0), "")

StatsStr = Replace(StatsStr, "--", "——")

StatsStr = Left(StatsStr, 250)

If UserID = 0 Then

Dim StatUserID

StatUserID = Session(CacheName & "UserID")(0)

SQL = "Select ID,Boardid From [Dv_Online] Where ID = " & Ccur(StatUserID)

Set Rs = Execute(SQL)

If Rs.Eof And Rs.Bof Then

If CInt(Forum_Setting(36)) = 0 Then

Actcome = ""

Else

Actcome = address(uip)

End If

GetBrowser()

'不记录搜索引擎的客人 2004-8-30 Dv.Yz

If IsSearch Or (Browser="unknown" And Version="unknown" And Platform="unknown") Then

Exit Sub

End If

SQL = "Insert Into [Dv_Online](ID,Username,Userclass,Ip,Startime,Lastimebk,Boardid,Browser,Stats,Usergroupid,Actcome,Userhidden) Values (" & StatUserID & ",'客人','客人','" & UserTrueIP & "'," & SqlNowString & "," & SqlNowString & "," & Boardid & ",'" & platform&"|"&Browser&version & "','" & StatsStr & "',7,'" & Actcome & "'," & Userhidden & ")"

'更新缓存总在线数据

MyBoardOnline.Forum_Online=MyBoardOnline.Forum_Online+1

Name="Forum_Online"

value=MyBoardOnline.Forum_Online

Else

SQL = "Update [Dv_Online] Set Lastimebk = " & SqlNowString & ",Boardid = " & Boardid & ",Stats = '" & StatsStr & "' Where ID = " & Ccur(StatUserID)

End If

Rs.Close

Set Rs = Nothing

Execute(SQL)

Else

SQL = "Select ID,Boardid From [DV_Online] Where UserID = " & UserID

Set Rs = Execute(SQL)

If Rs.Eof And Rs.Bof Then

If CInt(forum_setting(36)) = 0 Then

Actcome = ""

Else

Actcome = address(uip)

End If

GetBrowser

SQL = "Insert Into [Dv_Online](ID,Username,Userclass,Ip,Startime,Lastimebk,Boardid,Browser,Stats,Usergroupid,Actcome,Userhidden,UserID) Values (" & Session.SessionID & ",'" & Membername & "','" & Memberclass & "','" & UserTrueIP & "'," & SqlNowString & "," & SqlNowString & "," & Boardid & ",'" & platform&"|"&Browser&version & "','" & StatsStr & "'," & UserGroupID & ",'" & Actcome & "'," & Userhidden & "," & UserID & ")"

'更新缓存总在线数据

MyBoardOnline.Forum_Online=MyBoardOnline.Forum_Online+1

Name="Forum_Online"

Dvbbs.value=MyBoardOnline.Forum_Online

'更新缓存总用户在线数据

MyBoardOnline.Forum_UserOnline=MyBoardOnline.Forum_UserOnline+1

Name="Forum_UserOnline"

value=MyBoardOnline.Forum_UserOnline

Else

SQL = "Update [Dv_Online] Set Lastimebk = " & SqlNowString & ",Boardid = " & Boardid & ",Stats = '" & StatsStr & "' Where UserID = " & UserID

End If

Rs.Close

Set Rs = Nothing

Execute(SQL)

End If

'更新在线峰值

If CLng(MyBoardOnline.Forum_Online) > CLng(Maxonline) Then

Execute("update [Dv_setup] set Forum_Maxonline="&CLng(MyBoardOnline.Forum_Online)&",Forum_MaxonlineDate="& SqlNowString)

CacheData(5,0)=MyBoardOnline.Forum_Online

CacheData(6,0)=Now()

Name="setup"

value=CacheData

End If

Rem 删除超时用户

MyBoardOnline.OnlineQuery

End Sub

Public Sub Nav()

Head()

ShowTopTable()

IsTopTable = 1

End Sub

Public Sub head()

Nowstats=stats

If BoardID > 0 And ScriptName<>"printpage.asp" Then Stats=BoardType&"-"&Stats

Stats=Replace(Stats,Chr(34),""")

Stats=Replace(Stats,Chr(13),"")

Dim re,TitleStats

Set re=new RegExp

re.IgnoreCase =True

re.Global=True

re.Pattern="<(.[^>]*)>"

TitleStats=re.Replace(Stats, "")

re.Pattern=""""

TitleStats=re.Replace(TitleStats, """)

Set Re=Nothing

Response.Write Replace(Replace(Replace(mainhtml(1),"{$keyword}",Replace(Forum_info(8),"|",",")),"{$description}",Forum_info(10))&vbNewLine,"{$title}",Forum_Info(0)&"-"&TitleStats)

Response.Write Forum_CSS

Response.Write Chr(10)

Response.Write mainhtml(2)

'论坛防刷新设置

If Cint(Forum_Setting(19))=1 And Not Page_Admin Then

Dim DoReflashPage

DoReflashPage=false

If Trim(Forum_Setting(64))<>"" And InStr(LCase(Forum_Setting(64)),ScriptName) >0 Then DoReflashPage=True

If (Not IsEmpty(Session(CacheName & "UserID")(1))) And Cint(Forum_Setting(20))>0 And DoReflashPage Then

If DateDiff("s",Session(CacheName & "UserID")(1),Now())<Cint(Forum_Setting(20)) Then

Response.Write "<META http-equiv=Content-Type content=text/html; charset=gb2312><meta HTTP-EQUIV=REFRESH CONTENT="&Forum_Setting(20)&"> 本页面起用了防刷新机制，请不要在"&Forum_Setting(20)&"秒内连续刷新本页面 正在打开页面，请稍后……"

Response.End

Else

DoReflashPage=Session(CacheName & "UserID")

DoReflashPage(1)=Now()

Session(CacheName & "UserID")=DoReflashPage

End If

ElseIf IsEmpty(Session(CacheName & "UserID")(1)) and Cint(Forum_Setting(20))>0 and DoReflashPage Then

DoReflashPage=Session(CacheName & "UserID")

DoReflashPage(1)=Now()

Session(CacheName & "UserID")=DoReflashPage

End If

End Sub

Public Sub ShowTopTable()

Dim TempStr,ForumMenu,Tempstr1

Dim RayMenuInfo,RayMenu

If UserID = 0 Then

sysmenu = mainhtml(7)

Else

sysmenu = Replace(mainhtml(6),"{$username}",Membername)

If UserHidden=2 Then

sysmenu = Replace(sysmenu,"{$hiddeninfo}",lanstr(3))

Else

sysmenu = Replace(sysmenu,"{$hiddeninfo}",lanstr(4))

End If

If Master Or GroupSetting(70)="1" Then

sysmenu = Replace(sysmenu,"{$manageinfo}",mainhtml(10))

Else

sysmenu = Replace(sysmenu,"{$manageinfo}","")

End If

If Forum_ChanSetting(0)="1" Then

RayMenuInfo = Split(mainhtml(11),"||")

RayMenu = Replace(Replace(RayMenuInfo(4),"{$channame}",CacheData(23,0)),"{$forumurl}",Forum_Info(1))

If FoundIsChallenge Then

RayMenu = RayMenu & RayMenuInfo(2)

Else

RayMenu = RayMenu & RayMenuInfo(3)

End If

RayMenu = Replace(RayMenuInfo(1),"{$raymenu}",RayMenu)

sysmenu = Replace(sysmenu,"{$raymenuinfo}",RayMenuInfo(0))

Else

sysmenu = Replace(sysmenu,"{$raymenuinfo}","")

End If

sysmenu = Replace(sysmenu,"{$userid}",UserID)

Response.Write RayMenu

End If

If Forum_Setting(90)=0 Then

sysmenu = Replace(sysmenu,"{$Plus_Tools}","")

Else

sysmenu = Replace(sysmenu,"{$Plus_Tools}",mainhtml(16))

End If

If GroupSetting(57) = "1" Then

Name = "StyleList_All"

Tempstr1=Value

If Dvbbs.BoardID = 0 Then

TempStr1 = Replace(TempStr1,"{$dskinid}",CacheData(17,0))

Else

TempStr1 = Replace(TempStr1,"{$dskinid}",Sid)

End If

Else

mainhtml(9)=Replace(Replace(Replace(Replace(mainhtml(9),"\","\"),"'","'"),VbCrLf,"n"),chr(13),"")

mainhtml(9) = Split(mainhtml(9),"||")

Tempstr1=Replace(Replace(mainhtml(9)(0),"{$dskinid}",CacheData(17,0)),"{$csslist}","")

End If

sysmenu = Replace(sysmenu,"{$syles}",Tempstr1)

TempStr = TempStr & Chr(10) & mainhtml(4)

TempStr = Replace(TempStr,"{$width}",mainsetting(0))

TempStr = Replace(TempStr,"{$link}",Forum_Info(1))

If Boardid>0 Then

If Board_Setting(51)="" Or Board_Setting(51) = "0" Then

TempStr = Replace(TempStr,"{$logo}",Forum_Info(6))

Else

TempStr = Replace(TempStr,"{$logo}",Board_Setting(51))

End If

Else

TempStr = Replace(TempStr,"{$logo}",Forum_Info(6))

End If

If Trim(Forum_info(7))<>"0" And Trim(Forum_info(7))<>"" Then

TempStr = Replace(TempStr,"{$mailto}",Forum_Info(7))

Else

TempStr = Replace(TempStr,"{$mailto}","mailto:" & Forum_Info(5))

End If

TempStr = Replace(TempStr,"{$title}",Forum_Info(0) & "-" & Replace(stats,"'","\'"))

TempStr = Replace(TempStr,"{$top_ads}",Forum_ads(0))

TempStr = Replace(TempStr,"{$menu}",Chr(10) & sysmenu)

TempStr = Replace(TempStr,"{$boardid}",boardid)

TempStr = Replace(TempStr,"{$alertcolor}",mainsetting(1))

Name = "ForumPlusMenu"

ForumMenu = Value

If ForumMenu <> "" Then

TempStr = Replace(TempStr,"{$plusmenu}"," <img src="&mainpic(18)&" align=absmiddle> " & ForumMenu)

Else

TempStr = Replace(TempStr,"{$plusmenu}","")

End If

Response.Write TempStr

TempStr = ""

End Sub

Public Sub Head_var(IsBoard,idepth,GetTitle,GetUrl)

Dim NavStr,AllBoardList

If Dvbbs.BoardID=0 Then BoardReadme=lanstr(2) & " " & Forum_Info(0) & ""

If BoardID>0 Then

NavStr = " <a href="&Forum_Info(11)&" onMouseOver=""showmenu(event,BoardJumpList(0),'',0);"" style=""CURSOR:hand"">"&Forum_info(0)&"</a> → "

Else

NavStr = " <a href="&Forum_Info(11)&">"&Forum_info(0)&"</a> → "

End If

If IsBoard=1 Then

BoardType = Replace(Replace(BoardType,Chr(39),"'"),Chr(34), """)

If BoardParentID=0 Then

NavStr = NavStr & " <a href=""index.asp?boardid="&BoardID&""" onMouseOver=""showmenu(event,BoardJumpList("&Dvbbs.Boardid&"),'',0);"">"&BoardType&"</a>"

Else

If ScriptName="dispbbs.asp" Then

NavStr = NavStr & BoardInfoData & " → <a href=""index.asp?boardid="&BoardID&"&page="&Request("page")&""">"&BoardType&"</a>"

Else

NavStr = NavStr & BoardInfoData & " → <a href=""index.asp?boardid="&BoardID&""">"&BoardType&"</a>"

End If

NavStr = NavStr & " → " & Nowstats

Elseif IsBoard=2 Then

NavStr = NavStr & Nowstats

Else

NavStr = NavStr & "<a href="&GetUrl&">"&GetTitle&"</a> → " & Nowstats

End If

BoardReadme=Replace(Replace(Replace(BoardReadme&"","\n",""),"\r",""),"\","")

NavStr = Replace(mainhtml(5),"{$nav}",NavStr)

NavStr = Replace(NavStr,"{$width}",mainsetting(0))

NavStr = Replace(NavStr,"{$boardreadme}",BoardReadme)

If UserID>0 Then

'sendmsgnum,sendmsgid,sendmsguser

IsBoard = Split(mainhtml(12),"||")

If Clng(SendMsgNum)>0 Then

BoardReadme = IsBoard(0)

If Forum_Setting(10)=1 Then

BoardReadme = BoardReadme & IsBoard(1) & IsBoard(2)

Else

BoardReadme = BoardReadme & IsBoard(2)

End If

BoardReadme = Replace(BoardReadme,"{$smsid}",sendmsgid)

BoardReadme = Replace(BoardReadme,"{$sender}",sendmsguser)

BoardReadme = Replace(BoardReadme,"{$newmsgnum}",sendmsgnum)

Else

BoardReadme = IsBoard(3)

End If

Dim i,UserGroupList,iGroupName

IsUserPermissionOnly = MyUserInfo(Ubound(MyUserInfo)-2)

If UserGroupParent = 4 Then

BoardReadme = BoardReadme & IsBoard(4)

For i = 0 To Ubound(UserGroupParentID)

Name = "GroupSetting_" & UserGroupParentID(i)

iGroupName = Split(value,"§§§")(3)

If i = 0 Then

UserGroupList = "<a href=cookies.asp?action=ReGroup&GroupID="&UserGroupParentID(i)&">"&iGroupName&"</a> "

Else

UserGroupList = UserGroupList & "<a href=cookies.asp?action=ReGroup&GroupID="&UserGroupParentID(i)&">"&iGroupName&"</a>"

End If

BoardReadme = Replace(BoardReadme,"{$UserGroupList}",UserGroupList)

ElseIf Cint(IsUserPermissionOnly) > 0 Then

BoardReadme = BoardReadme & IsBoard(4)

Name = "GroupSetting_" & IsUserPermissionOnly

iGroupName = Split(value,"§§§")(3)

UserGroupList = "<a href=cookies.asp?action=ReGroup&GroupID="&IsUserPermissionOnly&">"&iGroupName&"</a> "

BoardReadme = Replace(BoardReadme,"{$UserGroupList}",UserGroupList)

End If

NavStr = Replace(NavStr,"{$umsg}",BoardReadme)

Else

NavStr = Replace(NavStr,"{$umsg}","")

End If

NavStr = Replace(NavStr,"{$alertcolor}",mainsetting(1))

NavStr = Replace(NavStr,"{$showstr}","")

Response.Write vbNewLine & NavStr

End Sub

Public Sub AddErrCode(ErrCode)

If ErrCodes = "" Then

ErrCodes = ErrCode

Else

ErrCodes = ErrCodes & "," & ErrCode

End If

End Sub

Public Property Let ErrType(ByVal Value)

ShowErrType = Value

End Property

Public Sub Showerr()

If ErrCodes<>"" Then

If ShowErrType = 1 Then

Response.redirect "showerr.asp?BoardID="&Boardid&"&ErrCodes="&ErrCodes&"&action="&server.URLEncode(Stats)&"&ShowErrType=1"

Else

Response.redirect "showerr.asp?BoardID="&Boardid&"&ErrCodes="&ErrCodes&"&action="&server.URLEncode(Stats)

End If

End Sub

Public Sub Footer()

Dim Tmp,CaCheInfo

'CaCheInfo = "<li>"

'CaCheInfo = CaCheInfo & "共使用了" & Application.Contents.Count & "个缓存对象。"

'CaCheInfo=result

Tmp = mainhtml(18)

Tmp = Replace(Tmp,"{$boardid}",boardid)

If (Dvbbs.Forum_ChanSetting(13)="1" And Dvbbs.Forum_ChanSetting(0)="1") Or Dvbbs.Forum_ChanSetting(3)="0" Then

Tmp = Replace(Tmp,"{$UserTicket}"," " & lanstr(11))

Else

Tmp = Replace(Tmp,"{$UserTicket}","")

End If

Response.Write Tmp

Tmp = mainhtml(8)

If Forum_Setting(30) = "1" Then

Dim Endtime

Endtime = Timer()

Tmp = Replace(Tmp,"{$runtime}"," 页面执行时间 0"&FormatNumber((Endtime-Startime),5)&" 秒, "&SqlQueryNum&" 次数据查询 "& CaCheInfo)

End If

Tmp = Replace(Tmp,"{$runtime}","")

Dim Alibaba_Ad

If IsSqlDataBase = 0 Or (IsBuss = 0 And IsSqlDataBase = 1) Or Forum_Info(0)="动网先锋论坛" Then

Alibaba_Ad = "网上贸易创造奇迹! <a href = ""http://china.alibaba.com"" title = ""从网民、网友时代进入“网商”时代"" target=_blank>阿里巴巴</a> <a href = ""http://www.alibaba.com"" title= ""Online Marketplace of Manufacturers & Wholesalers"" target = ""_blank"">Alibaba</a> "

End If

Tmp = Replace(Tmp,"{$powered}",Alibaba_Ad & "Powered By <a href = ""http://www.dvbbs.net/"" target = ""_blank"">Dvbbs</a> <a href = ""http://www.dvbbs.net/download.asp"" target = ""_blank"">Version " & Forum_Version & "</a>")

If Dvbbs.Forum_ChanSetting(3)="0" Then

Tmp = Replace(Tmp,"{$alipaymsg}","<td width=""2%""></td><td align=right valign=bottom><a href=""https://www.alipay.com"" target=_blank><img src="""&Dvbbs_Server_Url&"dvbbs/alipay_icon2.gif"" border=0 alt=""本论坛采用阿里巴巴支付宝网上银行支付系统，安全、可靠、便捷""></a></td>")

Else

Tmp = Replace(Tmp,"{$alipaymsg}","")

End If

Tmp = Replace(Tmp,"{$Footer_ads}",Forum_ads(1))

Tmp = Replace(Tmp,"{$copyright}",Forum_Copyright)

Response.Write Tmp

End Sub

Public Function Dvbbs_Suc(sucmsg)

Dim TempStr

TempStr = mainhtml(13)

TempStr = Replace(TempStr,"{$sucmsg}",sucmsg)

TempStr = Replace(TempStr,"{$returnurl}",Request.ServerVariables("HTTP_REFERER"))

Response.Write TempStr

TempStr = ""

End Function

Public Function Execute(Command)

If Not IsObject(Conn) Then ConnectionDatabase

If IsDeBug = 0 Then

On Error Resume Next

Set Execute = Conn.Execute(Command)

If Err Then

err.Clear

Set Conn = Nothing

If savelog=1 Then

Response.Write SaveSQLLOG(Command,"查询数据的时候发现错误，请检查您的查询代码是否正确。 基于安全的理由，只显示本信息，要查看详细的错误信息，请修改您的程序文件conn.asp。把""Const IsDeBug = 0""改为：""Const IsDeBug = 1""")

Else

Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。"

End If

Response.End

End If

Else

'Response.Write command & " "

Set Execute = Conn.Execute(Command)

End If

SqlQueryNum = SqlQueryNum+1

End Function

'-----------------------------------------------------------------------------------------------------

'独立道具查询

Public Function Plus_Execute(Command)

If Cint(Forum_Setting(92))=1 Then

If Not IsObject(Plus_Conn) Then Plus_ConnectionDatabase

Else

If Not IsObject(Conn) Then ConnectionDatabase

End IF

'检查权限,防止注入攻击。

If InStr(LCase(Command),"dv_admin")>0 And Left(ScriptName,6)<> "admin_" Then

If savelog=1 Then

Response.Write SaveSQLLOG(Command,"")

End If

Command=Replace(LCase(Command),"dv_admin","dv"&Chr(95)&"admin")

End If

If IsDeBug = 0 Then

On Error Resume Next

If Cint(Forum_Setting(92))=1 Then

Set Plus_Execute = Plus_Conn.Execute(Command)

Else

Set Plus_Execute = Conn.Execute(Command)

End If

If Err Then

err.Clear

If Cint(Forum_Setting(92))=1 Then

Set Plus_Conn = Nothing

Else

Set Conn = Nothing

End If

If savelog=1 Then

Else

Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。"

End If

Response.End

End If

Else

'Response.Write command & " "

If Cint(Forum_Setting(92))=1 Then

Set Plus_Execute = Plus_Conn.Execute(Command)

Else

Set Plus_Execute = Conn.Execute(Command)

End If

SqlQueryNum = SqlQueryNum+1

End Function

'-----------------------------------------------------------------------------------------------------

'记录查询错误事件

Public Function SaveSQLLOG(sCommand,message)

Dim lConnStr,lConn,ldb

ldb = MyDbPath & "data/DvSQLLOG.mdb"

'Response.Write ldb

lConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)

Set lConn = Server.CreateObject("ADODB.Connection")

lConn.Open lConnStr

lConn.Execute("Insert Into dv_sql_log (ScriptName,S_Info,ip) Values ('"&ScriptName&"','"&Replace(Left(sCommand,255),"'","''")&"','"&UserTrueIP&"')")

lConn.Close

Set lConn = Nothing

SaveSQLLOG = message

End Function

Public Sub ChecKIPlock()

Dim IPlock

IPlock = False

Dim locklist

locklist=Trim(CacheData(25,0))

If locklist="" Then Exit Sub

Dim i,StrUserIP,StrKillIP

StrUserIP=UserTrueIP

locklist=Split(locklist,"|")

If StrUserIP="" Then Exit Sub

StrUserIP=Split(UserTrueIP,".")

If Ubound(StrUserIP)<>3 Then Exit Sub

For i= 0 to UBound(locklist)

locklist(i)=Trim(locklist(i))

If locklist(i)<>"" Then

StrKillIP = Split(locklist(i),".")

If Ubound(StrKillIP)<>3 Then Exit For

IPlock = True

If (StrUserIP(0) <> StrKillIP(0)) And Instr(StrKillIP(0),"*")=0 Then IPlock=False

If (StrUserIP(1) <> StrKillIP(1)) And Instr(StrKillIP(1),"*")=0 Then IPlock=False

If (StrUserIP(2) <> StrKillIP(2)) And Instr(StrKillIP(2),"*")=0 Then IPlock=False

If (StrUserIP(3) <> StrKillIP(3)) And Instr(StrKillIP(3),"*")=0 Then IPlock=False

If IPlock Then Exit For

End If

Response.Cookies(Forum_sn & "Kill").Expires = DateAdd("s", 360, Now())

Response.Cookies(Forum_sn & "Kill").Path = Cookiepath

If IPlock Then

Response.Cookies(Forum_sn & "Kill")("kill") = "1"

Else

Response.Cookies(Forum_sn & "Kill")("kill") = "0"

End If

End Sub

'IP/来源

Public Function address(sip)

Dim aConnStr,aConn,adb

Dim str1,str2,str3,str4

Dim num

Dim country,city

Dim irs,SQL

address="未知"

If IsNumeric(Left(sip,2)) Then

If sip="127.0.0.1" Then sip="192.168.0.1"

str1=Left(sip,InStr(sip,".")-1)

sip=mid(sip,instr(sip,".")+1)

str2=Left(sip,instr(sip,".")-1)

sip=Mid(sip,InStr(sip,".")+1)

str3=Left(sip,instr(sip,".")-1)

str4=Mid(sip,instr(sip,".")+1)

If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then

Else

num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1

adb = "data/ipaddress.mdb"

aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)

Set AConn = Server.CreateObject("ADODB.Connection")

aConn.Open aConnStr

country="亚洲"

city=""

sql="select top 1 country,city from dv_address where ip1 <="&num&" and ip2 >="&num&""

Set irs=aConn.execute(sql)

If Not(irs.EOF And irs.bof) Then

country=irs(0)

city=irs(1)

End If

Set irs=Nothing

Set aConn = Nothing

SqlQueryNum = SqlQueryNum+1

End If

address=country&city

End If

End Function

'显示验证码

Public Function GetCode()

GetCode= Dvbbs.mainhtml(15)&"<img src=""DV_getcode.asp"">"

End Function

'检查验证码是否正确

Public Function CodeIsTrue()

Dim CodeStr

CodeStr=Trim(Request("CodeStr"))

If CStr(Session("GetCode"))=CStr(CodeStr) And CodeStr<>"" Then

CodeIsTrue=True

Session("GetCode")=empty

Else

CodeIsTrue=False

Session("GetCode")=empty

End If

End Function

'用于用户发布的各种信息过滤，带脏话过滤

Public 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), " ")

fString=ChkBadWords(fString)

HTMLEncode = fString

End If

End Function

'用于论坛本身的过滤，不带脏话过滤

Public Function iHTMLEncode(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), " ")

iHTMLEncode = fString

End If

End Function

Public Function CheckNumeric(Byval CHECK_ID)

If CHECK_ID<>"" and IsNumeric(CHECK_ID) Then _

CHECK_ID = cCur(CHECK_ID) _

Else _

CHECK_ID = 0

CheckNumeric = CHECK_ID

End Function

Public Function strLength(str)

If isNull(str) Or Str = "" Then

StrLength = 0

Exit Function

End If

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

strLength=t

Else

strLength=len(str)

End If

End Function

Public Function ChkBadWords(Str)

If IsNull(Str) Then Exit Function

Dim i

For i = 0 To UBound(BadWords)

If InStr(Str,BadWords(i))>0 Then

If i > UBound(rBadWord) Then

Str = Replace(Str,BadWords(i),"*")

Else

Str = Replace(Str,BadWords(i),rBadWord(i))

End If

ChkBadWords = Str

End Function

Public Function Checkstr(Str)

If Isnull(Str) Then

CheckStr = ""

Exit Function

End If

Str = Replace(Str,Chr(0),"")

CheckStr = Replace(Str,"'","''")

End Function

Public Sub ReloadBoardInfo(lboardid)

NodeUpdate=True

'Response.Write "ReloadBoardInfo="&lboardid &" "

Dim Rs,Node,i,BoardPath,BoardMasterList,BoardMaster,CNode

Set Rs=Execute("Select boardid,BoardType,ParentID,ParentStr,Depth,RootID,Child,readme,BoardMaster,PostNum,TopicNum,indexIMG,todayNum,boarduser,LastPost,Sid,Board_Setting,Board_Ads,Board_user,IsGroupSetting,BoardTopStr,cid,Rules From Dv_Board where boardid in ("& lboardid &") Order By RootID,orders")

Dim Board_setting,lastpost

Do while Not Rs.EOF

Board_setting=Split(Rs("Board_setting")&"",",")

BoardPath = "board"

For i=1 To Rs("Depth")

BoardPath = "board/"&BoardPath

Set Node=BoardXML.documentElement.selectSingleNode(BoardPath&"[@boardid='"&Rs(0)&"']")

For i = 0 To Rs.Fields.Count-1

Node.attributes.getNamedItem(LCase(Rs(i).name)).text = Rs(i)&""

lastpost=Split(Rs("lastpost")&"","$")

For i=0 to UBound(LastPost)

Node.attributes.getNamedItem("lastpost"&i).text=LastPost(i)

For Each cnode In Node.selectNodes("boardmasterlist")

node.removeChild(Cnode)

BoardMasterList=Split(Rs("BoardMaster")&"","|")

i=0

For Each BoardMaster in BoardMasterlist

Set CNode=Node.appendChild(BoardXML.createNode(1,"boardmasterlist",""))

CNode.attributes.setNamedItem(BoardXML.createNode(2,"master","")).text=BoardMaster

CNode.attributes.setNamedItem(BoardXML.createNode(2,"urlencode","")).text=Server.urlencode(BoardMaster)

CNode.attributes.setNamedItem(BoardXML.createNode(2,"order","")).text=i

i=i+1

Rs.MoveNext

Loop

Rs.Close

Set Rs = Nothing

End Sub

'更新分版面部分缓存数组，入口：版面ID列表,豆号分隔、更新内容、节点名称

Public Sub ReloadBoardCache(lBoardID,MyValue,TagName)

NodeUpdate=True

'Response.Write "ReloadBoardCache="& lBoardID &" MyValue="&MyValue&" TagName="&TagName&" "

lBoardID=Split(lBoardID,",")

Dim Nodelist,Node,i,lastpost,j,cnode,BoardMasterList,BoardMaster

Set Nodelist=BoardXML.documentElement.getElementsByTagName("board")

For i=0 to UBound(lBoardID)

For Each Node in nodelist

If Cstr(lBoardID(i))=Node.attributes.getNamedItem("boardid").text Then

Node.attributes.getNamedItem(TagName).text=MyValue

If TagName="lastpost" Then

lastpost=Split(MyValue,"$")

For j=0 to UBound(LastPost)

Node.attributes.getNamedItem("lastpost"&j).text=LastPost(i)

End If

If TagName="boardmaster" Then

For Each cnode In Node.selectNodes("boardmasterlist")

node.removeChild(Cnode)

BoardMasterList=Split(MyValue,"|")

j=0

For Each BoardMaster in BoardMasterlist

Set CNode=Node.appendChild(BoardXML.createNode(1,"boardmasterlist",""))

CNode.attributes.setNamedItem(BoardXML.createNode(2,"master","")).text=BoardMaster

CNode.attributes.setNamedItem(BoardXML.createNode(2,"urlencode","")).text=Server.urlencode(BoardMaster)

CNode.attributes.setNamedItem(BoardXML.createNode(2,"order","")).text=j

j=j+1

End If

Exit For

End If

End Sub

'取得带端口的URL

Property Get Get_ScriptNameUrl()

If request.servervariables("SERVER_PORT")="80" Then

Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")

Else

Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")

End If

End Property

Public Sub GetBrowser()

Dim Agent,Tmpstr,i

IsSearch = False

If Not IsEmpty(Session(Dvbbs.CacheName & "Cls_Browser")) Then

Tmpstr = Split(Session(Dvbbs.CacheName & "Cls_Browser"),"|||")

Browser = Dvbbs.checkStr(Tmpstr(0))

version = Dvbbs.checkStr(Tmpstr(1))

platform = Dvbbs.checkStr(Tmpstr(2))

If Tmpstr(3)="1" Then

IsSearch = True

End If

Exit Sub

End If

Browser="unknown"

version="unknown"

platform="unknown"

Agent=Request.ServerVariables("HTTP_USER_AGENT")

'Agent="Opera/7.23 (X11; Linux i686; U) [en]"

If Left(Agent,7) ="Mozilla" Then '有此标识为浏览器

Agent=Split(Agent,";")

If InStr(Agent(1),"MSIE")>0 Then

Browser="Microsoft Internet Explorer "

version=Trim(Left(Replace(Agent(1),"MSIE",""),6))

ElseIf InStr(Agent(4),"Netscape")>0 Then

Browser="Netscape "

tmpstr=Split(Agent(4),"/")

version=tmpstr(UBound(tmpstr))

ElseIf InStr(Agent(4),"rv:")>0 Then

Browser="Mozilla "

tmpstr=Split(Agent(4),":")

version=tmpstr(UBound(tmpstr))

If InStr(version,")") > 0 Then

tmpstr=Split(version,")")

version=tmpstr(0)

End If

If UBound(Agent)>2 Then

platform = UserPlatForm(Agent(2),Agent(3),UBound(Agent))

Else

platform = UserPlatForm(Agent(2),"",UBound(Agent))

End If

ElseIf Left(Agent,5) ="Opera" Then

Agent=Split(Agent,"/")

Browser="Mozilla "

tmpstr=Split(Agent(1)," ")

version=tmpstr(0)

If UBound(Agent)>2 Then

platform = UserPlatForm(Agent(1),Agent(3),UBound(Agent))

Else

platform = UserPlatForm(Agent(1),"",UBound(Agent))

End If

Else

'识别搜索引擎

Dim botlist

Botlist="Google,Isaac,SurveyBot,Baiduspider,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir"

Botlist=split(Botlist,",")

For i=0 to UBound(Botlist)

If InStr(Agent,Botlist(i))>0 Then

platform=Botlist(i)&"搜索器"

IsSearch=True

Exit For

End If

If version<>"unknown" Then

Dim Tmpstr1

Tmpstr1=Trim(Replace(version,".",""))

If Not IsNumeric(Tmpstr1) Then

version="unknown"

End If

If IsSearch Then

Browser=""

version=""

Session(Dvbbs.CacheName & "Cls_Browser") = Browser &"|||"& version &"|||"& platform&"|||1"

Else

Session(Dvbbs.CacheName & "Cls_Browser") = Browser &"|||"& version &"|||"& platform&"|||0"

End If

End Sub

Private Function UserPlatForm(UserAgent1,UserAgent2,UserAgentNum)

If InStr(UserAgent1,"NT 5.2")>0 Then

UserPlatForm="Windows 2003"

ElseIf InStr(UserAgent1,"Windows CE")>0 Then

UserPlatForm="Windows CE"

ElseIf InStr(UserAgent1,"NT 5.1")>0 Then

UserPlatForm="Windows XP"

ElseIf InStr(UserAgent1,"NT 4.0")>0 Then

UserPlatForm="Windows NT"

ElseIf InStr(UserAgent1,"NT 5.0")>0 Then

UserPlatForm="Windows 2000"

ElseIf InStr(UserAgent1,"NT")>0 Then

UserPlatForm="Windows NT"

ElseIf InStr(UserAgent1,"9x")>0 Then

UserPlatForm="Windows ME"

ElseIf InStr(UserAgent1,"98")>0 Then

UserPlatForm="Windows 98"

ElseIf InStr(UserAgent1,"95")>0 Then

UserPlatForm="Windows 95"

ElseIf InStr(UserAgent1,"Win32")>0 Then

UserPlatForm="Win32"

ElseIf InStr(UserAgent1,"Linux")>0 Then

UserPlatForm="Linux"

ElseIf InStr(UserAgent1,"SunOS")>0 Then

UserPlatForm="SunOS"

ElseIf InStr(UserAgent1,"Mac")>0 Then

UserPlatForm="Mac"

ElseIf UserAgentNum>2 Then

If InStr(UserAgent2,"NT 5.1")>0 Then UserPlatForm="Windows XP"

If InStr(UserAgent2,"Linux")>0 Then UserPlatForm="Linux"

End If

End Function

'---------------------------------------------------

'记录道具操作日志信息(发生数量，记录事件类型，备注内容，用户最后剩余金币和点券（金币|点券）)

'Log_ID,ToolsID,CountNum,Log_Money,Log_Ticket,AddUserName,AddUserID,Log_IP,Log_Time,Log_Type,BoardID,Conect,HMoney

'Log_Type类型(0=其它,1=使用,2=转让,3=充值,4=购买,5=奖励,6=vip交易)

'HMoney最后剩余金币和点券（金币|点券）

'boardid 记录版面参数，后台为-1

'---------------------------------------------------

Public Sub ToolsLog(Log_ToolsID,CountNum,Log_Money,Log_Ticket,Log_Type,Conect,HMoney)

Dim Sql

Conect = CheckStr(Conect)

HMoney = CheckStr(HMoney)

Sql = "Insert into [Dv_MoneyLog] (ToolsID,CountNum,Log_Money,Log_Ticket,AddUserName,AddUserID,Log_IP,Log_Type,BoardID,Conect,HMoney) values (" &_

CheckNumeric(Log_ToolsID) &","&_

CheckNumeric(CountNum) &","&_

CheckNumeric(Log_Money) &","&_

CheckNumeric(Log_Ticket) &",'"&_

MemberName &"',"&_

UserID &",'"&_

UserTrueIP &"',"&_

Log_Type &","&_

BoardID &",'"&_

Conect &"','"&_

HMoney &"'"&_

")"

'Response.Write Sql

Dvbbs.Execute(Sql)

End Sub

End Class

Class cls_Templates

Public html,Strings,pic

Public Property Let Value(ByVal vNewValue)

Dim TemplateStr,tmpstr:TemplateStr = vNewValue

TemplateStr = Replace(TemplateStr,"{$PicUrl}",Dvbbs.Forum_PicUrl)

tmpstr = Split(TemplateStr,"@@@")

html = Split(tmpstr(0),"|||"):Strings = Split(tmpstr(1),"|||"):pic = Split(tmpstr(2),"|||")

End Property

End Class

Class cls_UserOnlne

Public Forum_Online,Forum_UserOnline,Forum_GuestOnline

Private l_Online,l_GuestOnline

Private Sub Class_Initialize()

Dvbbs.Name="Forum_Online"

Dvbbs.Reloadtime=60

If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum

Dvbbs.Name="Forum_Online"

Forum_Online = Dvbbs.Value

Dvbbs.Name="Forum_UserOnline"

If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum

Forum_UserOnline=Dvbbs.Value

If Forum_Online < 0 Or Forum_UserOnline < 0 Or Forum_UserOnline > Forum_Online Then ReflashOnlineNum

Forum_GuestOnline = Forum_Online - Forum_UserOnline

l_Online=-1:l_GuestOnline=-1

Dvbbs.Reloadtime=28800

End Sub

Public Sub OnlineQuery()

Dim SQL,SQL1

Dim TempNum,TempNum1

Dvbbs.Name="delOnline_time"

If Dvbbs.ObjIsEmpty() Then Dvbbs.Value=Now()

If DateDiff("s",Dvbbs.Value,Now()) > Clng(Dvbbs.Forum_Setting(8))*10 Then

Dvbbs.Value=Now()

If Not IsObject(Conn) Then ConnectionDatabase

If IsSqlDataBase = 1 Then

SQL = "Delete From [DV_Online] Where UserID=0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & Clng(Dvbbs.Forum_Setting(8))

SQL1 = "Delete From [DV_Online] Where UserID>0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & Clng(Dvbbs.Forum_Setting(8))

Else

SQL = "Delete From [Dv_Online] Where UserID=0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60"

SQL1 = "Delete From [Dv_Online] Where UserID>0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60"

End If

Conn.Execute SQL,TempNum

Conn.Execute SQL1,TempNum1

Dvbbs.SqlQueryNum = Dvbbs.SqlQueryNum + 2

'如果删除客人数大于0，则应该更新总数

If TempNum>0 Then

'更新缓存总在线数据

Forum_Online = Forum_Online - TempNum

Forum_GuestOnline = Forum_GuestOnline - TempNum

End If

'如果删除用户数大于0，则应该更新总数和用户数

If TempNum1>0 Or TempNum>0 Then

'更新缓存总在线数据

Forum_Online = Forum_Online - TempNum1

Forum_UserOnline = Forum_UserOnline - TempNum1

End If

Dvbbs.Name="Forum_Online"

Dvbbs.Value=Forum_Online

'更新缓存总用户在线数据

Dvbbs.Name="Forum_UserOnline"

Dvbbs.Value=Forum_UserOnline

Forum_Online = Forum_Online - TempNum1

End If

End Sub

'刷新在线数据缓存

Public Sub ReflashOnlineNum

Dim Rs

Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online")

Dvbbs.Value=Rs(0)

Forum_Online = Dvbbs.Value

Dvbbs.Name="Forum_UserOnline"

Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online Where UserID>0")

If Not IsNull(Rs(0)) Then

Dvbbs.Value=Rs(0)

Else

Dvbbs.Value=0

End If

Forum_UserOnline = Dvbbs.Value

Set Rs=Nothing

End Sub

'查询在某版面的在线总数

Public Property Get Board_Online

Board_Online=Board_UserOnline+Board_GuestOnline

End Property

Public Property Get Board_GuestOnline

If l_GuestOnline=-1 Then

Dim Rs

Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online where BoardID="&Dvbbs.BoardID&" and UserID=0")

l_GuestOnline=Rs(0):Set Rs= Nothing

End If

If IsNull(l_GuestOnline) Then l_GuestOnline=0

Board_GuestOnline=l_GuestOnline

End Property

Public Property Get Board_UserOnline

If l_Online=-1 Then

Dim Rs

Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online where BoardID="&Dvbbs.BoardID&" and UserID>0")

l_Online=Rs(0):Set Rs= Nothing

End If

Board_UserOnline=l_Online

End Property

End Class

Microsoft VBScript 运行时错误 错误 '800a0009'

Microsoft VBScript 运行时错误错误 '800a0009'