新留言（"&Temp&"条）"&Info(7)&"
" If Info(26)<>"0" Then If Cache.valid("Hits") Then Hits=Cache.Value("Hits") Hits=Int(Hits) Cache.Add "Hits",Hits+1,dateadd("n",2000,NowBBSTime) If Hits>2000 Then Execute("update [i_config] Set Hits=Hits+2001") Hits=Replace(Join(InfoUpdate,","),InfoUpdate(9)&","&InfoUpdate(10),InfoUpdate(9)+ 2001&","&InfoUpdate(10)) Cache.Add "InfoUpdate",Hits,dateadd("n",2000,NowBBSTime) Cache.clean("Hits") End If End If If Info(26)="1" Then S=S&""&InfoUpdate(9)+Hits&" Call," If Info(24)="1" then S=S&" "&SqlNum&" Queries," S=S&getTimeOver(Info(25)) Response.Write Replace(ReadSkins("页面底部"),"{版"&"权}",S) End Sub '更新等级 参数（用户ID，帖数，标记） Public Sub UpdateGrade(User_ID,Num,Flag) Dim ARs,i,GradeID,Isbe,DefaultID Isbe=False ARs=SetGradeInfoCache() For i=0 To Ubound(ARs,2) If i=0 Then DefaultID=Ars(0,I)'防空 GradeID=Ars(0,I) If (Flag=Ars(1,i) And Flag<>0) Or (Int(Num)=>Int(Ars(5,i)) And Flag=0) Then Isbe=True Exit For End If Next If Not Isbe Then GradeID=DefaultID Execute("update [i_User] Set GradeID="&GradeID&",GradeFlag="&Flag&" where ID="&User_ID&"") End Sub Public Function SetGradeInfoCache() Dim Rs If Cache.valid("GradeInfo") then SetGradeInfoCache=Cache.Value("GradeInfo") Else Set Rs=Execute("Select ID,Flag,GradeName,PIC,Spic,EssayNum,Strings,Grouping From [i_Grade] order by Grouping,EssayNum desc") SetGradeInfoCache=Rs.GetRows(-1) Rs.Close Set Rs=Nothing Cache.add "GradeInfo",SetGradeInfoCache,dateadd("n",5000,now) End If End Function Public Function GetGradeInfo(GradeID) Dim ARs,i ARs=SetGradeInfoCache() For i=0 To Ubound(ARs,2) If int(ARs(0,i))=Int(GradeID) Then GetGradeInfo=ARs(0,i)&"|"&ARs(1,i)&"|"&Ars(2,i)&"|"&Ars(3,i)&"|"&Ars(4,i)&"|"&Ars(5,i)&"|"&Ars(6,i) Exit Function End If Next End Function Public Function GetGradeName(GID,GFlag) Dim ARs,i ARs=SetGradeInfoCache() For i=0 To Ubound(ARs,2) If (int(ARs(0,i))=Int(GID) And GFlag=0) or (GFlag<>0 And GFlag=Int(ARs(1,i))) Then GetGradeName=ARs(2,i) Exit Function End If Next End Function '公告 Public Function Placard(Ast) Dim Temp,Rs,Arr_Rs,i If Cache.valid("Placard") then Arr_Rs=Cache.Value("Placard") Else Set Rs=Execute("Select Id,Caption,AddTime,BoardID From [i_Placard] order by Id desc") If Rs.Eof Or Rs.Bof Then Temp=" " Placard=Temp Exit Function Else Arr_Rs=Rs.GetRows(-1) Rs.Close Cache.add "Placard",Arr_Rs,dateadd("n",5000,now) End if End if For i=0 To Ubound(Arr_Rs,2) If Arr_Rs(3,i)=Ast Then Temp=Temp&" ·"&Fun.HtmlCode(Arr_Rs(1,i))&" ["&Arr_Rs(2,i)&"] " End If Next If Temp="" Then Temp="没有公告" Placard=Temp End Function '缓存版块 0深度+1ID+2父ID+3名称+4图片+5简介+6版主+7主题+8总帖+9今日帖+10最后复+11认证用+12子论坛+13子论组+14组类+15版数组 '获得全部版块 Public Function GetBoardCache() If Cache.valid("BoardInfo") then Board_Rs=Cache.Value("BoardInfo") Else Dim Rs Set Rs=Execute("Select Depth,BoardID,ParentID,Boardname,BoardImg,Introduce,BoardAdmin,PassUser,Child,ParentStr,RootID,Strings From[i_Board] order by RootID,Orders") If Rs.Eof Then Exit Function Else Board_Rs=Rs.GetRows(-1) Cache.add "BoardInfo",Board_Rs,dateadd("n",5000,now) End If Rs.Close Set Rs=Nothing End If End Function '加载每个版块动态缓存 Public Sub LoadingEachBoardCache() Dim Rs,Temp,B_RS,I Set Rs=Execute("Select BoardID,EssayNum,TopicNum,TodayNum,LastReply From[i_Board] order by BoardID") If Rs.Eof Then Exit Sub Else B_Rs=Rs.GetRows(-1) End If Rs.Close Set Rs=Nothing For I=0 To Ubound(B_Rs,2) Temp=B_RS(1,I)&"|"&B_RS(2,I)&"|"&B_RS(3,I)&"|"&B_Rs(4,I) Cache.add "Board"&B_Rs(0,I),Temp,dateadd("n",120,now) Next End Sub '获得单个版块动态缓存 0总帖数1主题数2今日帖3最后复。。 Public Function GetEachBoardCache(B_ID) If Not Cache.valid("Board"&B_ID) Then LoadingEachBoardCache() GetEachBoardCache=Split(Cache.Value("Board"&B_ID),"|") End Function '更新 Public Sub UpdateEcachBoardCache(B_ID,Str) Dim Temp,i,TStr B_ID=Split(B_ID,",") Str=Str&"||||||||"'防止特殊版面为空出错 For I=0 To ubound(B_ID) TStr=Split(Str,"|") Temp=GetEachBoardCache(B_ID(i)) Cache.add "Board"&B_ID(i),Temp(0)+Int(TStr(0))&"|"&Temp(1)+Int(TStr(1))&"|"&Temp(2)+Int(TStr(2))&"|"&TStr(3)&"|"&TStr(4)&"|"&TStr(5)&"|"&TStr(6)&"|"&TStr(7)&"|"&TStr(8)&"|"&TStr(9),dateadd("n",120,now) Next End Sub '版块信息;入口(样式,BoardID) Public Function GetBoardInfo(Str,Ast) Dim Temp,I,BoardtypeName,BoardtypePic,BoardAdmin,BoardAdmin1,LastStr,Boardupdate Dim Strings Strings=Split(Board_Rs(11,Ast),"|") If Str="1" Then Str=ReadSkins("显示简洁版块") Else Str=ReadSkins("显示版块") End If If Strings(7)="1" Then BoardTypeName="锁定论坛":Boardtypepic=SkinsPIC(6) ElseIf Strings(6)="1" or Strings(5)="1" Then BoardtypeName="特殊论坛":Boardtypepic=SkinsPIC(5) ElseIf Strings(8)="1" or Strings(3)="1" Then BoardTypeName="限制论坛":Boardtypepic=SkinsPIC(4) Else BoardtypeName="普通论坛":Boardtypepic=SkinsPIC(3) End If If Board_Rs(4,Ast)="" or IsNull(board_Rs(4,Ast)) Then temp="" Else Temp="
")'竖排 Str=Replace(Str,"{版主竖排}",BoardAdmin1) Str = Replace(Str,"{版主}",BoardAdmin) Boardupdate=GetEachBoardCache(Board_Rs(1,Ast)) Str = Replace(Str,"{总帖数}",Boardupdate(0)) Str = Replace(Str,"{主题数}",Boardupdate(1)) Str = Replace(Str,"{今日帖数}",Boardupdate(2)) If Strings(6)="1" or Strings(5)="1" Then Temp="
特殊论坛，发帖信息保密！
"
Else
Temp=ReadSkins("最后发帖信息")
Temp= Replace(Temp,"{用户名称}",Boardupdate(3))
Temp= Replace(Temp,"{回复时间}",Boardupdate(5))
If Boardupdate(6) <> "" Then Temp= Replace(Temp,"{表情}","![](pic/face/"&Boardupdate(6)&".Gif)
") Else Temp = Replace(Temp,"{表情}","")
Temp= Replace(Temp,"{主题ID}",Boardupdate(7))
Temp= Replace(Temp,"{版块ID}",Boardupdate(8))
Temp= Replace(Temp,"{数据表ID}",Boardupdate(9))
Temp= Replace(Temp,"{帖子信息}",Boardupdate(4))
End If
Str = Replace(Str,"{最后发帖信息}",Temp)
GetBoardInfo=Str
End Function
'检验版块
Public Sub CheckBoard()
If Not IsArray(Board_Rs) Then GetBoardCache()
If Not IsArray(Board_Rs) Then GotoErr(10)
Dim Temp,i,PassUser
If BoardID=0 Then GotoErr(1)
For i=0 To Ubound(Board_Rs,2)
If Int(Board_Rs(1,i))=Int(BoardID) Then
BoardDepth=Board_Rs(0,i)
BoardName=Board_Rs(3,i)
Stats=Boardname
'BoardIntroduce=Board_Rs(5,i)
BoardAdmin=Board_Rs(6,i)
PassUser=Board_Rs(7,i)
BoardChild=Board_Rs(8,i)
BoardParentStr=Board_Rs(9,i)
BoardRootID=Board_Rs(10,i)
BoardString=Split(Board_Rs(11,i),"|")
Exit For
End If
Next
If BoardName="" or isnull(BoardName) Then GotoErr(10)
IsBoardAdmin=False
If InStr("|"&Lcase(BoardAdmin)&"|","|"&Lcase(MyName)&"|")>0 And FoundUser And BoardAdmin<>"" Then IsBoardAdmin=True
For i=0 To Ubound(Board_Rs,2)
'记录区置顶信息
If Board_Rs(10,i)=BoardRootID And Board_Rs(0,i)<>0 Then BoardRoots=BoardRoots&Board_Rs(1,i)&","
If Int(BoardDepth)>0 Then
If InStr(","&BoardParentStr&",",","&Board_Rs(1,i)&",")>0 Then
'0深度，1ＩＤ，2父ＩＤ，3名称，4图片，5简介，6版主，7认证用户，8子论坛，9子论组，10组类，11组
'如果上级论坛为会员版面
If BoardString(3)="1" Then If Not Founduser then GoToErr(10)
'上级版主管理下级
If Info(48)="1" And FoundUser Then
If InStr("|"&Lcase(Board_Rs(6,i))&"|","|"&Lcase(MyName)&"|")>0 And FoundUser And BoardAdmin<>"" Then IsBoardAdmin=True
End If
Temp=Temp &" → "&Board_Rs(3,i)&""
End If
End If
Next
'记录整个区版块ID
If BoardRoots<>"" Then
BoardRoots=Left(BoardRoots,len(BoardRoots)-1)
End If
Position=Position & Temp &" → "&Stats&""
If instr(PageUrl,"board.asp")>0 Then
If isnull(Boardadmin) or trim(BoardAdmin)="" then
Boardadmin="暂无"
Else
Temp=split(BoardAdmin,"|")
Boardadmin=""
For i=0 to ubound(Temp)
BoardAdmin=BoardAdmin&" "&Temp(I)&""
next
End If
End If
If MyAdmin=9 Then Exit Sub
'版组说明：0/1(0类)|0/1(1简洁)|(2简洁个数)|0/1(3会员)|0/1(4只读)|0/1(5VIP)|0/1(6认证)|0/1(7锁定)|0/1(8会员限制)|(9等级进入)|(10限帖数)|(11限积分)|(12限金币)|(13限游戏币)|0/1/2(13上传)|备用...
' 锁定
If BoardString(7)="1" And Not IsBoardAdmin Then GoToErr(12)
'VIP
If BoardString(5)="1" Then
If Not FoundUser Then GoToErr(10)
If Session(CacheName & "MyInfo")(17)="0" Then GoToErr(13)
End IF
'认证
If BoardString(6)="1" Then
If PassUser="" or isnull(PassUser) Then GotoErr(14)
If InStr(Lcase("|"&PassUser&"|"),Lcase("|"&Lcase(MyName)&"|"))=0 or MyName="" Then GotoErr(14)
End If
If BoardString(9)="1" Then
If Not FoundUser Then GotoErr(10)
'限帖数
If Int(BoardString(10))>Int(Session(CacheName & "MyInfo")(4)) Then GotoErr(16)
'限积分
If Int(BoardString(11))>Int(Session(CacheName & "MyInfo")(6)) Then GotoErr(17)
'限金钱
If Int(BoardString(12))>Int(Session(CacheName & "MyInfo")(7)) Then GotoErr(18)
'限游戏币
If Int(BoardString(13))>Int(Session(CacheName & "MyInfo")(8)) Then GotoErr(19)
End If
'只读
If BoardString(4)="1" And (Instr(PageUrl,"post.asp")>0 or Instr(PageUrl,"postsave.asp")>0) And Not IsBoardAdmin Then GotoErr(82)
If BoardString(3)="1" Then
If Instr(PageUrl,"board.asp")>0 Then Exit Sub
If Not Founduser Then GoToErr(10)
End If
End Sub
'版块下拉列表(当前ID，不显示的深度)
Public Function BoardIDList(Ast,Depth)
Dim Temp,I,II,po
If Not IsArray(Board_Rs) Then GetBoardCache()
If IsArray(Board_Rs) Then
For i=0 To Ubound(Board_Rs,2)
Po=""
If Board_Rs(0,i)<>Depth Then
If Board_Rs(0,i)<>0 Then
For II=1 To Board_Rs(0,i)
Po=Po&" ∣ "
Next
End If
Temp=Temp&""
End If
Next
BoardIDList=Temp
End If
End Function
'过滤特殊帖
Public Function CheckEspecial(str)
Dim re,restr
Set re=new RegExp
re.IgnoreCase=true
re.Global=True
If Info(68)="0" Then
re.Pattern="(\[Code\])(.+?)(\[\/Code\])"
str=re.replace(str,"$2")
End If
If Info(70)="0" Then
re.Pattern="(\[reply\])(.+?)(\[\/reply\])"
str=re.replace(str,"$2")
End If
If Info(71)="0" Then
re.Pattern="(\[COIN=*([0-9]*)\])(.+?)(\[\/COIN\])"
str=re.replace(str,"$3")
End If
If Info(72)="0" Then
re.Pattern="(\[MARK=*([0-9]*)\])(.+?)(\[\/MARK\])"
str=re.replace(str,"$3")
End If
If Info(73)="0" Then
re.Pattern="(\[DATE=(.[^\[]*)\])(.+?)(\[\/DATE\])"
str=re.replace(str,"$3")
End If
If Info(74)="0" Then
re.Pattern="(\[SEX=*([0-1]*)\])(.+?)(\[\/SEX\])"
str=re.replace(str,"$3")
End If
If Info(75)="0" Then
re.Pattern="(\[login\])(.+?)(\[\/login\])"
str=re.replace(str,"$2")
End If
If Info(76)="0" Then
re.Pattern="(\[USERNAME=(.[^\[]*)\])(.+?)(\[\/USERNAME\])"
str=re.replace(str,"$3")
End If
If Info(77)="0" Then
re.Pattern="(\[BUYPOST=*([0-9]*)\])(.+?)(\[\/BUYPOST\])"
str=re.replace(str,"$3")
End If
CheckEspecial=str
Set re=Nothing
End Function
'记录认证和Vip版块的标记
Public Function NoShowTopic()
Dim Temp,i,Strings
If Not IsArrAy(Board_Rs) Then GetBoardCache()
If IsArray(Board_Rs) Then
Temp=""
For i=0 To Ubound(Board_Rs,2)
Strings=Split(Board_Rs(11,i),"|")
If Strings(6)="1" or Strings(5)="1" Then
Temp=Temp&Board_Rs(1,I)&","
End If
Next
If Temp<>"" Then Temp=left(temp,len(temp)-1)
NoShowTopic=Temp
End If
End Function
Public Function GetBoardName(Ast)
Dim i
If Ast<1 then GetBoardName="所有版块":Exit Function
If Not IsArray(Board_Rs) Then GetBoardCache()
If IsArray(Board_Rs) Then
For i=0 To Ubound(Board_Rs,2)
IF Board_Rs(1,i)=Ast Then
GetBoardName=""&Board_Rs(3,i)&""
Exit For
End IF
Next
End If
End Function
Public function CheckNum(str)
If isnull(str) or str="" then Str=0
If not isnumeric(str) then GotoErr(1)
CheckNum=int(str)
End function
Function GetTimeOver(iflag)
If iflag=0 Then Exit Function
Dim tTimeOver
If iflag = 1 Then
tTimeOver = FormatNumber((Timer() - StartTime) * 1000, 3, true)
getTimeOver = " Processed in " & tTimeOver & " millisecond(2),"
Else
tTimeOver = FormatNumber(Timer() - StartTime, 6, true)
getTimeOver = " Processed in " & tTimeOver & " second(s),"
End If
End Function
Private Sub OpenSkins()
'Cache.clean("Skin_"& SkinID)
If Cache.valid("Skin_"& SkinID) then
Skins=Cache.value("Skin_"& SkinID)
Else
Dim Rs,Temp
Set Rs=Execute("Select Top 1 Pic,Content,SkinName,SkinDir From [i_Skins] Where SkinID="&SkinID&"")'"&SkinID)
If Not Rs.Eof Then
Temp="[i@PIC]"&Rs(0)&"[/i@PIC]"&Rs(1)&"[i@SkinName]"&Rs(2)&"[/i@SkinName][i@SkinDir]"&Rs(3)&"[/i@SkinDir]"
SkinsName=Rs(2)
SkinsDir=Rs(3)
Temp = GetLabel(Temp)
Cache.add "Skin_"&SkinID,Temp,dateadd("n",5000,now)
Skins=Temp
Rs.Close
Set Rs= Nothing
Else
Print "没有模版或已被删除了！请点这里更新你的Cookies" End If End If End Sub '通用标签替换 Function GetLabel(str) If str = "" Or IsNull(str) Then GetLabel = "":Exit Function str = Replace(str,"{SkinsDir}",SkinsDir) str = Replace(str,"{SkinsName}",SkinsName) GetLabel = str End Function Public Function ReadSkins(TempLateName) Dim TempStr,BeNum,EnNum,BStr,EStr BStr="["&TempLateName&"]" EStr="[/"&TempLateName&"]" BeNum=InStr(Skins,BStr) EnNum=InStr(BeNum+Len(BStr),Skins,EStr) On Error Resume Next TempStr=Mid(Skins,BeNum+Len(BStr),EnNum-BeNum-Len(BStr)) If Err Then Print "在处理"&TempName&"模版时出错" End If ReadSkins=TempStr End Function Public Sub Netlog(str) Dim Temp,UserName UserName=MyName If UserName="" Then UserName="-" Temp=Left(Request.ServerVariables("script_name")&"
"&Replace(Request.ServerVariables("Query_String"),"'","''"),255) Execute("insert into [i_Log] (UserName,UserIP,Remark,LogTime,Geturl) values ('"&UserName&"','"&MyIP&"','"&str&"','"&NowBbsTime&"','"&Temp&"')") End Sub Function Row(A,B,W,H) If H<>"" Then H="min-height:"&H&";" If MSIE Then H=Replace(H,"min-","") End If Row="
"&B&"
"&A&"
"&Str&"
"
End Function
Public Function Execute(T_Sql)
If Not IsObject(Conn) Then ConnectionDatabase
Set Execute = Conn.Execute(T_Sql)
SqlNum=SqlNum+1
End Function
'禁止外部提交
Public function CheckMake()
Dim Come,Here
Come=Cstr(Request.ServerVariables("HTTP_REFERER"))
Here=Cstr(Request.ServerVariables("SERVER_NAME"))
If Come<>"" And Mid(Come,8,Len(Here)) <> Here Then GoToErr(2)
End function
Public Sub GoToErr(ErrNum)
'If ErrNum=1 Then NetLog "非法改动参数，试图功击。"
Response.Redirect "Err.asp?ErrNum=" & ErrNum
Response.End
End Sub
Private Sub Print(Msg)
'输出提示信息
Response.Write "" & Msg & "
"
Response.End
End Sub
'通用表格显示（标题，内容）
Public Sub ShowTable(Str1,Str2)
Dim Temp
Temp=ReadSkins("通用内容表格")
Temp=Replace(Temp,"{标题}",Str1)
Temp=Replace(Temp,"{内容}",Str2)
Response.Write(Temp)
End Sub
Public Function GetiCode()
GetiCode=" "
End Function
Public Sub Alert(msg,goUrl)
msg = replace(msg,"'","\'")
If goUrl="back" Then
goUrl="history.go(-1);"
Else
goUrl="window.location.href='"&goUrl&"'"
End IF
Response.Write ("")
Response.End
End Sub
'生成文件
Public Function CreateFile(iPath,iHtml)
On Error Resume Next
Set objFSO = Server.CreateObject("ADODB.Stream")
With objFSO
.Open
.Charset = "UTF-8"
.Position = objFSO.Size
.WriteText = iHtml
.SaveToFile server.mappath(iPath),2
.Close
End With
Set objFSO = Nothing
End Function
End Class
Class Cls_Cache
Private Ca,CacheStr,expireTime,expireTimeName,path
Private sub class_initialize()
path=CacheName
End Sub
Private property let Name(Str) '缓存名称/属性
CacheStr=str&path
Ca=Application(CacheStr)
expireTimeName=str&"expire"&path
expireTime=Application(expireTimeName)
End property
Public property let expire(Str,tm) '设置缓存过期时间/属性
Name=Str
expireTime=tm
Application.Lock()
Application(expireTimeName)=expireTime
Application.UnLock()
End property
Public property get valid(str)'检查
Name=Str
if isEmpty(Ca) or (not isdate(expireTime) or CDate(expireTime)