user_space_code.asp

个人网站比较简短

                rsBlog("Department") = Department
                rsBlog("ZipCode") = ZipCode
                rsBlog("HomePage") = Homepage
                rsBlog("Email") = Email
                rsBlog("QQ") = PE_CLng(QQ)
            End If
            rsBlog("Intro") = Intro
            If Photo <> "" Then rsBlog("Photo") = Photo
            rsBlog("Type") = addtype
            If Trim(LinkUrl & "") = "" Then
               rsBlog("LinkUrl") = Null
            Else
               rsBlog("LinkUrl") = LinkUrl
            End If
            rsBlog("listnum") = listnum
            rsBlog.Update
    End If
    rsBlog.Close
    Set rsBlog = Nothing
    Call CloseConn
    Response.Redirect "User_Space.asp?Action=Manage"
End Sub

Sub Del()
    Dim BlogID, cusers, UserPassword, LastPassword
    BlogID = PE_CLng(Trim(Request("ID")))
    If BlogID = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请先选定聚合！</li>"
        Exit Sub
    End If

    UserPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserPassword")))
    LastPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("LastPassword")))
    Set cusers = Conn.Execute("select A.ID,C.UserID,C.UserName,C.UserPassword,C.LastPassword from PE_Space A inner join PE_User C on A.UserID=C.UserID Where A.ID=" & BlogID)
    If cusers.BOF And cusers.EOF Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>身份认证失败！</li>"
    Else
        If UserName <> cusers("UserName") Or UserPassword <> cusers("UserPassword") Or LastPassword <> cusers("LastPassword") Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>身份认证失败！</li>"
        End If
    End If
    Set cusers = Nothing
    If FoundErr = True Then Exit Sub

    Conn.Execute ("delete from PE_Space where ID=" & CLng(BlogID) & "")
    Call CloseConn
    Response.Redirect ComeUrl
End Sub

Sub SetStat()
    Dim cusers, UserPassword, LastPassword, BlogID, OrderID, tmporderid
    tmporderid = Split(Action, "|")
    If UBound(tmporderid) = 1 Then
        BlogID = PE_CLng(tmporderid(1))
        OrderID = PE_CLng(Trim(Request.Form("OrderID" & BlogID)))
        UserPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserPassword")))
        LastPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("LastPassword")))
        Set cusers = Conn.Execute("select A.ID,C.UserID,C.UserName,C.UserPassword,C.LastPassword from PE_Space A inner join PE_User C on A.UserID=C.UserID Where A.ID=" & BlogID)
        If cusers.BOF And cusers.EOF Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>身份认证失败！</li>"
        Else
            If UserName <> cusers("UserName") Or UserPassword <> cusers("UserPassword") Or LastPassword <> cusers("LastPassword") Then
                FoundErr = True
                ErrMsg = ErrMsg & "<li>身份认证失败！</li>"
            End If
        End If
        Set cusers = Nothing
        If FoundErr = True Then Exit Sub
        If OrderID > 1 And BlogID > 0 Then Conn.Execute ("update PE_Space set OrderID=" & OrderID & " where ID=" & BlogID & "")
    End If
    Call CloseConn
    Response.Redirect ComeUrl
End Sub

Sub CreateBlogDir(Uid, UName)
    If PE_CLng(Uid) = 0 Or Trim(UName & "") = "" Then Exit Sub
    On Error Resume Next
    Dim fsfl, fl, strDir
    
    '强制使用用户ID结尾，防止建立非法目录
    Dim spacename
    spacename = Replace(LCase(UName & Uid), ".", "")

    strDir = InstallDir & "Space/" & spacename & "/"
    If fso.FolderExists(Server.MapPath(strDir)) = False Then fso.CreateFolder Server.MapPath(strDir)

    Set fsfl = fso.GetFolder(Server.MapPath(InstallDir & "Space/Default/"))
    For Each fl In fsfl.Files
        fl.Copy Server.MapPath(strDir & fl.name), True
    Next

    Set fsfl = fso.CreateTextFile(Server.MapPath(strDir & "config.xml"), True)
    fsfl.WriteLine ("<?" & "xml version=""1.0"" encoding=""gb2312""" & "?>")
    fsfl.WriteLine ("<" & "body" & ">")
    fsfl.WriteLine ("<" & "baseconfig" & ">")
    fsfl.WriteLine ("<" & "userid" & ">" & Uid & "</" & "userid" & ">")
    fsfl.WriteLine ("</" & "baseconfig" & ">")
    fsfl.WriteLine ("</" & "body" & ">")

    '设置聚合为未审核状态
    If PE_CLng(UserSetting(26)) = 0 Then
        Set fsfl = fso.CreateTextFile(Server.MapPath(strDir & "index.asp"), True)
        fsfl.WriteLine ("审核中...")
    End If
    fsfl.Close
    Set fsfl = Nothing
End Sub

Sub Template()
If PE_CLng(UserSetting(28)) = 1 Then
    On Error Resume Next
    Dim fsfl, fc, fl, UDir
    Dim spacename
    spacename = Replace(LCase(UserName & UserID), ".", "")

    UDir = InstallDir & "Space/" & spacename & "/"
    If fso.FolderExists(Server.MapPath(UDir)) = False Then
        Response.Write "<br><center>用户空间不存在<br><br><a href='User_Space.asp?Action=Template'>【 返回 】</a></center>"
    Else
        Response.Write "<br>"
        Response.Write "<table width='100%' border='0' cellpadding='0' cellspacing='0'><tr><td align='center'>请选择您想使用的空间皮肤</td></tr></table>"
        Response.Write "<table class='border' border='0' cellspacing='15' width='100%' cellpadding='15'><tr align='center'>"
        Set fsfl = fso.GetFolder(Server.MapPath(InstallDir & "Space/Template/"))
        Set fc = fsfl.SubFolders
        i = 1
        For Each fl In fc
            Response.Write "<td><a href='#' onclick=""changetemplate('" & fl.name & "');""><img src='" & InstallDir & "Space/Template/" & fl.name & ".gif' border='0' alt='" & fl.name & "'><br>" & fl.name & "</a></td>"
            If i Mod 3 = 0 Then
                Response.Write "</tr><tr align='center'>"
            End If
            i = i + 1
        Next
        Set fsfl = Nothing
        Response.Write "</table>"
    End If
Else
    Response.Write "<br><center>您无权更换空间皮肤<br><br><a href='User_Space.asp?Action=Manage'>【 返回 】</a></center>"
End If
End Sub

Sub CTemplate()
If PE_CLng(UserSetting(28)) = 1 Then
    Dim fname
    fname = Trim(Request("fname"))
    fname = Replace(Replace(fname, ".", ""), "/", "")
    Dim fsfl, fl, UDir, spacename
    spacename = Replace(LCase(UserName & UserID), ".", "")
    UDir = InstallDir & "Space/" & spacename & "/"
    If fso.FolderExists(Server.MapPath(UDir)) = False Then
        Response.Write "<br><center>用户空间不存在<br><br><a href='User_Space.asp?Action=Template'>【 返回 】</a></center>"
    Else
        dim fflag, fc
        fflag = 0
        Set fsfl = fso.GetFolder(Server.MapPath(InstallDir & "Space/Template/"))
        Set fc = fsfl.SubFolders
        For Each fl In fc
            If fl.name = fname Then
                fflag = 1
            End If
        Next
        If fflag = 1 Then
            Set fsfl = fso.GetFolder(Server.MapPath(InstallDir & "Space/Template/" & fname))
            For Each fl In fsfl.Files
                fl.Copy Server.MapPath(UDir & fl.name), True
            Next
            If fso.FolderExists(Server.MapPath(InstallDir & "Space/Template/" & fname & "/skin")) Then
                If fso.FolderExists(Server.MapPath(UDir & "skin")) Then
                    fso.DeleteFolder (Server.MapPath(UDir & "skin"))
                End If
                fso.CopyFolder Server.MapPath(InstallDir & "Space/Template/" & fname & "/skin"), Server.MapPath(UDir & "skin")
            End If
            Response.Write "<br><center>您的空间已经成功的应用了新皮肤“" & fname & "”!<br><br><a href='../Space/" & spacename & "' target='_blank'>【 查看效果 】</a><br><a href='User_Space.asp?Action=Template'>【 返回 】</a></center>"
        Else
            Response.Write "<br><center>您选择的皮肤不存在<br><br><a href='User_Space.asp?Action=Manage'>【 返回 】</a></center>"       
        End If
        Set fsfl = Nothing

    End If
Else
    Response.Write "<br><center>您无权更换空间皮肤<br><br><a href='User_Space.asp?Action=Manage'>【 返回 】</a></center>"
End If
End Sub

Function GetKingOpti(iselected)
    Dim strtmp, rskind
    Set rskind = Conn.Execute("select KindID,KindName from PE_SpaceKind order by OrderID")
    Do While Not rskind.EOF
        strtmp = strtmp & "<option value=" & rskind("KindID")
        If iselected = rskind("KindID") Then
            strtmp = strtmp & " selected"
        End If
        strtmp = strtmp & ">" & rskind("KindName") & "</option>"
        rskind.MoveNext
    Loop
    Set rskind = Nothing
    strtmp = strtmp & "<option value=0"
    If iselected = 0 Then
        strtmp = strtmp & " selected"
    End If
    strtmp = strtmp & ">不属于任何分类</option>"
    GetKingOpti = strtmp
End Function

Function GetKingName(iselected)
    Dim strtmp, rskind, KindS

    If oldKInd = "" Then oldKInd = "0|||无分类"

    KindS = Split(oldKInd, "|||")
    If KindS(0) <> iselected Then
        Set rskind = Conn.Execute("select top 1 KindID,KindName from PE_SpaceKind Where KindID=" & iselected)
        If Not (rskind.BOF And rskind.EOF) Then
            strtmp = rskind("KindName")
        Else
            strtmp = "无分类"
        End If
        oldKInd = iselected & "|||" & strtmp
        Set rskind = Nothing
    Else
        strtmp = KindS(1)
    End If
    GetKingName = strtmp
End Function
%>