<%
Class class_sys
    Public cache_name, cache_name_custom, cache_data, Reloadtime, setup, userip, errstr, userdir, user_copyright, ver, is_password_cookies, is_gb2312
    Public logined_uname, logined_upass, logined_ulevel, logined_ushowlogword, logined_uid, logined_uupfilemax, logined_uupfilesize, logined_udir, logined_isubb, logined_udomain, logined_ufolder,logined_uframe,logined_ucustomdomain
    Public comeurl, autoupdate
    Private Sub class_initialize()
        Reloadtime = 14400
        cache_name = blogdir& cache_name_user
        userip = request.ServerVariables("HTTP_X_FORWARDED_FOR")
        If userip = "" Then userip = request.ServerVariables("REMOTE_ADDR")
        comeurl = lcase(Trim(request.ServerVariables("HTTP_REFERER")))
        ver = "3.12"
        autoupdate = True '更新整站首页开关
        is_password_cookies = 1 '是否编码cookies,1为开启,0为关闭
        is_gb2312 = 1   '系统平台，1为简体中文平台，0为其他平台
    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) = ServerDate(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)), ServerDate(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)
        name = "setup"
        Value = rs.GetRows(1)
        Set rs = Nothing
        Application.Lock
        Application(cache_name & "index_update") = True
        Application(cache_name & "list_update") = True
        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()
        setup = Value
        user_copyright = setup(7, 0) & "</div><div id=""powered""><a href=""http://www.oblog.cn"" target=""_blank""><img src=""images\oblog_powered.gif"" border=""0"" alt=""Powered by Oblog."" /></a>"
        If DateDiff("s", Application(oblog.cache_name & "index_updatetime"), ServerDate(Now())) > setup(17, 0) And Application(cache_name & "class_update") = False And autoupdate Then
            ReloadSetup()
            'ReloadUserdir()
            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="""&blogdir&"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/admin/admin_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)'>&lt;&lt; 返回上一页</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 = setup(7, 0) & vbCrLf
        site_bottom = site_bottom & "<div style=""display:none;clear: both;text-align: center;width: 100%;padding: 1;""><a href=""http://www.oblog.cn"" target=""_blank"">Powered by oBlog.cn</a></div>" & vbCrLf
        site_bottom = site_bottom & "<script src=""login.asp?action=showindexlogin""></script>"&vbCrLf&"</body>" & vbCrLf
        site_bottom = site_bottom & "</html>" & vbCrLf
    End Function
    Public Function execute(sql)
        If Not IsObject(conn) Then link_database
		'if instr(lcase(sql),"oblog_admin") then
			'response.Write("无权限"):response.End()
		'end if
        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
            'Response.Write sql & "<br>"
            Set execute = conn.execute(sql)
        End If
    End Function
    Public Function chk_regname(regname)
        Dim regbadstr, i
        regbadstr = Split(setup(51, 0), vbCrLf)
        chk_regname = False
        For i = 0 To UBound(regbadstr)
            If Trim(regbadstr(i)) <> "" Then
                If Trim(regname) = Trim(regbadstr(i)) Then
                    chk_regname = True
                End If
            End If
            If chk_regname = True Then Exit For
        Next
    End Function
    Public Function chk_badword(Str)
        Dim badstr, i, n, tmp
		tmp=setup(50, 0)
		if instr(tmp,"$$$") then
			tmp=split(tmp,"$$$")
			badstr=tmp(1)
		else
			chk_badword=0
			exit function
		end if
        badstr = Split(badstr, vbCrLf)
        chk_badword = 0
        For i = 0 To UBound(badstr)
            If Trim(badstr(i)) <> "" Then
                If InStr(Str, Trim(badstr(i))) > 0 Then
                    chk_badword = 1
					exit function					
                End If
            End If
        Next
    End Function
    Public Function filt_badword(Str)
        Dim badstr,i,tmp
			tmp=setup(50, 0)
			if instr(tmp,"$$$") then
				tmp=split(tmp,"$$$")
				badstr=tmp(0)
			else
				badstr=tmp
			end if
	    badstr = Split(badstr, vbCrLf)
	    For i = 0 To UBound(badstr)
	    	If Trim(badstr(i)) <> "" Then
	      	Str = Replace(Str, badstr(i), "***")
	      End If
	    Next
	    filt_badword = Str
    End Function
    Public Function getcode()
        getcode = "<img src=""" & blogurl & "inc/code.asp"" style=""cursor:hand"" onclick=""this.src='"&blogurl&"inc/code.asp';"" alt=""看不清?点一下"" />"
    End Function
    '检查验证码是否正确
    Public Function codepass()
        Dim CodeStr
        CodeStr = Trim(request("CodeStr"))
        If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
            codepass = True
            'Session("GetCode")=empty
        Else
            codepass = False
            'Session("GetCode")=empty
        End If
    End Function
    Public Function type_domainroot(Str)
        Dim domainroot, i
        domainroot = Trim(oblog.setup(4, 0))
        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
    Public Function show_class(kind, CurrentID, kindType)
        Dim rsClass, sqlClass, strTemp, 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
                    strTemp = "<option value='" & rsClass("id") & "'"
                If CurrentID > 0 And rsClass("id") = CurrentID Then
                     strTemp = strTemp & " selected"
                End If
                strTemp = strTemp & ">"
                
                If tmpDepth > 0 Then
                    For i = 1 To tmpDepth
                        strTemp = strTemp & "&nbsp;&nbsp;"
                        If i = tmpDepth Then
                            If rsClass("NextID") > 0 Then
                                strTemp = strTemp & "├&nbsp;"
                            Else
                                strTemp = strTemp & "└&nbsp;"
                            End If
                        Else
                            If arrShowLine(i) = True Then
                                strTemp = strTemp & "│"
                            Else
                                strTemp = strTemp & "&nbsp;"
                            End If
                        End If
                    Next
                End If
                strTemp = strTemp & rsClass("classname")
                strTemp = strTemp & "</option>"
                show_class = show_class & strTemp
                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
        End Select
    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 & "'"
        rs.Open sql, conn, 1, 3
        If rs.bof And rs.EOF Then
            rs.Close: Set rs = Nothing
            adderrstr ("用户名或密码错误，请重新输入！"): showerr
            Exit Sub
        Else
            If rs("lockuser") = 1 Then
                rs.Close: Set rs = Nothing
                adderrstr ("对不起！你的ID已被锁定，不能登陆！"): showerr
                Exit Sub
            Else
                rs("LastLoginIP") = oblog.userip
                rs("LastLoginTime") = ServerDate(Now())
                rs("LoginTimes") = rs("LoginTimes") + 1
                If Trim(oblog.setup(4, 0)) <> "" And oblog.setup(12, 0) = 1 Then
                    '启用二级域名
                    userurl = Trim(rs("user_domain")) & "." & Trim(rs("user_domainroot"))
                Else
                    '未启用二级域名则从根目录开始访问，不包含域名
                    'userurl= trim(oblog.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 Sub ot_chklogin(username, password, CookieDate)
        Dim sql, rs, rsreg
        If Not IsObject(ot_conn) Then link_database
        sql = "select * from " & ot_usertable & " where " & ot_username & "='" & username & "' and " & ot_password & " ='" & password & "'"
        Set rs = ot_conn.execute(sql)
        If rs.bof And rs.EOF Then
            Set rs = Nothing
            If IsObject(ot_conn) Then ot_conn.Close: Set ot_conn = Nothing
            oblog.adderrstr ("用户名或密码错误，请重新输入！"): oblog.showerr
            Exit Sub
        Else
            Set rsreg = server.CreateObject("adodb.recordset")
            rsreg.Open "select * from [oblog_user] where username='" & username & "'", conn, 1, 3
            If rsreg.EOF Then
                Dim reguserlevel
                If oblog.setup(16, 0) = 1 Then reguserlevel = 6 Else reguserlevel = 7
                Set rsreg = server.CreateObject("adodb.recordset")
                rsreg.Open "select top 1 * from [oblog_user]", conn, 1, 3
                rsreg.addnew
                rsreg("username") = username
                rsreg("password") = "othertable"
                rsreg("user_dir") = oblog.setup(30, 0)
                rsreg("user_level") = reguserlevel
                rsreg("lockuser") = 0
                rsreg("en_blogteam") = 1
                rsreg("adddate") = ServerDate(Now())
                rsreg.Update
				oblog.execute("update oblog_user set user_folder=userid where username='"&username&"'")
                oblog.execute ("update oblog_setup set user_count=user_count+1")
                rsreg.Close
                Set rsreg = Nothing
                oblog.SaveCookie username, password, 0, " "
                oblog.CreateUserDir username, 1
                Set rs = Nothing
                oblog.showok "您是第一次激活blog系统，请完善blog资料!", "user_setting.asp"
                response.End()
            Else
                rsreg("LastLoginIP") = request.ServerVariables("REMOTE_ADDR")
                rsreg("LastLoginTime") = ServerDate(Now())
                rsreg("LoginTimes") = rsreg("LoginTimes") + 1
                rsreg.Update
            End If
            rsreg.Close
            Set rsreg = Nothing
            Set rs = Nothing
            If IsObject(ot_conn) Then ot_conn.Close: Set ot_conn = Nothing
            oblog.SaveCookie username, password, CookieDate, ""
        End If
    End Sub
    Public Function CheckUserLogined()
        Dim Logined, rsLogin, sqlLogin, ssql,user_info
        Logined = True
        logined_uname = filt_badstr(DecodeCookie(request.Cookies(cookies_name)("UserName")))
        logined_upass = filt_badstr(DecodeCookie(request.Cookies(cookies_name)("Password")))
		'response.Write(DecodeCookie(Request.Cookies(cookies_name)("UserName")))
		'response.End()
        If logined_uname = "" Then
            Logined = False
        End If
        If logined_upass = "" Then
            Logined = False
        End If
        ssql = "userid,user_level,user_showlogword_num,user_upfiles_max,user_upfiles_size,user_dir,isubbedit,user_domain,user_domainroot,lockuser,user_folder,user_info"&str_domain
        If Logined = True Then
            If is_ot_user = 1 Then
                link_database
                sqlLogin = "select * from " & ot_usertable & " where " & ot_username & "='" & logined_uname & "' and " & ot_password & "='" & logined_upass & "'"
                Set rsLogin = ot_conn.execute(sqlLogin)
            Else
                sqlLogin = "select " & ssql & " from [oblog_user] where lockuser=0 and Username='" & logined_uname & "' and Password='" & logined_upass & "'"
                Set rsLogin = execute(sqlLogin)
            End If
            If rsLogin.bof And rsLogin.EOF Then
                Logined = False
            Else
                If is_ot_user = 1 Then
                    Set rsLogin = execute("select " & ssql & " from [oblog_user] where username='" & logined_uname & "'")
                End If
                If Not rsLogin.EOF Then
                    If rsLogin(9) = 1 Then
                        Set rsLogin = Nothing
                        oblog.adderrstr ("当前用户已被系统锁定，无法进行操作，请联系管理员！")
                        oblog.showerr
                    End If
                    logined_uid = rsLogin(0)
                    logined_ulevel = rsLogin(1)
                    logined_ushowlogword = rsLogin(2)
                    logined_uupfilemax = rsLogin(3)
                    logined_uupfilesize = rsLogin(4)
                    logined_udir = rsLogin(5)
                    logined_isubb = rsLogin(6)
                    logined_udomain = rsLogin(7) & "." & rsLogin(8)
                    logined_ufolder = rsLogin(10)
					if instr(rsLogin(11),"$") then
						user_info=split(rsLogin(11),"$")
						logined_uframe=user_info(1)
					else
						logined_uframe=1
					end if
					if true_domain=1 then 
						'判断用户绑定的顶级域名
						logined_ucustomdomain=rslogin("custom_domain")
						if logined_ucustomdomain<>"" then
							logined_udomain=logined_ucustomdomain
						end if
					end if
                Else
                    Dim reguserlevel
                    If oblog.setup(16, 0) = 1 Then reguserlevel = 6 Else reguserlevel = 7
                    Dim rsreg
                    Set rsreg = server.CreateObject("adodb.recordset")
                    rsreg.Open "select top 1 * from [oblog_user]", conn, 1, 3
                    rsreg.addnew
                    rsreg("username") = logined_uname
                    rsreg("password") = "othertable"
                    rsreg("user_dir") = oblog.setup(30, 0)
                    rsreg("user_level") = reguserlevel
                    rsreg("lockuser") = 0
                    rsreg("en_blogteam") = 1
                    rsreg("adddate") = ServerDate(Now())
                    rsreg.Update
					oblog.execute("update oblog_user set user_folder=userid where username='"&logined_uname&"'")
                    execute ("update oblog_setup set user_count=user_count+1")
                    rsreg.Close
                    Set rsreg = Nothing
                    SaveCookie logined_uname, logined_upass, 0, " "
                    logined_ulevel = reguserlevel
                    oblog.CreateUserDir logined_uname, 1
                    Set rsLogin = Nothing
                    oblog.showok "您是第一次激活blog系统，请完善blog资料!", "user_setting.asp"
                    response.End()
                End If
            End If
            Set rsLogin = Nothing
        End If
        CheckUserLogined = Logined
    End Function
    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=" & CLng(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>"
            upath = server.MapPath(blogdir & udir & "/" & ufolder)
            Set fso = server.CreateObject("scripting.filesystemobject")           
            If fso.FolderExists(upath) = False Then fso.CreateFolder (upath)
            Call oblog.BuildFile(upath & "/index." & f_ext, "暂无日志,请发表日志或者更新首页!")
            Call oblog.BuildFile(upath & "/message." & f_ext, "暂无留言,请更新发布留言板!")
            Call oblog.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 oblog.BuildFile(upath & "/0.htm", oblog.htm2js_div(" ", "calendar"))
            Else
                Call oblog.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 oblog.BuildFile(upath & "/show_blogname.htm", oblog.htm2js_div(filt_html(bname), "blogname"))
                Call oblog.BuildFile(upath & "/show_placard.htm", oblog.htm2js_div(" ", "placard"))
                Call oblog.BuildFile(upath & "/show_subject.htm", oblog.htm2js_div(" ", "subject"))
                Call oblog.BuildFile(upath & "/show_newblog.htm", oblog.htm2js_div(" ", "newblog"))
                Call oblog.BuildFile(upath & "/show_comment.htm", oblog.htm2js_div(" ", "comment"))
                Call oblog.BuildFile(upath & "/show_links.htm", oblog.htm2js_div(" ", "links"))
                Call oblog.BuildFile(upath & "/show_info.htm", oblog.htm2js_div(" ", "info"))
                Call oblog.BuildFile(upath & "/show_search.htm", oblog.htm2js_div(searchstr, "search"))
                Call oblog.BuildFile(upath & "/show_newmessage.htm", oblog.htm2js_div("<a href=""" & utruepath & "message." & f_ext & "#cmt"">::签写留言::</a> ", "newmessage"))
            Else
                Call oblog.BuildFile(upath & "/show_blogname.htm", filt_html(bname))
                Call oblog.BuildFile(upath & "/show_placard.htm", " ")
                Call oblog.BuildFile(upath & "/show_subject.htm", " ")
                Call oblog.BuildFile(upath & "/show_newblog.htm", " ")
                Call oblog.BuildFile(upath & "/show_comment.htm", " ")
                Call oblog.BuildFile(upath & "/show_links.htm", " ")
                Call oblog.BuildFile(upath & "/show_info.htm", " ")
                Call oblog.BuildFile(upath & "/show_search.htm", searchstr)
                Call oblog.BuildFile(upath & "/show_newmessage.htm", "<a href=""" & utruepath& "message." & f_ext & "#cmt"">::签写留言::</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
            response.Write ("没找到该用户，无法建立目录。")
            Exit Sub
        End If
    End Sub
    Public Sub showok(Str, url)
        url = Trim(url)
        If url <> "" Then
            response.Write "<script language=JavaScript>alert(""" & Str & """);window.location='" & url & "'</script>"
        Else
            If comeurl = "" Then
                response.Write "<script language=JavaScript>alert(""" & Str & """);history.go(-1)</script>"
            Else
                response.Write "<script language=JavaScript>alert(""" & Str & """);window.location='" & comeurl & "'</script>"
            End If
        End If
    End Sub
    Public Function type_city(province, city)
        Dim tmpstr
        tmpstr = "<select onchange=setcity(); name='province' >"
        tmpstr = tmpstr & "<option value=''>----请选择省份----</option>"
        tmpstr = tmpstr & "<option "
        tmpstr = tmpstr & "value=安徽>安徽</option> <option value=北京>北京</option> "
        tmpstr = tmpstr & "<option value=重庆>重庆</option> <option "
        tmpstr = tmpstr & "value=福建>福建</option> <option value=甘肃>甘肃</option> "
        tmpstr = tmpstr & "<option value=广东>广东</option> <option "
        tmpstr = tmpstr & "value=广西>广西</option> <option value=贵州>贵州</option> "
        tmpstr = tmpstr & "<option value=海南>海南</option> <option "
        tmpstr = tmpstr & "value=河北>河北</option> <option value=黑龙江>黑龙江</option> "
        tmpstr = tmpstr & "<option value=河南>河南</option> <option "
        tmpstr = tmpstr & "value=香港>香港</option> <option value=湖北>湖北</option> "
        tmpstr = tmpstr & "<option value=湖南>湖南</option> <option "
        tmpstr = tmpstr & "value=江苏>江苏</option> <option value=江西>江西</option> "
        tmpstr = tmpstr & "<option value=吉林>吉林</option> <option "
        tmpstr = tmpstr & "value=辽宁>辽宁</option> <option value=澳门>澳门</option>"
        tmpstr = tmpstr & "<option value=内蒙古>内蒙古</option> <option "
        tmpstr = tmpstr & "value=宁夏>宁夏</option> <option value=青海>青海</option> "
        tmpstr = tmpstr & "<option value=山东>山东</option> <option "
        tmpstr = tmpstr & "value=上海>上海</option> <option value=山西>山西</option> "
        tmpstr = tmpstr & "<option value=陕西>陕西</option> <option "
        tmpstr = tmpstr & "value=四川>四川</option> <option value=台湾>台湾</option> "
        tmpstr = tmpstr & "<option value=天津>天津</option> <option "
        tmpstr = tmpstr & "value=新疆>新疆</option> <option value=西藏>西藏</option> "
        tmpstr = tmpstr & "<option value=云南>云南</option> <option "
        tmpstr = tmpstr & "value=浙江>浙江</option> <option "
        tmpstr = tmpstr & "value=海外>海外</option></select>"
        tmpstr = tmpstr & " <select name='city' >"
        tmpstr = tmpstr & "</select>"
        tmpstr = tmpstr & "<SCRIPT src=""inc/getcity.js""></SCRIPT>"
        tmpstr = tmpstr & "<SCRIPT>initprovcity('" & province & "','" & city & "');</SCRIPT>"
        type_city = tmpstr
    End Function
    Public Sub type_job(job)
        Dim tmpstr
        tmpstr = "<select name='job' id='job'><option value=''>----请选择职业----<option value='财会/金融'> 财会/金融<option value='工程师'  > 工程师<option value='顾问'  > 顾问<option value='计算机相关行业(Internet)'  > 计算机相关行业 (Internet)<option value='计算机相关行业（其他）'  > 计算机相关行业（其他）<option value='家庭主妇'  > 家庭主妇<option value='教育/培训'  > 教育/培训<option value='客户服务/支持'  > 客户服务/支持<option value='零售商/手工工人'  > 零售商/手工工人<option value='退休'  > 退休<option value='无职业'  > 无职业<option value='销售/市场/广告'  > 销售/市场/广告<option value='学生'  > 学生<option value='研究和开发'  > 研究和开发<option value='一般管理'  > 一般管理<option value='政府/军队'  > 政府/军队<option value='执行官/高级管理'  > 执行官/高级管理<option value='制造/生产/操作'  > 制造/生产/操作<option value='专业人员（医药、法律等）'  > 专业人员（医药、法律等）<option value='自雇/业主'  > 自雇/业主<option value='其他'  > 其他</select>"
        response.Write (tmpstr)
%>
<SCRIPT language=javascript>
    var jobObject = document.oblogform["job"];
    for(var i = 0; i < document.oblogform["job"].options.length; i++) {
        if (document.oblogform["job"].options[i].value=="<%=trim(job)%>")
        {
            document.oblogform["job"].selectedIndex = i;
        }
    }
</SCRIPT>
<%
    End Sub
    Public Sub type_dateselect(addtime, n)
        Dim y, m, d, ttime
        If addtime = "" Then ttime = ServerDate(Now()) Else ttime = addtime
        response.Write ("<select name=selecty" & n & ">") & vbCrLf
        For y = 2000 To 2010
            If Year(ttime) = y Then
                response.Write "<option value=" & y & " selected>" & y & "年</option>" & vbCrLf
            Else
                response.Write "<option value=" & y & ">" & y & "年</option>" & vbCrLf
            End If
        Next
        response.Write "</select><select name=selectm" & n & ">" & vbCrLf
        For m = 1 To 12
            If Month(ttime) = m Then
                response.Write "<option value=" & m & " selected>" & m & "月</option>" & vbCrLf
            Else
                response.Write "<option value=" & m & ">" & m & "月</option>" & vbCrLf
            End If
        Next
        response.Write ("</select><select name=selectd" & n & ">") & vbCrLf
        For d = 1 To 31
            If Day(ttime) = d Then
                response.Write "<option value=" & d & " selected>" & d & "日</option>" & vbCrLf
            Else
                response.Write "<option value=" & d & ">" & d & "日</option>" & vbCrLf
            End If
        Next
        response.Write ("</select>") & vbCrLf
    End Sub
    Public Sub chk_commenttime()
        Dim lasttime
        '必须先取Session!
        lasttime = Session("chk_commenttime")
        If lasttime="" Or Not IsDate(lasttime) Then lasttime = Request.Cookies(cookies_name)("LastComment") 
        If IsDate(lasttime) Then
            If DateDiff("s", lasttime, ServerDate(Now())) < setup(49, 0) Then
                response.Write ("<script language=javascript>alert('" & setup(49, 0) & "秒后才能回复或评论。');window.history.back(-1);</script>")
                response.End
            End If
        End If
    End Sub
    Public Function filtpath(Str)
        If is_relativepath = 1 Then
            Dim nurl
            nurl = Trim("http://" & request.ServerVariables("SERVER_NAME"))
            nurl = nurl & request.ServerVariables("SCRIPT_NAME")
            nurl = Left(nurl, InStrRev(nurl, "/"))
            filtpath = Replace(Str, nurl, "")
        Else
            filtpath = Str
        End If
    End Function
    Public Function chkiplock()
        Dim IPlock
        IPlock = False
        Dim locklist
        locklist = Trim(setup(52, 0))
        If locklist = "" Then Exit Function
        Dim i, StrUserIP, StrKillIP
        StrUserIP = userip
        locklist = Split(locklist, vbCrLf)
        If StrUserIP = "" Then Exit Function
        StrUserIP = Split(userip, ".")
        If UBound(StrUserIP) <> 3 Then Exit Function
        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
        chkiplock = IPlock
    End Function

    Public Function showpage(sfilename, totalnumber, maxperpage, ShowTotal, ShowAllPages, strUnit)
        Dim n, i, strTemp, strUrl
        If totalnumber Mod maxperpage = 0 Then
            n = totalnumber \ maxperpage
        Else
            n = totalnumber \ maxperpage + 1
        End If
        strTemp = "<div id=""showpage"">"
        If ShowTotal = True Then
            strTemp = strTemp & "共" & totalnumber & strUnit & "&nbsp;&nbsp;"
        End If
        strUrl = JoinChar(sfilename)
        If CurrentPage < 2 Then
                strTemp = strTemp & "首页 上一页&nbsp;"
        Else
                strTemp = strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
                strTemp = strTemp & "<a href='" & strUrl & "page=" & (CurrentPage - 1) & "'>上一页</a>&nbsp;"
        End If
    
        If n - CurrentPage < 1 Then
                strTemp = strTemp & "下一页 尾页"
        Else
                strTemp = strTemp & "<a href='" & strUrl & "page=" & (CurrentPage + 1) & "'>下一页</a>&nbsp;"
                strTemp = strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
        End If
        strTemp = strTemp & "&nbsp;页次：" & CurrentPage & "/" & n & "</strong>页 "
        strTemp = strTemp & "&nbsp;" & maxperpage & "" & strUnit & "/页"
        If ShowAllPages = True Then
            strTemp = strTemp & "&nbsp;转到：<select name='page' size='1' onchange=""javascript:window.location='" & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"
            For i = 1 To n
                strTemp = strTemp & "<option value='" & i & "'"
                If CInt(CurrentPage) = CInt(i) Then strTemp = strTemp & " selected "
                strTemp = strTemp & ">" & i & "</option>"
            Next
            strTemp = strTemp & "</select>"
        End If
        strTemp = strTemp & "</div>"
        showpage = strTemp
    End Function
    Public Function JoinChar(strUrl)
        If strUrl = "" Then
            JoinChar = ""
            Exit Function
        End If
        If InStr(strUrl, "?") < Len(strUrl) Then
            If InStr(strUrl, "?") > 1 Then
                If InStr(strUrl, "&") < Len(strUrl) Then
                    JoinChar = strUrl & "&"
                Else
                    JoinChar = strUrl
                End If
            Else
                JoinChar = strUrl & "?"
            End If
        Else
            JoinChar = strUrl
        End If
    End Function
    Public Function htm2js(Str)
        If Str = "" Or IsNull(Str) Then Str = " "
        htm2js = "document.write('" & Replace(Replace(Replace(Replace(Str, "\", "\\"), "'", "\'"), vbCrLf, "\n"), Chr(13), "") & "');"
    End Function
    '将htm代码插入div
    Public Function htm2js_div(Str, divid)
        divid = Trim(divid)
        If Str = "" Or IsNull(Str) Then Str = " "
        htm2js_div = "if (chkdiv('" & divid & "')) {"
        htm2js_div = htm2js_div & "document.getElementById('"&divid&"')" & ".innerHTML='" & Replace(Replace(Replace(Replace(Replace(Str, "\", "\\"), "'", "\'"), vbCrLf, "\n"), Chr(13), ""),Chr(10),"") & "';}"
        If divid = "subject" Then htm2js_div = htm2js_div & vbCrLf & "if (chkdiv('subject_l')) {document.getElementById('subject_l').innerHTML='" & Replace(Replace(Replace(Replace(Str, "\", "\\"), "'", "\'"), vbCrLf, "\n"), Chr(13), "") & "';}"
    End Function
    Public Function readfile(mPath, fName)
        On Error Resume Next
        Dim fs2, f2, fpath
        Set fs2 = server.CreateObject("Scripting.FileSystemObject")
        fpath = server.MapPath(mPath) & "\"
        fpath = fpath & fName
        Set f2 = fs2.OpenTextFile(fpath, 1, True)
        readfile = f2.ReadAll
        Set fs2 = Nothing
        Set f2 = Nothing
    End Function
    Public Function showsize(size)
        On Error Resume Next
        If size = "" Or IsNull(size) Then
            showsize = "0Byte"
            Exit Function
        End If
        showsize = size & "Byte"
        If size < 0 Then
            showsize = "0KB"
            Exit Function
        End If
        If size > 1024 Then
           size = (size \ 1024)
           showsize = size & "KB"
        End If
        If size > 1024 Then
           size = (size / 1024)
           showsize = FormatNumber(size, 2) & "MB"
        End If
        If size > 1024 Then
           size = (size / 1024)
           showsize = FormatNumber(size, 2) & "GB"
        End If
    End Function
    Public Function ChkPost()
        Dim server_v1, server_v2
		ChkPost = False
		if true_domain=1 then
			ChkPost=true
			exit function
        end if
        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 Function filt_badstr(sSql)
		 If ISNull(sSql) Then Exit Function
		 sSql=Trim(sSql)
		 If sSql="" Then Exit Function 
		 sSql=Replace(sSql,Chr(0),"") 
		 sSql=Replace(sSql,"'","''")
		 'sSql=Replace(sSql,"%","％")
		 'sSql=Replace(sSql,"-","－")  
		 filt_badstr=sSql
	End Function
    Public Function filt_astr(Str, n)
        If IsNull(Str) Then
            filt_astr = ""
            Exit Function
        End If
        filt_astr = filt_badword(Str)
        filt_astr = InterceptStr(filt_astr, n)
    End Function
    Public Function filt_html(Str)
        On Error Resume Next
        If Str = "" Then
            filt_html = ""
        Else
            Str = Replace(Str, ">", "&gt;")
            Str = Replace(Str, "<", "&lt;")
            Str = Replace(Str, Chr(32), "&nbsp;")
            Str = Replace(Str, Chr(9), "&nbsp;")
            Str = Replace(Str, Chr(34), "&quot;")
            Str = Replace(Str, Chr(39), "&#39;")
            Str = Replace(Str, Chr(13), "")
            Str = Replace(Str, Chr(10) & Chr(10), "&nbsp; ")
            Str = Replace(Str, Chr(10), "&nbsp; ")
            filt_html = Str
        End If
    End Function
    Public Function filt_html_b(fString)
        If Not IsNull(fString) Then
            fString = Replace(fString, ">", "&gt;")
            fString = Replace(fString, "<", "&lt;")
            fString = Replace(fString, Chr(32), " ")
            fString = Replace(fString, Chr(9), " ")
            fString = Replace(fString, Chr(34), "&quot;")
            'fString = Replace(fString, CHR(39), "&#39;")
            fString = Replace(fString, Chr(13), "")
            fString = Replace(fString, Chr(10) & Chr(10), "</p><p> ")
            fString = Replace(fString, Chr(10), "<br> ")
            filt_html_b = fString
        End If
    End Function

    Public Function strLength(Str)
        On Error Resume Next
        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
                End If
            Next
            strLength = t
        Else
        strLength = Len(Str)
        End If
        If Err.Number <> 0 Then Err.Clear
    End Function
    Public Function InterceptStr(txt, length)
        Dim x, y, ii
        txt = Trim(txt)
        x = Len(txt)
        y = 0
        If x >= 1 Then
            For ii = 1 To x
                If Asc(Mid(txt, ii, 1)) < 0 Or Asc(Mid(txt, ii, 1)) > 255 Then '如果是汉字
                    y = y + 2
                Else
                    y = y + 1
                End If
                If y >= length Then
                    txt = Left(Trim(txt), ii) '字符串限长
                    Exit For
                End If
            Next
            InterceptStr = txt
        Else
            InterceptStr = ""
        End If
    End Function
    '读取用户目录对应绑定的路径，未绑定返回空
    Public Function getdirdomain(udir)
        Dim tmp1, tmp2, Str
        Str = Application(cache_name & "dirdomain")
        udir = Trim(udir)
        tmp1 = InStr(Str, udir & "!!??((")
        tmp2 = Len(udir & "!!??((") + tmp1
        If tmp1 > 0 Then
            getdirdomain = Mid(Str, tmp2, InStr(tmp1, Str, "##))==") - tmp2)
        Else
            getdirdomain = ""
    End If
    End Function
    Public Function GetUrl()
        On Error Resume Next
        Dim strTemp
        If LCase(request.ServerVariables("HTTPS")) = "off" Then
        strTemp = "http://"
        Else
        strTemp = "https://"
        End If
        strTemp = strTemp & request.ServerVariables("SERVER_NAME")
        If request.ServerVariables("SERVER_PORT") <> 80 Then strTemp = strTemp & ":" & request.ServerVariables("SERVER_PORT")
        strTemp = strTemp & request.ServerVariables("URL")
        If Trim(request.QueryString) <> "" Then strTemp = strTemp & "?" & Trim(request.QueryString)
        GetUrl = strTemp
    End Function
    Public Function trueurl(strContent)
        On Error Resume Next
        Dim tempReg, url
        url = Trim("http://" & request.ServerVariables("SERVER_NAME"))
        url = LCase(url & request.ServerVariables("SCRIPT_NAME"))
        url = Left(url, InStrRev(url, "/"))
        Set tempReg = New RegExp
        tempReg.IgnoreCase = True
        tempReg.Global = True
        tempReg.Pattern = "(^.*\/).*$" '含文件名的标准路径
        url = tempReg.Replace(url, "$1")
        tempReg.Pattern = "((?:src|href).*?=[\'\u0022](?!ftp|http|https|mailto))"
        trueurl = tempReg.Replace(strContent, "$1" + url)
        Set tempReg = Nothing
    End Function
    Public Function IsValidEmail(email)
        Dim names, name, i, c
        IsValidEmail = True
        names = Split(email, "@")
        If UBound(names) <> 1 Then
           IsValidEmail = False
           Exit Function
        End If
        For Each name In names
           If Len(name) <= 0 Then
             IsValidEmail = False
             Exit Function
           End If
           For i = 1 To Len(name)
             c = LCase(Mid(name, i, 1))
             If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
               IsValidEmail = False
               Exit Function
             End If
           Next
           If Left(name, 1) = "." Or Right(name, 1) = "." Then
              IsValidEmail = False
              Exit Function
           End If
        Next
        If InStr(names(1), ".") <= 0 Then
           IsValidEmail = False
           Exit Function
        End If
        i = Len(names(1)) - InStrRev(names(1), ".")
        If i <> 2 And i <> 3 Then
           IsValidEmail = False
           Exit Function
        End If
        If InStr(email, "..") > 0 Then
           IsValidEmail = False
        End If
    End Function
    Public Function chkdomain(domain)
        Dim name, i, c
        name = domain
        chkdomain = True
        If Len(name) <= 0 Then
            chkdomain = False
            Exit Function
        End If
        For i = 1 To Len(name)
           c = LCase(Mid(name, i, 1))
            If InStr("abcdefghijklmnopqrstuvwxyz-", c) <= 0 And Not IsNumeric(c) Then
               chkdomain = False
            Exit Function
           End If
       Next
    End Function
    Public Function CodeCookie(Str)
    If is_password_cookies = 1 Then
        Dim i
        Dim StrRtn
        For i = Len(Str) To 1 Step -1
            StrRtn = StrRtn & AscW(Mid(Str, i, 1))
            If (i <> 1) Then StrRtn = StrRtn & "a"
        Next
        CodeCookie = StrRtn
    Else
        CodeCookie = Str
    End If
    End Function
    
    Public Function DecodeCookie(Str)
    If is_password_cookies = 1 Then
        Dim i
        Dim StrArr, StrRtn
        StrArr = Split(Str, "a")
        For i = 0 To UBound(StrArr)
            If IsNumeric(StrArr(i)) = True Then
                StrRtn = ChrW(StrArr(i)) & StrRtn
            Else
                StrRtn = Str
                Exit Function
            End If
        Next
        DecodeCookie = StrRtn
    Else
        DecodeCookie = Str
    End If
    End Function
    Private Sub class_terminate()
    On Error Resume Next
        If IsObject(conn) Then conn.Close: Set conn = Nothing
    End Sub
    
    Public Function BuildFile(ByVal sFile, ByVal sContent)
        Dim oFSO, oStream
        If is_gb2312 = 1 Then
            Set oFSO = server.CreateObject("Scripting.FileSystemObject")
            'Response.Write "目录1：" & sFile & "<br>"
            Set oStream = oFSO.CreateTextFile(sFile, True)
            oStream.Write sContent
            oStream.Close
            Set oStream = Nothing
            Set oFSO = Nothing
        Else
            Set oStream = server.CreateObject("ADODB.Stream")
            With oStream
                .Type = 2
                .Mode = 3
                .Open
                '.Charset = "utf-8"
                .Charset = "gb2312"
                .Position = oStream.size
                .WriteText = sContent
                .SaveToFile sFile, 2
                .Close
            End With
            Set oStream = Nothing
        End If
    End Function
    '过滤掉flash UBB标记
    '[flash=500,350]http://www.kunfu.net/movie.swf[/flash]
    Function FilterUBBFlash(ByVal strFlash)
        Dim strFlash1
        strFlash1 = LCase(strFlash)
        If InStr(strFlash1, "[/flash]") > 0 Then
            strFlash1 = Replace(strFlash1, "[/flash]", "[ /flash ]")
            strFlash1 = Replace(strFlash1, "[flash", "[ flash ")
            FilterUBBFlash = strFlash1
        Else
            FilterUBBFlash = strFlash
        End If
    End Function
    
    'CheckAdmin
    Public Function CheckAdmin()
    	Dim admin_name,admin_password,sql,rs	
    	CheckAdmin=False
    	admin_name=filt_badstr(session("adminname"))
			admin_password=filt_badstr(session("adminpassword"))
    	If IsEmpty(admin_name) Or admin_name="" Then Exit Function
			sql="select id,password from oblog_admin where username='" & admin_name & "' and password='"&admin_password&"'"
			If Not IsObject(conn) Then link_database
			Set rs=conn.execute(sql)
			if Not rs.eof then
				If rs(1)=admin_password Then
					rs.close
					set rs=nothing
					CheckAdmin=True
					Exit Function				
				End If
			End if
			rs.close
			Set rs=Nothing	
		End Function	
End Class
%>

