<% '========================================================= ' File: Dv_ClsMain.asp ' Version:7.0 sp3 ' Date: 2004-6-30 ' Script Written by dvbbs.net '========================================================= ' Copyright (C) 2003,2004 AspSky.Net. All rights reserved. ' 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 = Lcase(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 End If End If 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 If 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 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 Next 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 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 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 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 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 End If 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 End If If NeedChecklongin Or (UserID >0 And Not Ubound(Session(CacheName & "UserID"))=45) Or toupdate Then TrueCheckUserLogin End If 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 Next End Function '更新用户验证密码 Public Sub NewPassword() If UserID=0 Then Exit Sub Response.Write "" 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 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 Session(CacheName & "UserID")(5)=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 If Session("flag")<>"" Then Response.Redirect "../newpass.asp" Else Response.Redirect "newpass.asp" End If End If Else UserID = 0 EmptyCookies LetGuestSession() End If Else UserID = 0 EmptyCookies LetGuestSession() End If End If 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 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 End If 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 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 Next 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())
本页面起用了防刷新机制，请不要在"&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 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}"," " & 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 = " "&Forum_info(0)&" → " Else NavStr = " "&Forum_info(0)&" → " End If If IsBoard=1 Then BoardType = Replace(Replace(BoardType,Chr(39),"'"),Chr(34), """) If BoardParentID=0 Then NavStr = NavStr & " "&BoardType&"" Else If ScriptName="dispbbs.asp" Then NavStr = NavStr & BoardInfoData & " → "&BoardType&"" Else NavStr = NavStr & BoardInfoData & " → "&BoardType&"" End If End If NavStr = NavStr & " → " & Nowstats Elseif IsBoard=2 Then NavStr = NavStr & Nowstats Else NavStr = NavStr & ""&GetTitle&" → " & 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 = ""&iGroupName&"
" Else UserGroupList = UserGroupList & ""&iGroupName&"" End If Next BoardReadme = Replace(BoardReadme,"{$UserGroupList}",UserGroupList) ElseIf Cint(IsUserPermissionOnly) > 0 Then BoardReadme = BoardReadme & IsBoard(4) Name = "GroupSetting_" & IsUserPermissionOnly iGroupName = Split(value,"§§§")(3) UserGroupList = ""&iGroupName&"
" 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 If End Sub Public Sub Footer() Dim Tmp,CaCheInfo 'CaCheInfo = "
  • " '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 = "网上贸易 创造奇迹! 阿里巴巴 Alibaba

    " End If Tmp = Replace(Tmp,"{$powered}",Alibaba_Ad & "Powered By Dvbbs Version " & Forum_Version & "") If Dvbbs.Forum_ChanSetting(3)="0" Then Tmp = Replace(Tmp,"{$alipaymsg}","") 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 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 & "
    " If Cint(Forum_Setting(92))=1 Then Set Plus_Execute = Plus_Conn.Execute(Command) Else Set Plus_Execute = Conn.Execute(Command) End If 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 Next 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)&"" 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 Next 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 End If Next 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 Next 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)&"" Next lastpost=Split(Rs("lastpost")&"","$") For i=0 to UBound(LastPost) Node.attributes.getNamedItem("lastpost"&i).text=LastPost(i) Next For Each cnode In Node.selectNodes("boardmasterlist") node.removeChild(Cnode) Next 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 Next 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) Next End If If TagName="boardmaster" Then For Each cnode In Node.selectNodes("boardmasterlist") node.removeChild(Cnode) Next 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 Next End If Exit For End If Next Next 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 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 Next End If If version<>"unknown" Then Dim Tmpstr1 Tmpstr1=Trim(Replace(version,".","")) If Not IsNumeric(Tmpstr1) Then version="unknown" End If 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 Dvbbs.Name="Forum_Online" 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 %>