class_sys.asp
来自「是个不错的文件代码,希望大家好好用,」· ASP 代码 · 共 1,851 行 · 第 1/5 页
ASP
1,851 行
<%
Class class_sys
Public Cache_Name, Cache_Name_Custom, Cache_data
Public Reloadtime, setup, UserIp, ErrStr, Comeurl, AutoUpdate,CacheScores,CacheConfig,CacheCompont
Public Userdir, User_CopyRight, ver, Is_password_cookies, Is_gb2312,defaultGroup
Public l_uId, l_uName, l_uNickname,l_uPass, l_ulevel, l_uShowlogWord, l_uDir, l_isUbb, l_uDomain
Public l_uFolder, l_uFrame,l_uGroupId,l_ucustomdomain,l_uUpUsed,l_uIco,l_uScores ,l_uNewBie,l_uAddtime
Public l_uLastLogin,l_uLastComment,l_uLastMessage,l_uCommentCount,l_uMessageCount,l_uVisitCount,l_ulogcount
Public l_Group
Public KeyWords1,KeyWords2,KeyWords3,KeyWords4
Private Sub Class_initialize()
Reloadtime = 14400
Cache_Name = blogdir & Cache_Name_user
UserIp = GetIP
Comeurl = LCase(Trim(request.ServerVariables("HTTP_REFERER")))
ver = "4.0"
AutoUpdate = True '更新整站首页开关
Is_password_cookies = 1 '是否编码cookies,1为开启,0为关闭
Is_gb2312 = 1 '系统平台，1为简体中文平台，0为其他平台
End Sub
Private Sub class_terminate()
On Error Resume Next
If IsObject(conn) Then conn.Close: Set conn = Nothing
End Sub
Public Property Let name(ByVal vNewValue)
Cache_Name_Custom = LCase(vNewValue)
End Property
Public Property Let Value(ByVal vNewValue)
If Cache_Name_Custom <> "" Then
ReDim Cache_data(2)
Cache_data(0) = vNewValue
Cache_data(1) = Now()
Application.Lock
Application(Cache_Name & "_" & Cache_Name_Custom) = Cache_data
Application.unLock
Else
Err.Raise vbObjectError + 1, "CacheServer", " please change the CacheName."
End If
End Property
Public Property Get Value()
If Cache_Name_Custom <> "" Then
Cache_data = Application(Cache_Name & "_" & Cache_Name_Custom)
If IsArray(Cache_data) Then
Value = Cache_data(0)
Else
Err.Raise vbObjectError + 1, "CacheServer", " The Cache_Data(" & Cache_Name_Custom & ") Is Empty."
End If
Else
Err.Raise vbObjectError + 1, "CacheServer", " please change the CacheName."
End If
End Property
Public Function ObjIsEmpty()
ObjIsEmpty = True
Cache_data = Application(Cache_Name & "_" & Cache_Name_Custom)
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 DelCahe(MyCaheName)
Application.Lock
Application.Contents.Remove (Cache_Name & "_" & MyCaheName)
Application.unLock
End Sub
Public Sub ReloadSetup()
Dim sql, rs, i
sql = "select * from [oblog_setup] "
Set rs = execute(sql)
If rs.eof Then
Response.Write "[oblog_setup]表信息不存在，无法正常运行程序！"
Response.End
End if
name = "setup"
Value = rs.GetRows(1)
Set rs = Nothing
ReloadCache
Application.Lock
Application(Cache_Name & "index_update") = True
Application(Cache_Name & "list_update") = True
Application.unLock
End Sub
Public Sub ReLoadCache()
Dim sql, rs, i,arr
sql = "select * from oblog_config"
Set rs = Execute(sql)
If rs.eof Then
Response.Write "[oblog_config]表信息不存在，无法正常运行程序！"
Response.End
End if
Application.Lock
rs.Filter="id=1"
If Not rs.Eof Then
arr=Split(rs(1),"$$")
Else
arr=""
End If
Application(Cache_Name & "_Config") = arr
CacheConfig=Application(Cache_Name & "_Config")
rs.Filter="id=2"
If Not rs.Eof Then
arr=Split(rs(1),"$$")
Else
arr=""
End If
Application(Cache_Name & "_Compont") = arr
CacheCompont=Application(Cache_Name & "_Compont")
rs.Filter="id=3"
If Not rs.Eof Then
arr=Split(rs(1),"$$")
Else
arr=""
End If
Application(Cache_Name & "_Scores") = arr
CacheScores=Application(Cache_Name & "_Scores")
rs.Filter="id=4"
If Not rs.Eof Then
arr=Split(rs(1),"$$")
Else
arr=""
End If
Application(Cache_Name & "_WhiteIp") = arr
rs.Filter="id=5"
If Not rs.Eof Then
arr=Split(rs(1),vbcrlf)
Else
arr=""
End If
Application(Cache_Name & "_BlackIp") = arr
rs.Filter="id=6"
If Not rs.Eof Then
arr=Split(rs(1),vbcrlf)
Else
arr=""
End If
Application(Cache_Name & "_Keywords1") = arr
KeyWords1= arr
rs.Filter="id=7"
If Not rs.Eof Then
arr=Split(rs(1),vbcrlf)
Else
arr=""
End If
Application(Cache_Name & "_Keywords2") = arr
KeyWords2= arr
rs.Filter="id=8"
If Not rs.Eof Then
arr=Split(rs(1),vbcrlf)
Else
arr=""
End If
Application(Cache_Name & "_Keywords3") = arr
KeyWords3= arr
rs.Filter="id=9"
If Not rs.Eof Then
arr=Split(rs(1),vbcrlf)
Else
arr=""
End If
Application(Cache_Name & "_Keywords4") = arr
KeyWords4= arr
Set rs=Execute("Select top 1 Groupid From oblog_groups Order By g_level")
Application(Cache_Name & "_defaultGroup") =rs(0)
defaultGroup=Application(Cache_Name & "_defaultGroup")
rs.Close
Set rs=Nothing
Application.unLock
End Sub
'读取用户目录及绑定的路径到缓存
Public Sub ReloadUserdir()
Dim sql, rs, s
sql = "Select userdir,dirdomain From oblog_userdir "
Set rs = Execute(sql)
While Not rs.EOF
s = s & rs(0) & "!!??((" & rs(1) & "##))=="
rs.movenext
Wend
Application.Lock
Application(Cache_Name & "dirdomain") = s
Application.unLock
Set rs = Nothing
End Sub
Public Sub Start()
name = "setup"
If ObjIsEmpty() Then ReloadSetup()
If Not IsArray(CacheConfig) Then ReLoadCache()
'ReloadSetup()
CacheConfig=Application(Cache_Name & "_Config")
CacheCompont=Application(Cache_Name & "_Compont")
CacheScores=Application(Cache_Name & "_Scores")
Keywords1=Application(Cache_Name & "_Keywords1")
Keywords2=Application(Cache_Name & "_Keywords2")
Keywords3=Application(Cache_Name & "_Keywords3")
Keywords4=Application(Cache_Name & "_Keywords4")
defaultGroup=Application(Cache_Name & "_defaultGroup")
setup = Value
User_CopyRight = CacheConfig(7) & "</div>" & "<div id=""powered""><a href=""http://www.meigui8.cn"" target=""_blank""><img src=""images\oblog_powered.gif"" border=""0"" alt=""Powered by "" /></a>"
If DateDiff("s", Application(Cache_Name & "index_updatetime"), Now()) > Int(CacheConfig(33)) And Application(Cache_Name & "class_update") = False And AutoUpdate Then
ReloadSetup()
Application.Lock
Application(Cache_Name & "index_update") = True
Application(Cache_Name & "list_update") = True
Application(Cache_Name & "class_update") = True
Application.unLock
Response.Write ("<script src=""index.asp?re=0""></script>")
End If
End Sub
Public Sub Sys_Err(errmsg)
Dim strErr
strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
strErr = strErr & "<link href='images/style.css' rel='stylesheet' type='text/css'></head><body>" & vbCrLf
strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
strErr = strErr & " <br><tr align='center'><td height='22' class='title'><strong>错误信息</strong></td></tr>" & vbCrLf
strErr = strErr & " <tr><td height='100' class='tdbg' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg & "</td></tr>" & vbCrLf
strErr = strErr & " <tr align='center'><td class='tdbg'><a href='javascript:history.go(-1)'><< 返回上一页</a></td></tr>" & vbCrLf
strErr = strErr & "</table>" & vbCrLf
strErr = strErr & "</body></html>" & vbCrLf
Response.Write strErr
End Sub
Public Sub Chk_Comeurl()
If is_chk_comeurl = 1 Then
Dim Comeurl, curl
Comeurl = LCase(Trim(request.ServerVariables("HTTP_REFERER")))
If Comeurl = "" Then
Response.Write "<br><p align=center><font color='red'>对不起，为了系统安全，不允许直接输入地址访问本系统的后台管理页面。</font></p>"
Response.End
Else
curl = Trim("http://" & request.ServerVariables("SERVER_NAME"))
If Mid(Comeurl, Len(curl) + 1, 1) = ":" Then
curl = curl & ":" & request.ServerVariables("SERVER_PORT")
End If
curl = LCase(curl & request.ServerVariables("script_NAME"))
If LCase(Left(Comeurl, InStrRev(Comeurl, "/"))) <> LCase(Left(curl, InStrRev(curl, "/"))) Then
Response.Write "<br><p align=center><font color='red'>对不起，为了系统安全，不允许从外部链接地址访问本系统的后台管理页面。</font></p>"
Response.End
End If
End If
End If
End Sub
Public Function Site_bottom()
Site_bottom = cacheConfig(10) & vbCrLf
Site_bottom = Site_bottom & "<div style=""display:block;clear: both;text-align: center;width: 100%;padding: 8;""><a href=""http://www.meigui8.cn"" target=""_blank""><img src=""images\oblog_powered.gif"" border=""0"" alt=""Powered by "" /></a></div>" & vbCrLf
site_bottom = site_bottom &vbCrLf&"</body>" & vbCrLf
Site_bottom = Site_bottom & "</html>" & vbCrLf
End Function
Public Function Execute(sql)
If Not IsObject(conn) Then link_database
If is_debug = 0 Then
On Error Resume Next
Set Execute = conn.Execute(sql)
If Err Then
Err.Clear
Set conn = Nothing
Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。"
Response.End
End If
Else
'If Is_Debug=1 Then Response.Write sql & "<br>"
'If Session("adminname")<>"" Then Response.Write sql & "<br>"
'Response.End
Set Execute = conn.Execute(sql)
End If
End Function
Public Function chk_badword(Str)
Dim badstr, i, n
'先检查顶级过滤,如果存在则返回0.1
'对于0.1情况需要特殊处理,0.1首先满足了>0的特点
'但是对于日志发布时,如果是0.1,则列为可疑对象
badstr = KeyWords1
n = 0
For i = 0 To UBound(badstr)
If Trim(badstr(i)) <> "" Then
If InStr(Str, Trim(badstr(i))) > 0 Then
chk_badword = 0.1
'借用一下errstr
errstr = errstr & "," &Trim(badstr(i))
Exit Function
End If
End If
Next
'检查审核过滤
badstr = KeyWords2
n = 0
For i = 0 To UBound(badstr)
If Trim(badstr(i)) <> "" Then
If InStr(Str, Trim(badstr(i))) > 0 Then
n = n + 1
End If
End If
Next
chk_badword = n
End Function
Public Function filt_badword(Str)
Dim badstr, i
badstr = KeyWords3
For i = 0 To UBound(badstr)
If Trim(badstr(i)) <> "" Then
Str = Replace(Str, badstr(i), "***",1,-1,1)
End If
Next
filt_badword = Str
' Dim objRegExp, strOutput,sKey
' Set objRegExp = New Regexp
' strOutput=Str
' objRegExp.IgnoreCase = True
' objRegExp.Global = True
' badstr = KeyWords3
' If UBound(badstr)=-1 Then
' filt_badword=Str
' Exit Function
' End if
' sKey=Join(badstr,"|")
' objRegExp.Pattern = "(" & sKey & ")"
' strOutput = objRegExp.Replace(strOutput,"***")
' filt_badword = strOutput
End Function
Public Function getcode()
dim tmpstr
Randomize
tmpstr=cstr(Int(900000*rnd)+100000)
getcode = "<img src=""" & blogurl & "inc/code.asp?s="&tmpstr&""" style=""cursor:hand;border:1px solid #ccc;vertical-align:top;"" onclick=""this.src='"&blogurl&"inc/code.asp?s="&tmpstr&"';"" alt=""看不清?点一下"" id=""ob_codeimg"" /><input type=""hidden"" name=""ob_codename"" value="""&tmpstr&""" />"
End Function
'检查验证码是否正确
Public Function codepass()
Dim CodeStr,codename
CodeStr = Trim(request("CodeStr"))
codename = Trim(request("ob_codename"))
If CStr(Session("GetCode"&codename)) = CStr(CodeStr) And CodeStr <> "" Then
codepass = True
Session("GetCode"&codename)=empty
Else
codepass = False
Session("GetCode"&codename)=empty
End If
End Function
Public Function type_domainroot(Str)
Dim domainroot, i
domainroot = Trim(cacheConfig(4))
If InStr(domainroot, "|") > 0 Then
domainroot = Split(domainroot, "|")
For i = 0 To UBound(domainroot)
If Trim(domainroot(i)) <> "" Then
If domainroot(i) = Str Then
type_domainroot = type_domainroot & "<option value='" & Trim(domainroot(i)) & "' selected>" & "." & domainroot(i) & "</option>"
Else
type_domainroot = type_domainroot & "<option value='" & Trim(domainroot(i)) & "'>" & "." & domainroot(i) & "</option>"
End If
End If
Next
Else
type_domainroot = "<option value='" & domainroot & "'>" & "." & domainroot & "</option>"
End If
End Function
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?