"
'CaCheInfo = CaCheInfo & "共使用了" & Application.Contents.Count & "个缓存对象。"
Tmp = mainhtml(8)
If Forum_Setting(30) = "1" Then
Dim Endtime
Endtime = Timer()
Tmp = Replace(Tmp,"{$runtime}","
执行时间：" & FormatNumber((Endtime-Startime)*1000,5) & "毫秒。查询数据库" & SqlQueryNum & "次。"& CaCheInfo)
Else
Tmp = Replace(Tmp,"{$runtime}","")
End If
Tmp = Replace(Tmp,"{$color}",mainsetting(1))
Tmp = Replace(Tmp,"{$width}",mainsetting(0))
Tmp = Replace(Tmp,"{$powered}","Powered By ：Dvbbs Version " & Forum_Version & " Sp2")
Tmp = Replace(Tmp,"{$Footer_ads}",Forum_ads(1))
If Forum_ChanSetting(0)="1" And Forum_ChanSetting(1)="1" And Forum_ChanSetting(4)="1" And IsTopTable=1 Then
Tmp = Replace(Tmp,"{$ad}","
" & adcode_2)
Else
Tmp = Replace(Tmp,"{$ad}","")
End If
Tmp = Replace(Tmp,"{$copyright}",Forum_Copyright)
Tmp = Replace(Tmp,"{$StyleName}",StyleName)
If Forum_ChanSetting(0)="1" Then
Tmp = Replace(Tmp,"{$server}","![]() | ")
Else
Tmp = Replace(Tmp,"{$server}","")
End If
'Response.Write CaCheInfo
'//------------------------------------------------------------------------------
'//论坛访问量统系
If ScriptName="list.asp" or ScriptName="index.asp" Then
Dim RayPostAct,RayUpCount,RayMaxCount,Forum_url,RaySubjection,Board_Datas,FrameBody
Dim PostStr
RayMaxCount=100 '定义更新概率
RaySubjection=False
Forum_url=Get_ScriptNameUrl
If ScriptName="index.asp" Then
Name="RayUpCount"
If Dvbbs.ObjIsEmpty() Then
Value=1
Else
RayUpCount=Value
If Not IsNumeric(RayUpCount) Then
Value=1
Else
Value=RayUpCount+1
End If
End If
RayUpCount=Value
If RayUpCount >= RayMaxCount Then
RaySubjection=True
RayUpCount=1
Value=1
FrameBody="?PostType=0&forumname="&Server.htmlencode(Forum_Info(0))
FrameBody=FrameBody+"&forumurl="&Forum_url
FrameBody=FrameBody+"&forumlogincount="&Dvbbs.CacheData(10,0)
FrameBody=FrameBody+"&foruminlinecount="&MyBoardOnline.Forum_Online
FrameBody=FrameBody+"&forumtitlecount="&CacheData(8,0)
FrameBody=FrameBody+"&forumvisitprob=1"
FrameBody=FrameBody+"&forumemail="&Forum_Info(5)
FrameBody=FrameBody+"&forumtag=host"
End If
ElseIf ScriptName="list.asp" Then
Name="BoardInfo_" & Boardid
Board_Datas=Value
If Not IsNumeric(Board_Data(24,0)) Then
Board_Datas(24,0)=1
Else
Board_Datas(24,0)=Board_Datas(24,0)+1
End If
If Board_Datas(24,0) >= RayMaxCount Then
RaySubjection=True
Board_Datas(24,0)=1
FrameBody="?PostType=1&forumchildname="&Boardtype
FrameBody=FrameBody+"&forumchildurl="&Forum_url&"list.asp?boardid="&Boardid
FrameBody=FrameBody+"&forumchildtitlecount="&Board_Datas(9,0)
FrameBody=FrameBody+"&foruminlinecount="&MyBoardOnline.Forum_Online
FrameBody=FrameBody+"&forumlogincount="&Dvbbs.CacheData(10,0)
FrameBody=FrameBody+"&Forumvisitprob=1"
FrameBody=FrameBody+"&forumchildtag=subjection"
End If
Value=Board_Datas
End If
If RaySubjection Then
Response.Write ""
End If
End If
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 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
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 SaveSQLLOG(sCommand,message)
Dim lConnStr,lConn,ldb,SQL,RS
ldb = "data/DvSQLLOG.mdb"
lConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
Set lConn = Server.CreateObject("ADODB.Connection")
lConn.Open lConnStr
Set Rs = Server.CreateObject("adodb.recordset")
Sql="select * from dv_sql_log"
Rs.open sql,lconn,1,3
Rs.addnew
Rs("ScriptName")=ScriptName
Rs("S_Info")=Left(sCommand,255)
Rs("ip")=UserTrueIP
Rs.update
Rs.close
lConn.Execute(SQL)
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
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
sql="select top 1 country,city from dv_address where ip1 <="&num&" and ip2 >="&num&""
Set irs=aConn.execute(sql)
If irs.EOF And irs.bof Then
country="亚洲"
city=""
Else
country=irs(0)
city=irs(1)
End If
Set irs=Nothing
Set aConn = Nothing
SqlQueryNum = SqlQueryNum+1
End If
address=country&city
Else
address="未知"
End If
End Function
'显示验证码
Public Function GetCode()
Dim test
On Error Resume Next
Set test=Server.CreateObject("Adodb.Stream")
Set test=Nothing
If Err Then
Dim zNum
Randomize timer
zNum = cint(8999*Rnd+1000)
Session("GetCode") = zNum
GetCode=Dvbbs.mainhtml(15)& Session("GetCode")
Else
GetCode= Dvbbs.mainhtml(15)&"![]()
"
End If
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 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 i > UBound(rBadWord) Then
Str = Replace(Str,BadWords(i),"*")
Else
Str = Replace(Str,BadWords(i),rBadWord(i))
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 Function Get_Chan_Ad()
Dim TempData,i
Dim rndnum
Dim Temp_Ad,Forum_AdLoop1,Forum_AdLoop2
Temp_Ad = Split(CacheData(22,0),"||")
If Temp_Ad(0)<>"" Then
Forum_AdLoop1=Split(Temp_Ad(0),",")
Else
Forum_AdLoop1=Split("",",")
End If
If Temp_Ad(1)<>"" Then
Forum_AdLoop2=Split(Temp_Ad(1),",")
Else
Forum_AdLoop2=Split("",",")
End If
Forum_AdLoop3 = Temp_Ad(2)
'顶部banner
Randomize
rndnum=Cint(Ubound(Forum_AdLoop1)*rnd+1)
If UBound(Forum_AdLoop1)=-1 Then
adcode_1=""
Else
Name = "ForumAdCode1"
If ObjIsEmpty() Then LoadForumAdCode1
If IsArray(Value) And Forum_ChanSetting(3)="1" Then
TempData=Value
adcode_1=ReCssUrl(TempData(1,rndnum-1))
Else
adcode_1=""
End If
End If
'尾部通栏
Randomize
rndnum=Cint(Ubound(Forum_AdLoop2)*rnd+1)
If UBound(Forum_AdLoop2)=-1 Then
adcode_2=""
Else
Name = "ForumAdCode2"
If ObjIsEmpty() Then LoadForumAdCode2
If IsArray(Value) And Forum_ChanSetting(4)="1" Then
TempData=Value
adcode_2=ReCssUrl(TempData(1,rndnum-1))
Else
adcode_2=""
End If
End If
Name = "ForumAdCode3"
If ObjIsEmpty() Then LoadForumAdCode3
If IsArray(Value) And Forum_ChanSetting(2)="1" Then
TempData=Value
adcode_4=ReCssUrl(TempData(1,i))
Else
adcode_4=""
End If
i3 = 0
If Forum_AdLoop3<>"" And Forum_ChanSetting(5)="1" And Instr(ScriptName,"dispbbs")>0 Then
Name = "TopicAdCode"
If ObjIsEmpty() Then LoadTopicAdCode
If IsArray(Value) Then
TempData = Value
For i=0 To Ubound(TempData,2)
If TempData(1,i)=239 Or TempData(1,i)=240 Or TempData(1,i)=1 Or TempData(1,i)=2 Then
ad_3(i3)=" "
Else
ad_3(i3)=ReCssUrl(TempData(0,i))
End If
i3 = i3 + 1
Next
End If
End If
If i3=0 Then Ad_3(0)=" "
End Function
Private Function LoadTopicAdCode()
Dim Rs
Set Rs=Execute("Select a_adcode,a_id From Dv_AdCode Where a_id In ("&Forum_AdLoop3&")")
If Not Rs.Eof Then
Value = Rs.GetRows(-1)
Else
Value = ""
End If
Set Rs=Nothing
End Function
Private Function LoadForumAdCode1()
Dim Rs
Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0001'")
If Not Rs.Eof Then
Value = Rs.GetRows(-1)
Else
Value = ""
End If
Set Rs=Nothing
End Function
Private Function LoadForumAdCode2()
Dim Rs
Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0002'")
If Not Rs.Eof Then
Value = Rs.GetRows(-1)
Else
Value = ""
End If
Set Rs=Nothing
End Function
Private Function LoadForumAdCode3()
Dim Rs
Set Rs=Execute("Select a_address,a_adcode,a_id From Dv_AdCode Where a_address='0004'")
If Not Rs.Eof Then
Value = Rs.GetRows(-1)
Else
Value = ""
End If
Set Rs=Nothing
End Function
Public Function ReCssUrl(str)
if str="" then exit function
str=replace(str,"%css%","Get_Css.asp?SkinID="&SkinID)
str=replace(str,"%url%",Forum_info(1))
If CacheData(23,0)="" or isnull(CacheData(23,0)) Then
str=replace(str,"%username%","dvbbs")
str=replace(str,"%mouseId%","dvbbs")
Else
str=replace(str,"%username%",CacheData(23,0))
str=replace(str,"%mouseId%",CacheData(23,0))
End If
ReCssUrl=str
End Function
Public Function ReloadBoardInfo(lBoardID)
If lBoardID=0 Then Exit Function
'数组(21)TempStr用来记录版面的下拉菜单,(22)TempStr1用来保存该版面的导航,(23)TempStr2用来保存该版面的新闻和小字报,(24)TempStr3版块点击统计
Dim Rs
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,BoardID As TempStr,BoardID As TempStr1,BoardID As TempStr2,BoardID As TempStr3,cid,BoardID As TempStr4 from Dv_board where BoardID="&lBoardID)
If Not Rs.Eof Then
Name = "BoardInfo_" & lBoardID
Value = Rs.GetRows(1)
Else
'自动修正所有版面的boards数
Call ReloadAllBoardInfo()
'Response.Redirect "index.asp"
End If
Rs.Close
Set Rs = Nothing
End Function
'缓存版面公告和小字报信息
Public Function LoadBoardNews_Paper(lBoardID)
Dim tRs,bgs,MyGetData,TempStr,NoAnn,NoColor
If Not IsArray(lanstr) Then
NoAnn = "当前没有公告"
Else
NoAnn = lanstr(9)
End If
If Not IsArray(mainsetting) Then
NoColor = "blue"
Else
NoColor = mainsetting(10)
End If
Set tRs=Execute("Select Top 1 title,addtime,bgs From [Dv_bbsnews] Where boardid="&lBoardID&" Order By ID Desc")
If tRs.BOF And tRs.EOF Then
TempStr = NoAnn & "|||"
Else
bgs=tRs(2)
If bgs="" or IsNull(bgs) Then
TempStr=tRs(0) & "|||" & tRs(1)
Else
TempStr="
"&tRs(0)&"|||"&tRs(1)
End if
End If
'小字报部分
If IsSqlDataBase=1 Then
Set tRs=Execute("Select Top 5 S_id as id,S_username as postuser,S_title as topic From Dv_Smallpaper Where Datediff(D,S_addtime,"&SqlNowString&")<=1 And S_boardid="&lBoardID&" Order By S_addtime Desc")
Else
Set tRs=Execute("Select Top 5 S_id as id,S_username as postuser,S_title as topic From Dv_Smallpaper Where Datediff('D',S_addtime,"&SqlNowString&")<=1 And S_boardid="&lBoardID&" Order By S_addtime Desc")
End If
If tRs.Eof And tRs.Bof Then
TempStr=TempStr & "|||"
Else
Dim TempData,i
TempData=tRs.GetRows(-1)
For i=0 To Ubound(TempData,2)
If i=0 Then
TempStr = TempStr & "||| "&HtmlEncode(TempData(1,i))&"："&HtmlEncode(TempData(2,i))&" "
Else
TempStr = TempStr & " "&HtmlEncode(TempData(1,i))&"："&HtmlEncode(TempData(2,i))&" "
End If
Next
End If
MyGetData = Value
MyGetData(23,0) = TempStr
Value = MyGetData
Set tRs=Nothing
End Function
'缓存导航相关信息
Public Sub LoadBoardParentStr(MyParentStr)
Dim tRs,GetData,MyGetData
Set tRs=Execute("Select Boardid,Boardtype,Boardmaster,Parentid From Dv_Board Where Boardid In ("&MyParentStr&") Order By Orders")
If Not tRs.Eof Then
GetData = tRs.GetRows(-1)
MyGetData = Value
MyGetData(22,0) = GetData
value=MyGetData
End If
Set tRs = Nothing
End Sub
'对应Dvbbs.Board_Data(21,0)，Act=1.导航菜单缓存;Dvbbs.Board_Data(26,0)，Act=0不含隐藏论坛的导航菜单缓存;
Public Sub LoadBoardList(lBoardID,Act)
Dim Forum_Boards,i,ii,Depth,Board_Datas,MyBoardList,MyBoardRootID,MyBoard_Data,b_setting
If lBoardID=0 Then Exit Sub
Name="BoardInfo_" & lBoardID
MyBoard_Data=value
MyBoardRootID=Clng(MyBoard_Data(5,0))
Forum_Boards=Split(CacheData(27,0),",")
For i=0 To Ubound(Forum_Boards)
Name="BoardInfo_" & Forum_Boards(i)
If ObjIsEmpty() Then ReloadBoardInfo(Forum_Boards(i))
Board_Datas = Value
b_setting=split(Board_Datas(16,0),",")
If b_setting(1)<>"1" Or Act=1 Then
Depth=Board_Datas(4,0)
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & ""
Select Case Depth
Case 0
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & "╋"
Case 1
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & " ├"
End Select
If Depth>1 Then
For ii=2 To Depth
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & " │"
Next
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & " ├"
End If
If MyBoardRootID = Board_Datas(5,0) And (Not Board_Datas(2,0) = 0) Then MyBoardList = MyBoardList & Server.htmlencode(Board_Datas(1,0)) & "
"
End If
Next
Name="BoardInfo_" & lBoardID
MyBoard_Data=value
If Act=1 Then
MyBoard_Data(21,0)=Replace(Replace(MyBoardList,"'","\'"),Chr(34), """)
Board_Data(21,0)=MyBoard_Data(21,0)
Else
MyBoard_Data(26,0)=Replace(Replace(MyBoardList,"'","\'"),Chr(34), """)
Board_Data(26,0)=MyBoard_Data(26,0)
End If
value=MyBoard_Data
Forum_Boards=Null
Board_Datas=Null
End Sub
Public Sub ReloadAllBoardInfo()
Dim Rs,Boards
Set Rs=Execute("Select BoardID From Dv_Board Order By RootID,Orders")
If Not Rs.Eof Then
Boards=Rs.GetString(,-1, "",",","")
Boards=Left(Boards,Len(Boards)-1)
End If
Rs.close:Set Rs=Nothing
Execute("Update dv_Setup Set Forum_Boards='"&Boards&"'")
ReloadSetupCache Boards,27
End Sub
'更新分版面部分缓存数组，入口：版面ID、更新内容、数组位置、更新方式，0直接赋值，1数值相加
Public Sub ReloadBoardCache(lBoardID,MyValue,N,act)
If lBoardID=0 Then Exit Sub
If lBoardID=444 Or lBoardID=777 Or lBoardID="" Then
Response.Write "错误的版面参数"
Response.End
End If
Dim Tmpdata
Name="BoardInfo_" & lBoardID
If ObjIsEmpty() Then ReloadBoardInfo(lBoardID)
Tmpdata=Value
If act=1 And IsNumeric(Tmpdata(N,0)) And IsNumeric(MyValue) Then
Tmpdata(N,0)=CLng(Tmpdata(N,0))+MyValue
ElseIf act=2 And IsNumeric(Tmpdata(N,0)) And IsNumeric(MyValue) Then
Tmpdata(N,0)=CLng(Tmpdata(N,0))-MyValue
Else
Tmpdata(N,0) = MyValue
End If
Value=Tmpdata
End Sub
Public Function ReloadForumPlusMenu()
Dim Rs,tRs,TempMenu,TempMenu1,MSetting
Name="ForumPlusMenu"&SkinID
Set Rs=Dvbbs.Execute("Select * From Dv_Plus Where Plus_Type='0' and Isuse=1 Order By ID")
If Rs.Eof And Rs.Bof Then
Value=""
Exit Function
End If
Do While Not Rs.Eof
MSetting=Split(Split(Rs("Plus_Setting"),"|||")(0),"|")
Set tRs=Dvbbs.Execute("Select * From Dv_Plus Where Plus_Type='"&Rs("ID")&"' and Isuse=1 Order By ID")
If tRs.Eof And tRs.Bof Then
Select Case MSetting(0)
Case 0
TempMenu = TempMenu & " &)
"&Rs("Plus_Name")&""
Case 1
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
Case 2
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
Case 3
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
End Select
Else
Do While Not tRs.Eof
MSetting=Split(Split(tRs("Plus_Setting"),"|||")(0),"|")
Select Case MSetting(0)
Case 0
TempMenu1 = TempMenu1 & ""
Case 1
TempMenu1 = TempMenu1 & ""
Case 2
TempMenu1 = TempMenu1 & ""
Case 3
TempMenu1 = TempMenu1 & ""
End Select
tRs.MoveNext
Loop
MSetting=Split(Split(Rs("Plus_Setting"),"|||")(0),"|")
Select Case MSetting(0)
Case 0
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
Case 1
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
Case 2
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
Case 3
TempMenu = TempMenu & " "&Rs("Plus_Name")&""
End Select
TempMenu1=""
End If
Rs.MoveNext
Loop
Value=TempMenu
Set tRs=Nothing
Set Rs=Nothing
End Function
'取得带端口的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
End Class
Class cls_Templates
Public html,Strings,pic
Public Property Let Value(ByVal vNewValue)
Dim tmpstr:tmpstr = vNewValue
tmpstr = Replace(tmpstr,"{$PicUrl}",Dvbbs.Forum_PicUrl)
tmpstr = Split(tmpstr,"@@@")
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=14400
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")
Dvbbs.Value=Rs(0)
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
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
'Session(Dvbbs.CacheName & "Cls_Browser") 0:Browser+|||+1:version+|||+2:platform
Class Cls_Browser
Public Browser,version ,platform,IsSearch
Private Sub Class_Initialize()
Dim Agent,Tmpstr
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 InStr(Agent(2),"NT 5.2")>0 Then
platform="Windows 2003"
ElseIf InStr(Agent(2),"Windows CE")>0 Then
platform="Windows CE"
ElseIf InStr(Agent(2),"NT 5.1")>0 Then
platform="Windows XP"
ElseIf InStr(Agent(2),"NT 4.0")>0 Then
platform="Windows NT"
ElseIf InStr(Agent(2),"NT 5.0")>0 Then
platform="Windows 2000"
ElseIf InStr(Agent(2),"NT")>0 Then
platform="Windows NT"
ElseIf InStr(Agent(2),"9x")>0 Then
platform="Windows ME"
ElseIf InStr(Agent(2),"98")>0 Then
platform="Windows 98"
ElseIf InStr(Agent(2),"95")>0 Then
platform="Windows 95"
ElseIf InStr(Agent(2),"Win32")>0 Then
platform="Win32"
ElseIf InStr(Agent(2),"Linux")>0 Then
platform="Linux"
ElseIf InStr(Agent(2),"SunOS")>0 Then
platform="SunOS"
ElseIf InStr(Agent(2),"Mac")>0 Then
platform="Mac"
ElseIf UBound(Agent)>2 Then
If InStr(Agent(3),"NT 5.1")>0 Then
platform="Windows XP"
End If
If InStr(Agent(3),"Linux")>0 Then
platform="Linux"
End If
End If
If InStr(Agent(2),"Windows")>0 And platform="unknown" Then
platform="Windows"
End If
ElseIf Left(Agent,5) ="Opera" Then '有此标识为浏览器
Agent=Split(Agent,"/")
Browser="Mozilla "
tmpstr=Split(Agent(1)," ")
version=tmpstr(0)
If InStr(Agent(1),"NT 5.2")>0 Then
platform="Windows 2003"
ElseIf InStr(Agent(1),"Windows CE")>0 Then
platform="Windows CE"
ElseIf InStr(Agent(1),"NT 5.1")>0 Then
platform="Windows XP"
ElseIf InStr(Agent(1),"NT 4.0")>0 Then
platform="Windows NT"
ElseIf InStr(Agent(1),"NT 5.0")>0 Then
platform="Windows 2000"
ElseIf InStr(Agent(1),"NT")>0 Then
platform="Windows NT"
ElseIf InStr(Agent(1),"9x")>0 Then
platform="Windows ME"
ElseIf InStr(Agent(1),"98")>0 Then
platform="Windows 98"
ElseIf InStr(Agent(1),"95")>0 Then
platform="Windows 95"
ElseIf InStr(Agent(1),"Win32")>0 Then
platform="Win32"
ElseIf InStr(Agent(1),"Linux")>0 Then
platform="Linux"
ElseIf InStr(Agent(1),"SunOS")>0 Then
platform="SunOS"
ElseIf InStr(Agent(1),"Mac")>0 Then
platform="Mac"
ElseIf UBound(Agent)>2 Then
If InStr(Agent(3),"NT 5.1")>0 Then
platform="Windows XP"
End If
If InStr(Agent(3),"Linux")>0 Then
platform="Linux"
End If
End If
Else
'识别搜索引擎
Dim botlist,i
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
End Class
%>
<%
'是否商业版，非官方SQL版本请在此设置为0以及在Conn中设置论坛为SQL数据库，否则显示不正常
Const IsBuss=1
Dvbbs.GetForum_Setting
Dvbbs.CheckUserLogin
%>
<%
'=================================================
'动网Dv7.0Jmail发送邮件组件：
' Edit By YangZheng
'=================================================
Dim SendMail
Sub Jmail(Email,Topic,Mailbody)
On Error Resume Next
Dim JMail
Set JMail = Server.CreateObject("JMail.Message")
JMail.silent=true
JMail.Logging = True
JMail.Charset = "gb2312"
If Not(Dvbbs.Forum_info(12) = "" Or Dvbbs.Forum_info(13) = "") Then
JMail.MailServerUserName = Dvbbs.Forum_info(12) '您的邮件服务器登录名
JMail.MailServerPassword = Dvbbs.Forum_info(13) '登录密码
End If
JMail.ContentType = "text/html"
JMail.Priority = 1
JMail.From = Dvbbs.Forum_info(5)
JMail.FromName = Dvbbs.Forum_info(0)
JMail.AddRecipient Email
JMail.Subject = Topic
JMail.Body = Mailbody
JMail.Send (Dvbbs.Forum_info(4))
Set JMail = Nothing
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
Sub Cdonts(Email,Topic,Mailbody)
On Error Resume Next
Dim ObjCDOMail
Set ObjCDOMail = Server.CreateObject("CDONTS.NewMail")
ObjCDOMail.From = Dvbbs.Forum_info(5)
ObjCDOMail.To = Email
ObjCDOMail.Subject = Topic
ObjCDOMail.BodyFormat = 0
ObjCDOMail.MailFormat = 0
ObjCDOMail.Body = Mailbody
ObjCDOMail.Send
Set ObjCDOMail = Nothing
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
Sub Aspemail(Email,Topic,Mailbody)
On Error Resume Next
Dim Mailer
Set Mailer = Server.CreateObject("Persits.MailSender")
Mailer.Charset = "gb2312"
Mailer.IsHTML = True
Mailer.username = Dvbbs.Forum_info(12) '服务器上有效的用户名
Mailer.password = Dvbbs.Forum_info(13) '服务器上有效的密码
Mailer.Priority = 1
Mailer.Host = Dvbbs.Forum_info(4)
Mailer.Port = 25 ' 该项可选.端口25是默认值
Mailer.From = Dvbbs.Forum_info(5)
Mailer.FromName = Dvbbs.Forum_info(0) ' 该项可选
Mailer.AddAddress Email,Email
Mailer.Subject = Topic
Mailer.Body = Mailbody
Mailer.Send
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
%>
<%
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function md5_F(x, y, z)
md5_F = (x And y) Or ((Not x) And z)
End Function
Private Function md5_G(x, y, z)
md5_G = (x And z) Or (y And (Not z))
End Function
Private Function md5_H(x, y, z)
md5_H = (x Xor y Xor z)
End Function
Private Function md5_I(x, y, z)
md5_I = (y Xor (x Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage,stype)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, x(k + 10), S22, &H2441453
md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, &HF4292244
md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, x(k + 6), S43, &HA3014314
md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
if stype=32 then
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
else
MD5=LCase(WordToHex(b) & WordToHex(c)) 'I crop this to fit 16byte database password :D
end if
End Function
%>
<%
dim topic,mailbody,sendmsg,useremail
dim username,password,repassword,Rs,SQl
dim answer
Dvbbs.LoadTemplates("login")
Dvbbs.Stats=template.Strings(2)
Dvbbs.Nav()
Dvbbs.Head_var 0,"",template.Strings(0),""
If request("action")="step1" Then
call step1()
ElseIf request("action")="step2" Then
call step2()
ElseIf request("action")="step3" Then
call step3()
Else
Call main()
End If
Dvbbs.activeonline()
Dvbbs.footer()
Sub step1()
If Dvbbs.chkpost=False Then
showerr template.Strings(10)
Exit Sub
End If
If request.Form("username")="" Then
showerr template.Strings(6)
Exit Sub
Else
username=replace(request("username"),"'","")
End If
If Dvbbs.forum_setting(81)="1" Then
If Not Dvbbs.CodeIsTrue() Then
Response.redirect "showerr.asp?ErrCodes=验证码校验失败，请返回刷新页面后再输入验证码。&action=OtherErr"
End If
End If
If Dvbbs.Forum_Setting(2)<>"0" Then
Set Rs=Dvbbs.execute("Select UserQuesion,userAnswer,Username,Usergroupid from [Dv_user] where username='"&username&"'")
Else
Set Rs=Dvbbs.execute("Select UserQuesion,userAnswer,Username,Usergroupid from [Dv_user] where username='"&username&"' and UserGroupID>3")
End If
If rs.eof and rs.bof then
showerr template.Strings(8)
Exit Sub
ElseIf rs(3) < 4 then
showerr template.Strings(7)
Exit Sub
Else
If rs(0)="" or isnull(rs(0)) Then
showerr template.Strings(9)
Exit Sub
Else
template.html(6)=Replace(template.html(6),"{$Quesion}",Rs(0))
template.html(6)=Replace(template.html(6),"{$username}",username)
If Dvbbs.forum_setting(81)="0" Then
template.html(6)=Replace(template.html(6),"{$getcode}","")
Else
template.html(6)=Replace(template.html(6),"{$getcode}"," 验证码："&Dvbbs.GetCode())
End If
Response.Write template.html(6)
End If
End If
Rs.Close
Set Rs=Nothing
End Sub
Sub step2()
Dim answer,UserToday,UpUserToday
If request.Form("username")="" Then
showerr template.Strings(6)
Exit Sub
Else
username=replace(request("username"),"'","")
End If
If Dvbbs.chkpost=False Then
showerr template.Strings(10)
Exit Sub
End If
If request.form("answer")="" then
showerr template.Strings(11)
Exit Sub
Else
answer=md5(request("answer"),16)
End If
If Dvbbs.forum_setting(81)="1" Then
If Not Dvbbs.CodeIsTrue() Then
Response.redirect "showerr.asp?ErrCodes=验证码校验失败，请返回刷新页面后再输入验证码。&action=OtherErr"
End If
End If
sql="select useranswer,userquesion,useranswer,UserToday,Lastlogin from [Dv_user] where username='"&username&"'"
Set Rs=Dvbbs.execute(sql)
If Rs.EOF And Rs.BOF Then
showerr template.Strings(12)
Exit Sub
Else
If datediff("h",Rs(4),now())<24 Then
showerr "您取回密码次数已超出系统限制，请24小时后再使用取回密码功能！"
Exit Sub
End If
If Rs(2)<>answer Then
If Cint(Dvbbs.forum_setting(84))<>0 Then
If Ubound(Split(Rs(3),"|"))<3 Then
UpUserToday=Rs(3)&"|0"
Else
UpUserToday=Rs(3)
End IF
UserToday=Split(UpUserToday,"|")
UserToday(3)=Cint(UserToday(3))+1
UpUserToday=Clng(UserToday(0))&"|"&Clng(UserToday(1))&"|"&Clng(UserToday(2))&"|"&Clng(UserToday(3))
Dvbbs.Execute("update [Dv_user] Set UserToday='"&UpUserToday&"' Where username='"&username&"'")
If UserToday(3)>Cint(Dvbbs.forum_setting(84)) Then
UpUserToday=Clng(UserToday(0))&"|"&Clng(UserToday(1))&"|"&Clng(UserToday(2))
Dvbbs.Execute("update [Dv_user] Set Lastlogin="&SqlNowString&",UserToday='"&UpUserToday&"' Where username='"&username&"'")
showerr "您取回密码次数已超出系统限制，请24小时后再使用取回密码功能！"
Exit Sub
End If
End If
showerr template.Strings(12)
Exit Sub
Else
If Dvbbs.Forum_Setting(2)<>"0" Then
template.html(7)=Replace(template.html(7),"{$readme}",template.Strings(3))
Else
template.html(7)=Replace(template.html(7),"{$readme}",template.Strings(4))
End If
template.html(7)=Replace(template.html(7),"{$Quesion}",Rs(1))
template.html(7)=Replace(template.html(7),"{$answer}",request.form("answer"))
template.html(7)=Replace(template.html(7),"{$username}",username)
Response.Write template.html(7)
End If
End If
Rs.Close
Set Rs=Nothing
End Sub
Sub step3()
If Dvbbs.chkpost=False Then
showerr template.Strings(10)
Exit Sub
End If
If request.Form("username")="" Then
showerr template.Strings(6)
Exit Sub
Else
username=replace(request("username"),"'","")
End If
If request.Form("answer")="" Then
showerr template.Strings(11)
Exit Sub
Else
answer=md5(request("answer"),16)
End If
if request.Form("password")="" or Len(request("password"))>10 or len(request("password"))<6 then
showerr template.Strings(13)
Exit Sub
ElseIf request.Form("repassword")="" Then
showerr template.Strings(14)
Exit Sub
ElseIf request.Form("password")<>request("repassword") Then
showerr template.Strings(15)
Exit Sub
Else
password=md5(request.Form("password"),16)
End If
set rs=server.createobject("adodb.recordset")
sql="select userpassword,useremail,userquesion,userclass,UserGroupID from [Dv_user] where username='"&username&"' and useranswer='"&Dvbbs.checkStr(answer)&"'"
If Not IsObject(Conn) Then ConnectionDatabase
rs.open sql,conn,1,3
If rs.eof and rs.bof Then
showerr template.Strings(16)
Exit Sub
Else
If Dvbbs.Forum_Setting(2)>0 Then
repassword=request.form("password")
answer=request.form("answer")
password=rs("userpassword")
useremail=rs("useremail")
call sendusermail()
If SendMail="OK" Then
sendmsg=template.Strings(17)
ElseIf Rs("UserGroupID")<4 Then
sendmsg=template.Strings(18)
Else
rs("userpassword")=md5(repassword,16)
Rs.Update
sendmsg=template.Strings(19)
End If
Else
Rs("userpassword")=password
Rs.Update
End If
template.html(8)=Replace(template.html(8),"{$Quesion}",Rs(2))
template.html(8)=Replace(template.html(8),"{$answer}",request.form("answer"))
template.html(8)=Replace(template.html(8),"{$password}",request.form("password"))
If Dvbbs.Forum_Setting(2)<>"0" Then
template.html(8)=Replace(template.html(8),"{$readme}",sendmsg)
Else
template.html(8)=Replace(template.html(8),"{$readme}",template.Strings(5))
End If
Response.Write template.html(8)
End if
Rs.Close
Set Rs=Nothing
End Sub
Sub main()
If Dvbbs.Forum_ChanSetting(0)="1" Then Response.Write template.html(4)
If Dvbbs.forum_setting(81)="0" Then
template.html(5)=Replace(template.html(5),"{$getcode}","")
Else
template.html(5)=Replace(template.html(5),"{$getcode}"," 验证码："&Dvbbs.GetCode())
End If
Response.Write template.html(5)
End Sub
Sub showerr(errmsg)
template.html(9)=Replace(template.html(9),"{$Errmsg}",errmsg)
Response.Write template.html(9)
End Sub
Sub sendusermail()
on error resume Next
Dim activepassurl
activepassurl=Dvbbs.Get_ScriptNameUrl()&"activepass.asp?username="&Dvbbs.htmlencode(username)&"&pass="&password&"&repass="&repassword&"&answer="&answer
template.html(12)=Replace(template.html(12),"{$Forumname}",Dvbbs.Forum_info(0))
topic=template.html(12)
template.html(10)=Replace(template.html(10),"{$username}",Dvbbs.htmlencode(username))
template.html(10)=Replace(template.html(10),"{$Copyright}",Dvbbs.Forum_Copyright)
template.html(10)=Replace(template.html(10),"{$activepassurl}",""&activepassurl&"")
template.html(10)=Replace(template.html(10),"{$Version}","Dvbbs"&Dvbbs.Forum_Version)
mailbody=template.html(10)
select case Dvbbs.Forum_Setting(2)
case 0
sendmsg=template.Strings(20)&""&template.Strings(21)&""
case 1
call jmail(useremail,topic,mailbody)
case 2
call Cdonts(useremail,topic,mailbody)
case 3
call aspemail(useremail,topic,mailbody)
case else
sendmsg=template.Strings(20)&""&template.Strings(21)&""
end select
End Sub
%>