class_sys.asp
来自「是个不错的文件代码,希望大家好好用,」· ASP 代码 · 共 1,851 行 · 第 1/5 页
ASP
1,851 行
Public Function show_class(kind, CurrentID, kindType)
Dim rsClass, sqlClass, sTmp, tmpDepth, i
Dim arrShowLine(20)
For i = 0 To UBound(arrShowLine)
arrShowLine(i) = False
Next
If kind = "user" Then
sqlClass = "select * From oblog_userclass order by RootID,OrderID"
ElseIf kind = "log" Then
sqlClass = "select * From oblog_logclass Where idType=" & kindType & " order by RootID,OrderID"
End If
Set rsClass = Execute(sqlClass)
If rsClass.bof And rsClass.EOF Then
show_class = "<option value='0'>请选择类别</option>"
Else
show_class = "<option value='0'>请选择类别</option>"
Do While Not rsClass.EOF
tmpDepth = rsClass("Depth")
If rsClass("NextID") > 0 Then
arrShowLine(tmpDepth) = True
Else
arrShowLine(tmpDepth) = False
End If
sTmp = "<option value='" & rsClass("id") & "'"
If CurrentID > 0 And rsClass("id") = CurrentID Then
sTmp = sTmp & " selected"
End If
sTmp = sTmp & ">"
If tmpDepth > 0 Then
For i = 1 To tmpDepth
sTmp = sTmp & " "
If i = tmpDepth Then
If rsClass("NextID") > 0 Then
sTmp = sTmp & "├ "
Else
sTmp = sTmp & "└ "
End If
Else
If arrShowLine(i) = True Then
sTmp = sTmp & "│"
Else
sTmp = sTmp & " "
End If
End If
Next
End If
sTmp = sTmp & rsClass("classname")
sTmp = sTmp & "</option>"
show_class = show_class & sTmp
rsClass.movenext
Loop
End If
rsClass.Close
Set rsClass = Nothing
End Function
'取用户分类
Public Function show_Postclass(CurrentID)
Dim rsClass, sqlClass, sTmp, tmpDepth, i,Sql
Dim arrShowLine(20)
For i = 0 To UBound(arrShowLine)
arrShowLine(i) = False
Next
'处理类别
Dim sClass,sClass1,aClass
sClass=Trim(l_Group(9,0))
If sClass="" Or IsNull(sClass) Then
sqlClass = "select * From oblog_logclass Where idType=0 order by RootID,OrderID"
Else
'取大类
Sql="Select * From oblog_logclass Where classid in(" & sClass & ")" & vbcrlf
'取各子类
' Response.Write sql
aClass=Split(sClass,",")
For i=0 To UBound(aClass)
sClass1=""
sClass1="0," & aclass(i)
Sql= Sql & " union " & vbcrlf
Sql= Sql & " Select * From oblog_logclass Where Left(parentpath,Len('" & sClass1 &"'))='" & sClass1 & "' " & vbcrlf
Next
sqlClass="Select * From (" & Sql & ") a order by RootID,OrderID"
' Response.Write sqlClass
End If
Set rsClass=Server.CreateObject("Adodb.recordset")
rsClass.Open sqlClass,conn,1,3
Set rsClass = Execute(sqlClass)
If rsClass.EOF Then
show_Postclass = "<option value='0'>请选择类别</option>"
Else
show_Postclass = "<option value='0'>请选择类别</option>"
Do While Not rsClass.EOF
tmpDepth = rsClass("Depth")
If rsClass("NextID") > 0 Then
arrShowLine(tmpDepth) = True
Else
arrShowLine(tmpDepth) = False
End If
sTmp = "<option value='" & rsClass("id") & "'"
If CurrentID > 0 And rsClass("id") = CurrentID Then
sTmp = sTmp & " selected"
End If
sTmp = sTmp & ">"
If tmpDepth > 0 Then
For i = 1 To tmpDepth
sTmp = sTmp & " "
If i = tmpDepth Then
If rsClass("NextID") > 0 Then
sTmp = sTmp & "├ "
Else
sTmp = sTmp & "└ "
End If
Else
If arrShowLine(i) = True Then
sTmp = sTmp & "│"
Else
sTmp = sTmp & " "
End If
End If
Next
End If
sTmp = sTmp & rsClass("classname")
sTmp = sTmp & "</option>"
show_Postclass = show_Postclass & sTmp
rsClass.movenext
Loop
End If
rsClass.Close
Set rsClass = Nothing
End Function
Public Sub AddErrStr(message)
If errstr = "" Then
errstr = message
Else
errstr = errstr & "_" & message
End If
End Sub
Public Sub ShowErr()
If errstr <> "" Then Response.redirect "err.asp?message=" & errstr
End Sub
Public Sub ShowUserErr()
If errstr <> "" Then Response.redirect "user_prompt.asp?message=" & errstr
End Sub
Public Sub SaveCookie(username, password, CookieDate, userurl)
If cookies_domain <> "" Then
Response.Cookies(cookies_name).domain = cookies_domain
End If
Response.Cookies(cookies_name)("username") = CodeCookie(username)
Response.Cookies(cookies_name)("password") = CodeCookie(password)
If userurl = "" Or userurl = "." Then userurl = " "
Response.Cookies(cookies_name)("userurl") = CodeCookie(userurl)
Select Case CookieDate
Case 0
'not save
Case 1
Response.Cookies(cookies_name).Expires = Date + 1
Case 2
Response.Cookies(cookies_name).Expires = Date + 31
Case 3
Response.Cookies(cookies_name).Expires = Date + 365
Case Else
End Select
'Response.End
End Sub
Public Sub ob_chklogin(username, password, CookieDate)
Dim rs, sql, userurl
If Not IsObject(conn) Then link_database
Set rs = server.CreateObject("adodb.recordset")
sql = "Select * from oblog_user Where username='" & username & "' And password ='" & password & "' And isdel=0 "
rs.open sql, conn, 1, 3
If rs.EOF Then
rs.Close: Set rs = Nothing
adderrstr ("用户名或密码错误，请重新输入！")
Exit Sub
Else
If rs("lockuser") = 1 Then
rs.Close: Set rs = Nothing
adderrstr ("对不起！你的ID已被锁定，不能登录！")
Exit Sub
Else
rs("LastLoginIP") = UserIp
rs("LastLoginTime") = ServerDate(Now())
rs("LoginTimes") = rs("LoginTimes") + 1
If cacheConfig(4) <> "" And cacheConfig(5) = 1 Then
'启用二级域名
userurl = Trim(rs("user_domain")) & "." & Trim(rs("user_domainroot"))
Else
'未启用二级域名则从根目录开始访问，不包含域名
'userurl= trim(setup(3,0)) & trim(rs("user_dir")) & "/" & trim(rs("userid")) & "/index." & f_ext
userurl = blogdir & Trim(rs("user_dir")) & "/" & Trim(rs("user_folder")) & "/index." & f_ext
End If
rs.Update
SaveCookie username, password, CookieDate, userurl
rs.Close: Set rs = Nothing
End If
End If
End Sub
Public Function CheckUserLogined()
Dim Logined, rsLogin, sqlLogin, sSql, user_info
Logined = True
l_uName = filt_badstr(DecodeCookie(request.Cookies(cookies_name)("username")))
l_uPass = filt_badstr(DecodeCookie(request.Cookies(cookies_name)("password")))
If l_uName = "" Then
Logined = False
End If
If l_uPass = "" Then
Logined = False
End If
sSql = "userid,user_level,user_showlogword_num,user_upfiles_max,user_upfiles_size,user_dir,isubbedit,user_domain,"
sSql = sSql &"user_domainroot,lockuser,user_folder,adddate,user_info,user_Icon1,user_Icon2,user_group,lastcomment,"
sSql = sSql &"lastmessage,scores,Nickname,comment_count,message_count,newbie,lastlogintime,log_count,user_siterefu_num" & str_domain
If Logined = True Then
sqlLogin = "select " & sSql & " from oblog_user where lockuser=0 and Username='" & l_uName & "' and Password='" & l_uPass & "' And isdel=0 "
Set rsLogin = Execute(sqlLogin)
If rsLogin.EOF Then
Logined = False
Else
If rsLogin(9) = 1 Then
Set rsLogin = Nothing
adderrstr ("当前用户已被系统锁定，无法进行操作，请联系管理员！")
showerr
End If
l_uId = rsLogin(0)
l_ulevel = rsLogin(1)
l_uShowlogWord = rsLogin(2)
l_uDir = rsLogin(5)
l_isUbb = rsLogin(6)
l_uDomain = rsLogin(7) & "." & rsLogin(8)
l_uFolder = rsLogin(10)
l_uGroupId=rsLogin("user_group")
l_uUpUsed=rsLogin("user_upfiles_size")
l_uLastComment=rsLogin("lastcomment")
l_uLastMessage=rsLogin("lastmessage")
l_uScores=rsLogin("scores")
l_uNickname=rsLogin("Nickname")
l_uCommentCount=rsLogin("comment_count")
l_uMessageCount=rsLogin("message_count")
If l_uNickname="" Then l_uNickname=l_uName
If InStr(rsLogin(11), "$") Then
user_info = Split(rsLogin(11), "$")
l_uFrame = user_info(1)
Else
l_uFrame = 1
End If
If true_domain = 1 Then
'判断用户绑定的顶级域名
l_ucustomdomain = rsLogin("custom_domain")
If l_ucustomdomain <> "" Then
l_uDomain = l_ucustomdomain
End If
End If
l_uNewBie=rsLogin("newbie")
l_uIco=ob_IIF(rsLogin("user_icon1"), "images/ico_default.gif")
l_uLastLogin=rsLogin("lastlogintime")
l_ulogcount=rsLogin("log_count")
l_uvisitcount=rsLogin("user_siterefu_num")
l_uAddtime=rsLogin("adddate")
If IsNumeric(l_uGroupId) Then
'获得组信息
GetGroupInfo
'判断
Set rsLogin=Execute("Select top 1 groupid,g_points,g_autoupdate From oblog_groups Where g_level>" & l_Group(2,0) & " Order By g_level")
If Not rsLogin.Eof Then
If rsLogin("g_autoupdate")=1 Then
'判断是否需要升级
If l_uScores>=rsLogin(1) Then
Execute ("update oblog_groups set g_members=g_members-1 WHERE groupid = " &l_uGroupId)
Execute("Update oblog_user Set user_group=" & rsLogin(0) & " Where userid=" & l_uid)
Execute ("update oblog_groups set g_members=g_members+1 WHERE groupid = " &rsLogin(0))
Call GetGroupInfo
End If
End If
End If
End If
End If
Set rsLogin = Nothing
End If
CheckUserLogined = Logined
End Function
'组信息
Public Sub GetGroupInfo()
Dim rst
Set rst=Execute("Select * From oblog_groups Where groupid=" & l_uGroupId)
If Not rst.Eof Then
l_Group=rst.GetRows(1)
End If
Set rst=Nothing
End Sub
Public Sub CreateUserDir(ustr, action)
Dim fso, sql, rs, udir, uid, upath, loginstr, searchstr, bname, ufolder, utruepath
sql = "select userid,user_dir,blogname,user_folder,user_domain,user_domainroot" & str_domain & " from oblog_user where "
If action = 0 Then sql = sql & "userid=" & Int(ustr) Else sql = sql & "username='" & filt_badstr(ustr) & "'"
Set rs = Execute(sql)
If Not rs.EOF Then
udir = rs(1)
uid = rs(0)
bname = rs(2)
ufolder = rs(3)
If true_domain = 1 Then
If rs("custom_domain") <> "" And Not IsNull(rs("custom_domain")) Then
utruepath = "http://" & rs("custom_domain") & "/"
Else
utruepath = "http://" & rs("user_domain") & "." & rs("user_domainroot") & "/"
End If
Else
utruepath = blogdir & udir & "/" & ufolder & "/"
End If
If bname = "" Or IsNull(bname) Then bname = " "
searchstr = "<form name='search' method='post' action='" & blogurl & "list.asp?userid=" & uid & "' target=""_blank"">"
searchstr = searchstr & "<select name='selecttype' id='selecttype'>"
searchstr = searchstr & "<option value='topic' selected>日志标题</option>"
searchstr = searchstr & "<option value='logtext'>日志内容</option></select><br />"
searchstr = searchstr & "<input name='keyword' type='text' id='keyword' size='16' maxlength='40'>"
searchstr = searchstr & " <input type='submit' name='Submit' value='搜索'></form>"
'ATAI防止admin/manager下生成用户目录
'upath = server.MapPath(udir)
upath = server.MapPath(blogdir & udir)
Set fso = server.CreateObject(CacheCompont(1))
If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
upath = server.MapPath(blogdir & udir & "/" & ufolder)
If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
Call BuildFile(upath & "/index." & f_ext, "暂无日志,请发表日志或者更新首页!")
Call BuildFile(upath & "/message." & f_ext, "暂无留言,请更新发布留言板!")
Call BuildFile(upath & "/photo." & f_ext, "暂无相册,请添加相片或更新发布相册首页!")
upath = server.MapPath(blogdir & udir & "/" & ufolder & "/calendar")
If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
If f_ext = "htm" Or f_ext = "html" Then
Call BuildFile(upath & "/0.htm", htm2js_div(" ", "calendar"))
Else
Call BuildFile(upath & "/0.htm", " ")
End If
upath = server.MapPath(blogdir & udir & "/" & ufolder & "/inc")
If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
If f_ext = "htm" Or f_ext = "html" Then
Call BuildFile(upath & "/show_blogname.htm", htm2js_div(filt_html(bname), "blogname"))
Call BuildFile(upath & "/show_placard.htm", htm2js_div(" ", "placard"))
Call BuildFile(upath & "/show_subject.htm", htm2js_div(" ", "subject"))
Call BuildFile(upath & "/show_newblog.htm", htm2js_div(" ", "newblog"))
Call BuildFile(upath & "/show_comment.htm", htm2js_div(" ", "comment"))
Call BuildFile(upath & "/show_links.htm", htm2js_div(" ", "links"))
Call BuildFile(upath & "/show_info.htm", htm2js_div(" ", "info"))
Call BuildFile(upath & "/show_search.htm", htm2js_div(searchstr, "search"))
Call BuildFile(upath & "/show_newmessage.htm", htm2js_div("<a href=""" & utruepath & "message." & f_ext & "#cmt""><strong>签写留言</strong></a> ", "newmessage"))
Else
Call BuildFile(upath & "/show_blogname.htm", filt_html(bname))
Call BuildFile(upath & "/show_placard.htm", " ")
Call BuildFile(upath & "/show_subject.htm", " ")
Call BuildFile(upath & "/show_newblog.htm", " ")
Call BuildFile(upath & "/show_comment.htm", " ")
Call BuildFile(upath & "/show_links.htm", " ")
Call BuildFile(upath & "/show_info.htm", " ")
Call BuildFile(upath & "/show_search.htm", searchstr)
Call BuildFile(upath & "/show_newmessage.htm", "<a href=""" & utruepath & "message." & f_ext & "#cmt""><strong>签写留言</strong></a> ")
End If
If logfilepath = 1 Then
upath = server.MapPath(blogdir & udir & "/" & ufolder & "/archives")
If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
End If
Set fso = Nothing
Set rs = Nothing
Else
Set rs = Nothing
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?