<%@ LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<%
'***************PJblog2 基本设置*******************
' PJblog2 Copyright 2005
' Update:2005-8-16
'**************************************************
Option Explicit
Response.Buffer = True
Server.ScriptTimeOut = 90
Session.CodePage = 65001
Session.LCID = 2057
'定义 Cookie,Application 域，必须修改，否则可能运行不正常
'把"PJBlog3"和"PJBlog3Setting"引号里面的东西替换称任意英文数值值即可
Const CookieName = "PJBlog3"
Const CookieNameSetting = "PJBlog3Setting"
Const IPViewURL = "http://www.dheart.net/ip/index.php?ip=" 'IP查询网站地址
Response.Cookies(CookieNameSetting).Expires = Date+365
Response.Cookies(CookieName).path = "/"
'站点开关操作
If Not IsNumeric(Application(CookieName & "_SiteEnable")) Or IsEmpty(Application(CookieName & "_SiteEnable")) Then
Application.Lock
Application(CookieName & "_SiteEnable") = 1
Application(CookieName & "_SiteDisbleWhy") = ""
Application.UnLock
End If
If Application(CookieName & "_SiteEnable") = 0 And Application(CookieName & "_SiteDisbleWhy")<>"" And InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/control.asp") = 0 And InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/login.asp") = 0 And InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/conmenu.asp") = 0 And InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/conhead.asp") = 0 And InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/concontent.asp") = 0 Then
Response.Write(""&Application(CookieName & "_SiteDisbleWhy")&"
")
Response.End
End If
Dim StartTime, SQLQueryNums
StartTime = Timer()
SQLQueryNums = 0
'定义数据库链接文件，建议修改
'blogDB/PBLog3.asp为数据库路径，PBLog3.asp为数据库，修改这里就要修改相关的文件夹及数据库名字
Const AccessFile = "blogDB/PBLog3.asp.mdb"
'定义数据库连接
Dim Conn
Dim SQL, TempVar, siteTitle, Skins
Dim log_Year, log_Month, log_Day, SQLFiltrate, cateID
Dim viewType, Url_Add, CurPage
SQLFiltrate = "WHERE"
log_Year = CheckStr(Trim(Request.QueryString("log_Year")))
log_Month = CheckStr(Trim(Request.QueryString("log_Month")))
log_Day = CheckStr(Trim(Request.QueryString("log_Day")))
cateID = CheckStr(Trim(Request.QueryString("cateID")))
viewType = CheckStr(Trim(Request.QueryString("viewType")))
SQLFiltrate = "WHERE"
Url_Add = "?"
If IsInteger(cateID) = True Then
SQLFiltrate = SQLFiltrate&" log_CateID="&CateID&" AND"
Url_Add = Url_Add&"CateID="&CateID&"&"
End If
If IsInteger(log_Year) = True Then
SQLFiltrate = SQLFiltrate&" year(log_PostTime)="&log_Year&" AND"
Url_Add = Url_Add&"log_Year="&log_Year&"&"
End If
If IsInteger(log_Month) = True Then
SQLFiltrate = SQLFiltrate&" month(log_PostTime)="&log_Month&" AND"
Url_Add = Url_Add&"log_Month="&log_Month&"&"
End If
If IsInteger(log_Day) = True Then
SQLFiltrate = SQLFiltrate&" day(log_PostTime)="&log_Day&" AND"
Url_Add = Url_Add&"log_Day="&log_Day&"&"
End If
If CheckStr(Request.QueryString("Page"))<>Empty Then
Curpage = CheckStr(Request.QueryString("Page"))
If IsInteger(Curpage) = False Then
Curpage = 1
elseif Curpage<0 then
Curpage = 1
end if
Else
Curpage = 1
End If
%>
<%
Call createConnection(AccessFile)
%>
<%
'***************PJblog2 缓存处理*******************
' PJblog2 Copyright 2006
' Update:2008-8-26
'**************************************************
'-------------------------Blog基本参数--------------------------
Dim blog_Infos, SiteName, SiteUrl, blogPerPage, blog_LogNums, blog_CommNums, blog_MemNums
Dim blog_VisitNums, blogBookPage, blog_MessageNums, blogcommpage, blogaffiche
Dim blogabout, blogcolsize, blog_colNums, blog_TbCount, blog_showtotal, blog_commTimerout
Dim blog_commUBB, blog_commImg, blog_version, blog_UpdateDate, blog_DefaultSkin, blog_SkinName, blog_SplitType
Dim blog_ImgLink, blog_postFile, blog_postCalendar, log_SplitType, blog_introChar, blog_introLine
Dim blog_validate, Register_UserNames, Register_UserName, FilterIPs, FilterIP, blog_Title, blog_KeyWords, blog_Description, blog_SaveTime
Dim blog_commLength, blog_downLocal, blog_DisMod, blog_Disregister, blog_master, blog_email, blog_CountNum
Dim blog_wapNum, blog_wapImg, blog_wapHTML, blog_wapLogin, blog_wapComment, blog_wap, blog_wapURL, blog_currentCategoryID
Dim memoryCache, blog_UpLoadSet
'一些初始化的值
blog_version = "3.1.6.227" '当前PJBlog版本号
blog_UpdateDate = "2009-05-26"'PJBlog最新更新时间
memoryCache = false '全内存cache
'=========================日志基本信息缓存=======================
Sub getInfo(ByVal action)
Dim blog_Infos
'--------------写入基本信息缓存------------------
If Not IsArray(Application(CookieName&"_blog_Infos")) Or action = 2 Then
Dim log_Infos
SQL = "select top 1 blog_Name,blog_URL,blog_PerPage,blog_LogNums,blog_CommNums,blog_MemNums," & _
"blog_VisitNums,blog_BookPage,blog_MessageNums,blog_commPage,blog_affiche," & _
"blog_about,blog_colPage,blog_colNums,blog_tbNums,blog_showtotal," & _
"blog_FilterName,blog_FilterIP,blog_commTimerout,blog_commUBB,blog_commImg," & _
"blog_postFile,blog_postCalendar,blog_DefaultSkin,blog_SkinName,blog_SplitType," & _
"blog_introChar,blog_introLine,blog_validate,blog_Title,blog_ImgLink," & _
"blog_commLength,blog_downLocal,blog_DisMod,blog_Disregister,blog_master,blog_email,blog_CountNum," & _
"blog_wapNum,blog_wapImg,blog_wapHTML,blog_wapLogin,blog_wapComment,blog_wap,blog_wapURL,blog_KeyWords,blog_Description,blog_SaveTime,blog_UpLoadSet" & _
" from blog_Info"
Set log_Infos = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
blog_Infos = log_Infos.GetRows()
Set log_Infos = Nothing
Application.Lock
Application(CookieName&"_blog_Infos") = blog_Infos
Application.UnLock
Else
blog_Infos = Application(CookieName&"_blog_Infos")
End If
'--------------读取基本信息缓存------------------
If action<>2 Then
SiteName = blog_Infos(0, 0)'站点名字
SiteURL = blog_Infos(1, 0)'站点地址
blogPerPage = Int(blog_Infos(2, 0))'每页日志数
blog_LogNums = Int(blog_Infos(3, 0))'日志总数
blog_CommNums = Int(blog_Infos(4, 0))'评论总数
blog_MemNums = Int(blog_Infos(5, 0))'会员总数
blog_VisitNums = Int(blog_Infos(6, 0))'访问量
blogBookPage = Int(blog_Infos(7, 0))'每页留言数(备用)
blog_MessageNums = Int(blog_Infos(8, 0))'留言总数(备用)
blogcommpage = Int(blog_Infos(9, 0))'每页评论数
blogaffiche = blog_Infos(10, 0)'公告
blogabout = blog_Infos(11, 0)'备案信息
blogcolsize = Int(blog_Infos(12, 0))'每页书签数(备用)
blog_colNums = Int(blog_Infos(13, 0))'书签总数(备用)
blog_TbCount = Int(blog_Infos(14, 0))'引用通告总数
blog_showtotal = CBool(blog_Infos(15, 0))'是否显示统计(备用)
Register_UserNames = blog_Infos(16, 0)'注册名字过滤
Register_UserName = Split(Register_UserNames, "|")
FilterIPs = blog_Infos(17, 0)'IP地址过滤
FilterIP = Split(FilterIPs, "|")
blog_commTimerout = Int(blog_Infos(18, 0))'发表评论时间间隔
blog_commUBB = Int(blog_Infos(19, 0))'是否禁用评论UBB代码
blog_commIMG = Int(blog_Infos(20, 0))'是否禁用评论贴图
blog_postFile = blog_Infos(21, 0) '动态输出日志文件
blog_postCalendar = CBool(blog_Infos(22, 0)) '动态输出日志日历文件
blog_DefaultSkin = blog_Infos(23, 0)'默认界面
blog_SkinName = blog_Infos(24, 0)'界面名称
blog_SplitType = CBool(blog_Infos(25, 0))'日志分割类型
blog_introChar = blog_Infos(26, 0)'日志预览最大字符数
blog_introLine = blog_Infos(27, 0)'日志预览切割行数
blog_validate = CBool(blog_Infos(28, 0))'发表评论是否都需要验证
blog_Title = blog_Infos(29, 0)'Blog副标题
blog_ImgLink = CBool(blog_Infos(30, 0))'是否在首页显示图片友情链接
blog_commLength = Int(blog_Infos(31, 0))'评论长度
blog_downLocal = CBool(blog_Infos(32, 0))'是否使用防盗链下载
blog_DisMod = CBool(blog_Infos(33, 0))'默认显示内容
blog_Disregister = CBool(blog_Infos(34, 0))'是否允许注册
blog_master = blog_Infos(35, 0)'blog管理员姓名
blog_email = blog_Infos(36, 0)'blog管理员邮件地址
blog_CountNum = blog_Infos(37, 0)'访客统计最大次数
blog_wapNum = Int(blog_Infos(38, 0))'Wap 文章列表数量
blog_wapImg = CBool(blog_Infos(39, 0))'Wap 文章显示图片
blog_wapHTML = CBool(blog_Infos(40, 0))'Wap 文章使用简单HTML
blog_wapLogin = CBool(blog_Infos(41, 0))'Wap 允许登录
blog_wapComment = CBool(blog_Infos(42, 0))'Wap 允许评论
blog_wap = CBool(blog_Infos(43, 0))'使用 wap
blog_wapURL = CBool(blog_Infos(44, 0))'使用 wap 转换文章超链接
blog_KeyWords = blog_Infos(45, 0)'站点首页KeyWords
blog_Description = blog_Infos(46, 0)'站点首页Description
blog_SaveTime = blog_Infos(47, 0)'Ajax草稿自动保存时间间隔
blog_UpLoadSet = blog_Infos(48, 0)'附件管理
End If
End Sub
'======================End Sub=======================
'-------------------------Blog权限变量---------------
Dim stat_title, stat_AddAll, stat_EditAll, stat_DelAll, stat_Add, stat_Edit, stat_Del, stat_CommentAdd
Dim stat_CommentDel, stat_Admin, stat_code, UP_FileType, UP_FileSize, UP_FileTypes, stat_FileUpLoad
Dim stat_CommentEdit, stat_ShowHiddenCate
'=====================日志权限缓存===================
Sub UserRight(ByVal action) '读取日志权限
Dim blog_Status
'--------------写入日志权限缓存------------------
If Not IsArray(Application(CookieName&"_blog_rights")) Or action = 2 Then
Dim log_Status, log_StatusList
SQL = "select stat_name,stat_title,stat_Code,stat_attSize,stat_attType from blog_status"
Set log_Status = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
blog_Status = log_Status.GetRows()
Set log_Status = Nothing
Application.Lock
Application(CookieName&"_blog_rights") = blog_Status
Application.UnLock
Else
blog_Status = Application(CookieName&"_blog_rights")
End If
'--------------写入日志权限缓存------------------
If action<>2 Then
Dim blog_Status_Len, i
blog_Status_Len = UBound(blog_Status, 2)
For i = 0 To blog_Status_Len
If blog_Status(0, i) = memStatus Then
stat_title = blog_Status(1, i)
FillRight blog_Status(2, i)
UP_FileSize = blog_Status(3, i)
UP_FileTypes = blog_Status(4, i)
UP_FileType = Split(UP_FileTypes, "|")
'exit Sub
End If
Next
End If
End Sub
Sub FillRight(StatusCode) '写入权限变量
stat_AddAll = CBool(Mid(StatusCode, 1, 1))
stat_Add = CBool(Mid(StatusCode, 2, 1))
stat_EditAll = CBool(Mid(StatusCode, 3, 1))
stat_Edit = CBool(Mid(StatusCode, 4, 1))
stat_DelAll = CBool(Mid(StatusCode, 5, 1))
stat_Del = CBool(Mid(StatusCode, 6, 1))
stat_CommentAdd = CBool(Mid(StatusCode, 7, 1))
stat_CommentEdit = CBool(Mid(StatusCode, 8, 1))
stat_CommentDel = CBool(Mid(StatusCode, 9, 1))
stat_FileUpLoad = CBool(Mid(StatusCode, 10, 1))
stat_Admin = CBool(Mid(StatusCode, 11, 1))
stat_ShowHiddenCate = CBool(Mid(StatusCode, 12, 1))
Response.Cookies(CookieName)("memRight") = StatusCode
If DateDiff("d",Date(),Request.Cookies(CookieName)("exp"))>0 Then
Response.Cookies(CookieName).Expires = Date + DateDiff("d",Date(),Request.Cookies(CookieName)("exp"))
End If
End Sub
'=========================End Sub========================
'========================日志分类缓存=========================
Function CategoryList(ByVal action) '日志分类
'写入日志分类
'action=0 横向菜单 action=1 树状菜单 action=2重建分类, 默认尝试返回Arr_Category
'--------------写入日志分类缓存------------------
Dim Arr_Category, i
If Not IsArray(Application(CookieName&"_blog_Category")) Or action = 2 Then
Dim log_Category
TempVar = ""
SQL = "SELECT cate_ID,cate_Name,cate_Order,cate_Intro,cate_OutLink,cate_URL,cate_icon,cate_count,cate_Lock,cate_local,cate_Secret,cate_Part FROM blog_Category ORDER BY cate_Order ASC"
Set log_Category = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
If log_Category.EOF Or log_Category.bof Then
ReDim Arr_Category(0, 0)
Else
Arr_Category = log_Category.GetRows()
End If
Set log_Category = Nothing
Application.Lock
Application(CookieName&"_blog_Category") = Arr_Category
Application.UnLock
Else
Arr_Category = Application(CookieName&"_blog_Category")
End If
CategoryList = "" '初始化
Dim Category_Len, Menu_Diver
'--------------输出日志横向菜单------------------
If action = 0 Then
Menu_Diver = ""
CategoryList = ""
If UBound(Arr_Category, 1) = 0 Then
CategoryList = CategoryList&"
![]()
"&Arr_Category(1, i)&"
")
Else
CategoryList = CategoryList&("![]()
"&Arr_Category(1, i)&"
")
End If
Else
If CBool(Arr_Category(10, i)) Then
If stat_ShowHiddenCate Or stat_Admin Then CategoryList = CategoryList&("![]()
"&Arr_Category(1, i)&" ["&Arr_Category(7, i)&"] ![]()
")
Else
CategoryList = CategoryList&("![]()
"&Arr_Category(1, i)&" ["&Arr_Category(7, i)&"] ![]()
")
End If
End If
End If
Next
End If
End Function
'========================End Sub===============================
'========================日志归档缓存============================
Function Archive(ByVal action)'日志归档
Dim blog_archive, i
'-----------------写入日志归档缓存--------------------
If Not IsArray(Application(CookieName&"_blog_archive")) Or action = 2 Then
Dim log_archives
SQL = "SELECT Count(log_ID) AS [count], Year([log_PostTime]) AS PostYear, Month([log_PostTime]) AS PostMonth " &_
"FROM blog_Content where blog_Content.log_IsDraft=false "&_
"GROUP BY Year([log_PostTime]), Month([log_PostTime]) "&_
"ORDER BY Year([log_PostTime]) Desc, Month([log_PostTime]) ASC"
Set log_archives = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
If log_archives.EOF Or log_archives.bof Then
ReDim blog_archive(0, 0)
Else
blog_archive = log_archives.GetRows()
End If
Set log_archives = Nothing
Application.Lock
Application(CookieName&"_blog_archive") = blog_archive
Application.UnLock
Else
blog_archive = Application(CookieName&"_blog_archive")
End If
'-----------------读取日志归档缓存--------------------
If action<>2 Then
Dim archive_item_Len, Month_array, TempYear, MonthCounter
If UBound(blog_archive, 1) = 0 Then
Archive = ""
Exit Function
End If
Month_array = Array("01月", "02月", "03月", "04月", "05月", "06月", "07月", "08月", "09月", "10月", "11月", "12月")
archive_item_Len = UBound(blog_archive, 2)
TempYear = blog_archive(1, 0)
MonthCounter = 0
For i = 0 To archive_item_Len
If i = 0 Then Archive = ""&blog_archive(1, i)&""
If blog_archive(1, i) = TempYear Then
Archive = Archive&""&Month_array(blog_archive(2, i) -1)&""
MonthCounter = MonthCounter + 1
If MonthCounter = 5 Then
MonthCounter = 0
Archive = Archive&"
"
End If
Else
MonthCounter = 1
Archive = Archive&""&blog_archive(1, i)&""
Archive = Archive&""&Month_array(blog_archive(2, i) -1)&""
TempYear = blog_archive(1, i)
End If
Next
End If
End Function
'=====================End Function========================
'=====================最新评论缓存=====================
Function NewComment(ByVal action)
Dim blog_Comment, ShowLen, i
ShowLen = 10 '显示最新评论预览数量
'-----------------写入最新评论缓存--------------------
If Not IsArray(Application(CookieName&"_blog_Comment")) Or action = 2 Then
Dim log_Comments
SQL = "SELECT top "&ShowLen&" comm_ID,blog_ID,comm_Author,comm_Content,comm_PostTime" &_
" FROM blog_Comment as C,blog_Content as T,blog_Category as A where C.blog_ID=T.log_ID and T.log_IsShow=true and T.log_CateID=A.cate_ID and A.cate_Secret=false order by C.comm_PostTime Desc"
Set log_Comments = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
If log_Comments.EOF Or log_Comments.bof Then
ReDim blog_Comment(0, 0)
Else
blog_Comment = log_Comments.GetRows(ShowLen)
End If
Set log_Comments = Nothing
Application.Lock
Application(CookieName&"_blog_Comment") = blog_Comment
Application.UnLock
Else
blog_Comment = Application(CookieName&"_blog_Comment")
End If
'-----------------读取最新评论缓存--------------------
If action<>2 Then
Dim Comment_Item_Len
If UBound(blog_Comment, 1) = 0 Then
NewComment = ""
Exit Function
End If
Comment_Item_Len = UBound(blog_Comment, 2)
dim url
For i = 0 To Comment_Item_Len
If blog_postFile = 2 Then
url = SiteURL&caload(blog_Comment(1, i))&"#comm_"&blog_Comment(0, i)
else
url = SiteURL&"article.asp?id="&blog_Comment(1, i)&"#comm_"&blog_Comment(0, i)
end if
NewComment = NewComment&""&CCEncode(CutStr(DelQuote(blog_Comment(3, i)), 25))&""
Next
End If
End Function
'=====================End Function========================
'====================写入标签Tag缓存=====================
Dim Arr_Tags
Function Tags(ByVal action)
If Not IsArray(Application(CookieName&"_blog_Tags")) Or action = 2 Then
Dim log_Tags, log_TagsList
Set log_Tags = Conn.Execute("SELECT tag_id,tag_name,tag_count FROM blog_tag")
SQLQueryNums = SQLQueryNums + 1
TempVar = ""
Do While Not log_Tags.EOF
log_TagsList = log_TagsList&TempVar&log_Tags("tag_id")&"||"&log_Tags("tag_name")&"||"&log_Tags("tag_count")
TempVar = ","
log_Tags.MoveNext
Loop
Set log_Tags = Nothing
Arr_Tags = Split(log_TagsList, ",")
Application.Lock
Application(CookieName&"_blog_Tags") = Arr_Tags
Application.UnLock
Else
Arr_Tags = Application(CookieName&"_blog_Tags")
End If
End Function
'======================End Function========================
'====================写入表情符号缓存=====================
Dim Arr_Smilies
Function Smilies(ByVal action)
If Not IsArray(Application(CookieName&"_blog_Smilies")) Or action = 2 Then
Dim log_Smilies, log_SmiliesList
Set log_Smilies = Conn.Execute("SELECT sm_ID,sm_Image,sm_Text FROM blog_Smilies")
SQLQueryNums = SQLQueryNums + 1
TempVar = ""
Do While Not log_Smilies.EOF
log_SmiliesList = log_SmiliesList&TempVar&log_Smilies("sm_ID")&"|"&log_Smilies("sm_Image")&"|"&log_Smilies("sm_Text")
TempVar = ","
log_Smilies.MoveNext
Loop
Set log_Smilies = Nothing
Arr_Smilies = Split(log_SmiliesList, ",")
Application.Lock
Application(CookieName&"_blog_Smilies") = Arr_Smilies
Application.UnLock
Else
Arr_Smilies = Application(CookieName&"_blog_Smilies")
End If
End Function
'======================End Function========================
'======================写入关键字列表======================
Dim Arr_Keywords
Function Keywords(ByVal action)
If Not IsArray(Application(CookieName&"_blog_Keywords")) Or action = 2 Then
Dim log_Keywords, log_KeywordsList
Set log_Keywords = Conn.Execute("SELECT key_ID,key_Text,key_URL,key_Image FROM blog_Keywords")
SQLQueryNums = SQLQueryNums + 1
TempVar = ""
Do While Not log_Keywords.EOF
If log_Keywords("key_Image")<>Empty Then
log_KeywordsList = log_KeywordsList&TempVar&log_Keywords("key_ID")&"$|$"&log_Keywords("key_Text")&"$|$"&log_Keywords("key_URL")&"$|$"&log_Keywords("key_Image")
Else
log_KeywordsList = log_KeywordsList&TempVar&log_Keywords("key_ID")&"$|$"&log_Keywords("key_Text")&"$|$"&log_Keywords("key_URL")&"$|$None"
End If
TempVar = "|$|"
log_Keywords.MoveNext
Loop
Set log_Keywords = Nothing
Arr_Keywords = Split(log_KeywordsList, "|$|")
Application.Lock
Application(CookieName&"_blog_Keywords") = Arr_Keywords
Application.UnLock
Else
Arr_Keywords = Application(CookieName&"_blog_Keywords")
End If
End Function
'======================End Function=========================
'=======================写入首页链接列表====================
Dim Arr_Bloglinks
Function Bloglinks(ByVal action)
If Not IsArray(Application(CookieName&"_blog_Bloglinks")) Or action = 2 Then
Dim log_Bloglinks, log_BloglinksList
Set log_BlogLinks = Conn.Execute("SELECT link_Name,link_URL,link_Image FROM blog_Links WHERE link_IsMain=True ORDER BY link_Order ASC")
SQLQueryNums = SQLQueryNums + 1
TempVar = ""
Do While Not log_BlogLinks.EOF
If log_BlogLinks("link_Image")<>Empty Then
log_BloglinksList = log_BloglinksList&TempVar&log_BlogLinks("link_Name")&"$|$"&log_BlogLinks("link_URL")&"$|$"&log_BlogLinks("link_Image")
Else
log_BloglinksList = log_BloglinksList&TempVar&log_BlogLinks("link_Name")&"$|$"&log_BlogLinks("link_URL")&"$|$None"
End If
TempVar = "|$|"
log_BlogLinks.MoveNext
Loop
Set log_BlogLinks = Nothing
Arr_Bloglinks = Split(log_BloglinksList, "|$|")
Application.Lock
Application(CookieName&"_blog_Bloglinks") = Arr_Bloglinks
Application.UnLock
Else
Arr_Bloglinks = Application(CookieName&"_blog_Bloglinks")
End If
If action = 1 Then
Dim Arr_Bloglink, Arr_BloglinkItem, ImgLink, TextLink
Bloglinks = ""
For Each Arr_Bloglink in Arr_Bloglinks
Arr_BloglinkItem = Split(Arr_Bloglink, "$|$")
If blog_ImgLink Then
If Arr_BloglinkItem(2) = "None" Then
TextLink = TextLink&""&Arr_BloglinkItem(0)&""
Else
ImgLink = ImgLink&"![]()
"
End If
Else
Bloglinks = Bloglinks&""&Arr_BloglinkItem(0)&""
End If
Next
If blog_ImgLink Then Bloglinks = ImgLink&TextLink
End If
End Function
'=====================End Function=======================
'======================自定义模块缓存=====================
Dim side_html_default, side_html, side_html_static, content_html_Top_default, content_html_Top, content_html_Bottom_default, content_html_Bottom, function_Plugin
Function log_module(ByVal action)
Dim blog_modules
side_html_default = "" '首页侧栏代码
side_html = "" '普通页面侧栏代码
side_html_static = "" '静态页面的侧边栏
content_html_Top_default = "" '首页内容代码顶部
content_html_Top = "" '普通页面内容代码顶部
content_html_Bottom_default = "" '首页内容代码底部
content_html_Bottom = "" '普通页面内容代码底部
function_Plugin = "" 'Blog功能插件
If Not IsArray(Application(CookieName&"_blog_module")) Or action = 2 Then
Dim blog_module, blog_module_array, TempDiv
TempDiv = ""
SQL = "SELECT type,title,name,HtmlCode,IndexOnly,SortID,PluginPath,InstallFolder,IsSystem FROM blog_module where IsHidden=false order by SortID"
Set blog_module = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
Do Until blog_module.EOF
If blog_module("type") = "sidebar" Then
side_html_default = side_html_default&""
If Len(blog_module("title"))>0 Then side_html_default = side_html_default&"
"&blog_module("title")&"
"
side_html_default = side_html_default&"
"&blog_module("HtmlCode")&"
"
If Len(blog_module("title"))>0 Then side_html = side_html&"
"&blog_module("title")&"
"
side_html = side_html&"
"&blog_module("HtmlCode")&"
"
If Len(blog_module("title"))>0 Then side_html_static = side_html_static&"
"&blog_module("title")&"
"
side_html_static = side_html_static&"
"&blog_module("HtmlCode")&"
"&blog_module("HtmlCode")&"
"
If blog_module("IndexOnly") = False Then
content_html_Top = content_html_Top&""&blog_module("HtmlCode")&"
"
End If
Else
content_html_Bottom_default = content_html_Bottom_default&""&blog_module("HtmlCode")&"
"
If blog_module("IndexOnly") = False Then
content_html_Bottom = content_html_Bottom&""&blog_module("HtmlCode")&"
"
End If
End If
End If
If blog_module("type") = "function" Then
function_Plugin = function_Plugin&TempDiv&blog_module("name")&"%|%"&blog_module("PluginPath")&"%|%"&blog_module("InstallFolder")
TempDiv = "$*$"
End If
blog_module.movenext
Loop
Set blog_module = Nothing
blog_modules = Array(side_html_default, side_html, content_html_Top_default, content_html_Top, content_html_Bottom_default, content_html_Bottom, function_Plugin,side_html_static)
Application.Lock
Application(CookieName&"_blog_module") = blog_modules
Application.UnLock
Else
blog_modules = Application(CookieName&"_blog_module")
End If
If action<>2 Then
side_html_default = UnCheckStr(blog_modules(0)) '首页侧栏代码
side_html = UnCheckStr(blog_modules(1)) '普通页面侧栏代码
side_html_static = UnCheckStr(blog_modules(7)) '静态页面侧栏代码
content_html_Top_default = UnCheckStr(blog_modules(2)) '首页内容代码顶部
content_html_Top = UnCheckStr(blog_modules(3)) '普通页面内容代码顶部
content_html_Bottom_default = UnCheckStr(blog_modules(4)) '首页内容代码底部
content_html_Bottom = UnCheckStr(blog_modules(5)) '普通页面内容代码底部
function_Plugin = blog_modules(6) 'Blog功能插件
End If
End Function
'========================End function=========================
'======================重新加载Blog缓存=====================
Sub reloadcache
getInfo(2)
UserRight(2)
CategoryList(2)
Archive(2)
NewComment(2)
Tags(2)
Smilies(2)
Keywords(2)
Bloglinks(2)
log_module(2)
Calendar "", "", "", 2
End Sub
'=====================304 支持==========================
'更新Etag
Sub newEtag
Application.Lock
Application(CookieName&"_Etag") = randomStr(10)
Application.UnLock
End Sub
'返回服务器的etag，由随机数和登录用户名组成
Function getEtag
if IsEmpty(Application(CookieName&"_Etag")) then
call newEtag
end if
getEtag = Application(CookieName&"_Etag") & "-" & CheckStr(Request.Cookies(CookieName)("memName"))
End Function
%>
<%
'===============================================================
' Function For PJblog3
' 更新时间: 2009-05-22
'===============================================================
'*************************************
'函数名 : FilterHtmlTags()
'用途 : 过滤html标签
'更新时间 : 2009-05-22
'*************************************
Function FilterHtmlTags(ByVal Description)
If len(Description) = 0 or Description = "" Then Exit Function
Dim FaStr, re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "<[^>]*?>"
'去掉 尖括号和换行
FaStr = re.replace(Description, "")
FaStr = replace(FaStr,Chr(13), "")
FaStr = replace(FaStr,Chr(10), "")
Set re = nothing
FilterHtmlTags = FaStr
End Function
'*************************************
'防XSS注入函数 更新于2009-04-21 by evio
'与checkstr()相比, checkxss更加安全
'*************************************
Function Checkxss(byVal ChkStr)
Dim Str
Str = ChkStr
If IsNull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str, "&", "&")
Str = Replace(Str, "'", "´")
Str = Replace(Str, """", """)
Str = Replace(Str, "<", "<")
Str = Replace(Str, ">", ">")
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(w)(here)"
Str = re.Replace(Str, "$1here")
re.Pattern = "(s)(elect)"
Str = re.Replace(Str, "$1elect")
re.Pattern = "(i)(nsert)"
Str = re.Replace(Str, "$1nsert")
re.Pattern = "(c)(reate)"
Str = re.Replace(Str, "$1reate")
re.Pattern = "(d)(rop)"
Str = re.Replace(Str, "$1rop")
re.Pattern = "(a)(lter)"
Str = re.Replace(Str, "$1lter")
re.Pattern = "(d)(elete)"
Str = re.Replace(Str, "$1elete")
re.Pattern = "(u)(pdate)"
Str = re.Replace(Str, "$1pdate")
re.Pattern = "(\s)(or)"
Str = re.Replace(Str, "$1or")
'----------------------------------
re.Pattern = "(java)(script)"
Str = re.Replace(Str, "$1script")
re.Pattern = "(j)(script)"
Str = re.Replace(Str, "$1script")
re.Pattern = "(vb)(script)"
Str = re.Replace(Str, "$1script")
'----------------------------------
If Instr(Str, "expression") > 0 Then
Str = Replace(Str, "expression", "expression", 1, -1, 0) '防止xss注入
End If
Set re = Nothing
Checkxss = Str
End Function
'*************************************
'获得基址
'*************************************
Function GetbaseUrl()
Dim baseUrl
baseUrl = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("URL")
baseUrl = Left(baseUrl, InStrRev(baseUrl,"/"))
GetbaseUrl = baseUrl
End Function
'*************************************
'分段静态的判断 by evio
'*************************************
Function PartStatus(StartID,EndID)
Dim RI, ReArtList
ReArtList = ""
For RI = 0 to (int(EndID) - int(StartID))
if not isEmpty(Application(CookieName&"_introCache"&(int(StartID)+RI))) then
ReArtList = ReArtList&(int(StartID)+RI)&"|"
else
if FileExist("Cache/"&int(StartID)+RI&".asp") then
ReArtList = ReArtList&(int(StartID)+RI)&"|"
end if
end if
Next
ReArtList = ReArtList&"end"
PartStatus = ReArtList
End Function
'*************************************
'自定义读取缓存路径 by evio
'*************************************
function caload(id)
if not isEmpty(Application(CookieName&"_articleUrl_"&id)) then
caload = Application(CookieName&"_articleUrl_"&id)
exit function
end if
caload = ""
dim rex, strrexs, strrex, conrex, istr, jstr, sestr, recname, recpart, rechtml, loadtype, cacheStream,pid,ppid
Dim LoadList, cacheList
if not isEmpty(Application(CookieName&"_listCache")) then
cacheList = Application(CookieName&"_listCache")
else
LoadList = LoadFromFile("cache/listCache.asp")
If LoadList(0) = 0 Then
Application.Lock
Application(CookieName&"_listCache") = LoadList(1)
Application.UnLock
cacheList = LoadList(1)
End If
end if
If stat_Admin Or stat_ShowHiddenCate Then
loadtype = "A"
Else
loadtype = "G"
End if
set rex = New RegExp
rex.IgnoreCase = True
rex.Global = True
rex.Pattern = "\[""([^\r]*?)"";([^\r]*?);\(([^\r]*?)\)\]"
set strrex = rex.Execute(cacheList)
for each strrexs in strrex
if loadtype = strrexs.SubMatches(0) then
conrex = split(strrexs.SubMatches(2),",")
for jstr = 0 to ubound(conrex)
pid = split(conrex(jstr),"|")
ppid = pid(1)
if int(ppid)=int(id) then
recpart = pid(2)
if recpart = "" or recpart = empty or recpart = null or len(recpart) = 0 then
recpart = "article/"
else
recpart = "article/"&recpart&"/"
end if
recname = pid(3)
if recname = "" or recname = empty or recname = null or len(recname)=0 then
recname = id
else
recname = recname
end if
rechtml = pid(4)
if rechtml = "0" then
rechtml = "htm"
else
rechtml = "html"
end if
caload = caload&recpart&recname&"."&rechtml
end if
next
end if
next
Application.Lock
Application(CookieName&"_articleUrl_"&id) = caload
Application.UnLock
set rex = nothing
end function
'*************************************
'判断是否存在文件 by evio
'*************************************
Function FileExist(FilePath)
FileExist = False
Dim FSO
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
FilePath = Server.MapPath(FilePath)
If FSO.FileExists(FilePath) Then FileExist = True
End Function
'*************************************
'创建文件夹 by evio
'*************************************
sub createfolder(catename)
dim catefso,blogcatepath,blogcatetestpath
set catefso = server.CreateObject("scripting.filesystemobject")
blogcatepath = catename
blogcatetestpath=server.MapPath(".\"&blogcatepath&"")
if catefso.FolderExists(blogcatetestpath) Then
else
catefso.createfolder(blogcatetestpath)
end if
set catefso=nothing
end sub
'*************************************
'自定义路径 by evio
'*************************************
Function Alias(id)
dim cname,ccate,chtml,ccateID,ccateExec,cnames,ctype,cc
set cc=conn.execute("select top 1 log_CateID,log_cname,log_ctype from blog_Content where log_ID="&id)
ccateID = cc(0)
cname = cc(1)
ctype = cc(2)
set ccateExec=conn.execute("select Cate_Part from blog_Category where cate_ID="&ccateID)
If not ccateExec.EOF and not ccateExec.bof Then
ccate = ccateExec(0).value
end if
if ccate="" or ccate=empty or ccate=null or len(ccate)=0 then
ccate="article/"
else
ccate="article/"&ccate&"/"
end if
if len(cname)<1 or cname="" or cname=empty or cname=null then
cnames=trim(id)
else
cnames=cname
end if
if ctype="0" then
chtml="htm"
else
chtml="html"
end if
chtml="."&chtml
set ccateExec = nothing
set cc = nothing
Alias=ccate&cnames&chtml
End Function
'*************************************
'防止外部提交
'*************************************
Function ChkPost()
Dim server_v1, server_v2
chkpost = False
server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
if instr(server_v1, replace(replace(server_v2, "http://", ""), "www.", ""))=0 then
' If Mid(server_v1,8,Len(server_v2))<>server_v2 then
chkpost = False
Else
chkpost = True
End If
End Function
'*************************************
'IP过滤
'*************************************
Function MatchIP(IP)
MatchIP = False
Dim SIp, SplitIP
For Each SIp in FilterIP
SIp = Replace(SIp, "*", "\d*")
SplitIP = Split(SIp, ".")
Dim re, strMatchs, strIP
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "("&SplitIP(0)&"|)."&"("&SplitIP(1)&"|)."&"("&SplitIP(2)&"|)."&"("&SplitIP(3)&"|)"
Set strMatchs = re.Execute(IP)
strIP = strMatchs(0).SubMatches(0) & "." & strMatchs(0).SubMatches(1)& "." & strMatchs(0).SubMatches(2)& "." & strMatchs(0).SubMatches(3)
If strIP = IP Then
MatchIP = True
Exit Function
End If
Set strMatchs = Nothing
Set re = Nothing
Next
End Function
'*************************************
'获得注册码
'*************************************
Function getcode()
getcode = "![]()
"
End Function
'*************************************
'限制上传文件类型
'*************************************
Function IsvalidFile(File_Type)
IsvalidFile = False
Dim GName
For Each GName in UP_FileType
If File_Type = GName Then
IsvalidFile = True
Exit For
End If
Next
End Function
'*************************************
'限制插件名称
'*************************************
Function IsvalidPlugins(Plugins_Name)
Dim NoAllowNames, NoAllowName
NoAllowNames = "user,bloginfo,calendar,comment,search,links,archive,category,contentlist"
NoAllowName = Split(NoAllowNames, ",")
IsvalidPlugins = True
Dim GName
Plugins_Name = Trim(LCase(Plugins_Name))
For Each GName in NoAllowName
If Plugins_Name = GName Then
IsvalidPlugins = False
Exit For
End If
Next
End Function
'*************************************
'检测是否只包含英文和数字
'*************************************
Function IsValidChars(Str)
Dim re, chkstr
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "[^_\.a-zA-Z\d]"
IsValidChars = True
chkstr = re.Replace(Str, "")
If chkstr<>Str Then IsValidChars = False
Set re = Nothing
End Function
'*************************************
'检测是否只包含英文和数字
'*************************************
Function IsvalidValue(ArrayN, Str)
IsvalidValue = False
Dim GName
For Each GName in ArrayN
If Str = GName Then
IsvalidValue = True
Exit For
End If
Next
End Function
'*************************************
'检测是否有效的数字
'*************************************
Function IsInteger(Para)
IsInteger = False
If Not (IsNull(Para) Or Trim(Para) = "" Or Not IsNumeric(Para)) Then
IsInteger = True
End If
End Function
'*************************************
'用户名检测
'*************************************
Function IsValidUserName(byVal UserName)
Dim i, c
Dim VUserName
IsValidUserName = True
For i = 1 To Len(UserName)
c = LCase(Mid(UserName, i, 1))
If InStr("$!<>?#^%@~`&*();:+='"" ", c) > 0 Then
IsValidUserName = False
Exit Function
End If
Next
For Each VUserName in Register_UserName
If UserName = VUserName Then
IsValidUserName = False
Exit For
End If
Next
End Function
'*************************************
'检测是否有效的E-mail地址
'*************************************
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
'*************************************
'加亮关键字
'*************************************
Function highlight(byVal strContent, byRef arrayWords)
Dim intCounter, strTemp, intPos, intTagLength, intKeyWordLength, bUpdate
If Len(arrayWords)<1 Then
highlight = strContent
Exit Function
End If
For intPos = 1 To Len(strContent)
bUpdate = False
If Mid(strContent, intPos, 1) = "<" Then
On Error Resume Next
intTagLength = (InStr(intPos, strContent, ">", 1) - intPos)
If Err Then
highlight = strContent
Err.Clear
End If
strTemp = strTemp & Mid(strContent, intPos, intTagLength)
intPos = intPos + intTagLength
End If
If arrayWords <> "" Then
intKeyWordLength = Len(arrayWords)
If LCase(Mid(strContent, intPos, intKeyWordLength)) = LCase(arrayWords) Then
strTemp = strTemp & "" & Mid(strContent, intPos, intKeyWordLength) & ""
intPos = intPos + intKeyWordLength - 1
bUpdate = True
End If
End If
If bUpdate = False Then
strTemp = strTemp & Mid(strContent, intPos, 1)
End If
Next
highlight = strTemp
End Function
'*************************************
'过滤超链接
'*************************************
Function checkURL(ByVal ChkStr)
Dim Str
Str = ChkStr
Str = Trim(Str)
If IsNull(Str) Then
checkURL = ""
Exit Function
End If
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(d)(ocument\.cookie)"
Str = re.Replace(Str, "$1ocument cookie")
re.Pattern = "(d)(ocument\.write)"
Str = re.Replace(Str, "$1ocument write")
re.Pattern = "(s)(cript:)"
Str = re.Replace(Str, "$1cript ")
re.Pattern = "(s)(cript)"
Str = re.Replace(Str, "$1cript")
re.Pattern = "(o)(bject)"
Str = re.Replace(Str, "$1bject")
re.Pattern = "(a)(pplet)"
Str = re.Replace(Str, "$1pplet")
re.Pattern = "(e)(mbed)"
Str = re.Replace(Str, "$1mbed")
Set re = Nothing
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
checkURL = Str
End Function
'*************************************
'过滤文件名字
'*************************************
Function FixName(UpFileExt)
If IsEmpty(UpFileExt) Then Exit Function
FixName = UCase(UpFileExt)
FixName = Replace(FixName, Chr(0), "")
FixName = Replace(FixName, ".", "")
FixName = Replace(FixName, "ASP", "")
FixName = Replace(FixName, "ASA", "")
FixName = Replace(FixName, "ASPX", "")
FixName = Replace(FixName, "CER", "")
FixName = Replace(FixName, "CDX", "")
FixName = Replace(FixName, "HTR", "")
End Function
'*************************************
'过滤特殊字符
'*************************************
Function CheckStr(byVal ChkStr)
Dim Str
Str = ChkStr
If IsNull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str, "&", "&")
Str = Replace(Str, "'", "'")
Str = Replace(Str, """", """)
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(w)(here)"
Str = re.Replace(Str, "$1here")
re.Pattern = "(s)(elect)"
Str = re.Replace(Str, "$1elect")
re.Pattern = "(i)(nsert)"
Str = re.Replace(Str, "$1nsert")
re.Pattern = "(c)(reate)"
Str = re.Replace(Str, "$1reate")
re.Pattern = "(d)(rop)"
Str = re.Replace(Str, "$1rop")
re.Pattern = "(a)(lter)"
Str = re.Replace(Str, "$1lter")
re.Pattern = "(d)(elete)"
Str = re.Replace(Str, "$1elete")
re.Pattern = "(u)(pdate)"
Str = re.Replace(Str, "$1pdate")
re.Pattern = "(\s)(or)"
Str = re.Replace(Str, "$1or")
Set re = Nothing
CheckStr = Str
End Function
'*************************************
'恢复特殊字符
'*************************************
Function UnCheckStr(ByVal Str)
If IsNull(Str) Then
UnCheckStr = ""
Exit Function
End If
Str = Replace(Str, "'", "'")
Str = Replace(Str, """, """")
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(w)(here)"
Str = re.Replace(Str, "$1here")
re.Pattern = "(s)(elect)"
Str = re.Replace(Str, "$1elect")
re.Pattern = "(i)(nsert)"
Str = re.Replace(Str, "$1nsert")
re.Pattern = "(c)(reate)"
Str = re.Replace(Str, "$1reate")
re.Pattern = "(d)(rop)"
Str = re.Replace(Str, "$1rop")
re.Pattern = "(a)(lter)"
Str = re.Replace(Str, "$1lter")
re.Pattern = "(d)(elete)"
Str = re.Replace(Str, "$1elete")
re.Pattern = "(u)(pdate)"
Str = re.Replace(Str, "$1pdate")
re.Pattern = "(\s)(or)"
Str = re.Replace(Str, "$1or")
Set re = Nothing
Str = Replace(Str, "&", "&")
UnCheckStr = Str
End Function
'*************************************
'转换HTML代码
'*************************************
Function HTMLEncode(ByVal reString)
Dim Str
Str = reString
If Not IsNull(Str) Then
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
Str = Replace(Str, Chr(9), " ")
Str = Replace(Str, Chr(32)&Chr(32), " ")
Str = Replace(Str, Chr(39), "'")
Str = Replace(Str, Chr(34), """)
Str = Replace(Str, Chr(13), "")
Str = Replace(Str, Chr(10), "
")
HTMLEncode = Str
End If
End Function
'*************************************
'转换最新评论和日志HTML代码
'*************************************
Function CCEncode(ByVal reString)
Dim Str
Str = reString
If Not IsNull(Str) Then
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
Str = Replace(Str, Chr(9), " ")
Str = Replace(Str, Chr(32)&Chr(32), " ")
Str = Replace(Str, Chr(39), "'")
Str = Replace(Str, Chr(34), """)
Str = Replace(Str, Chr(13), "")
Str = Replace(Str, Chr(10), " ")
CCEncode = Str
End If
End Function
'*************************************
'反转换HTML代码
'*************************************
Function HTMLDecode(ByVal reString)
Dim Str
Str = reString
If Not IsNull(Str) Then
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
Str = Replace(Str, " ", Chr(9))
Str = Replace(Str, " ", Chr(32)&Chr(32))
Str = Replace(Str, "'", Chr(39))
Str = Replace(Str, """, Chr(34))
Str = Replace(Str, "", Chr(13))
Str = Replace(Str, "
", Chr(10))
HTMLDecode = Str
End If
End Function
'*************************************
'恢复&字符
'*************************************
Function ClearHTML(ByVal reString)
Dim Str
Str = reString
If Not IsNull(Str) Then
Str = Replace(Str, "&", "&")
ClearHTML = Str
End If
End Function
'*************************************
'过滤textarea
'*************************************
Function UBBFilter(ByVal reString)
Dim Str
Str = reString
If Not IsNull(Str) Then
Str = Replace(Str, "", "</textarea>")
UBBFilter = Str
End If
End Function
'*************************************
'过滤HTML代码
'*************************************
Function EditDeHTML(byVal Content)
EditDeHTML = Content
If Not IsNull(EditDeHTML) Then
EditDeHTML = UnCheckStr(EditDeHTML)
EditDeHTML = Replace(EditDeHTML, "&", "&")
EditDeHTML = Replace(EditDeHTML, "<", "<")
EditDeHTML = Replace(EditDeHTML, ">", ">")
EditDeHTML = Replace(EditDeHTML, Chr(34), """)
EditDeHTML = Replace(EditDeHTML, Chr(39), "'")
End If
End Function
'*************************************
'日期转换函数
'*************************************
Function DateToStr(DateTime, ShowType)
Dim DateMonth, DateDay, DateHour, DateMinute, DateWeek, DateSecond
Dim FullWeekday, shortWeekday, Fullmonth, Shortmonth, TimeZone1, TimeZone2
TimeZone1 = "+0800"
TimeZone2 = "+08:00"
FullWeekday = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
shortWeekday = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
Fullmonth = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
Shortmonth = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
DateMonth = Month(DateTime)
DateDay = Day(DateTime)
DateHour = Hour(DateTime)
DateMinute = Minute(DateTime)
DateWeek = Weekday(DateTime)
DateSecond = Second(DateTime)
If Len(DateMonth)<2 Then DateMonth = "0"&DateMonth
If Len(DateDay)<2 Then DateDay = "0"&DateDay
If Len(DateMinute)<2 Then DateMinute = "0"&DateMinute
Select Case ShowType
Case "Y-m-d"
DateToStr = Year(DateTime)&"-"&DateMonth&"-"&DateDay
Case "Y-m-d H:I A"
Dim DateAMPM
If DateHour>12 Then
DateHour = DateHour -12
DateAMPM = "PM"
Else
DateHour = DateHour
DateAMPM = "AM"
End If
If Len(DateHour)<2 Then DateHour = "0"&DateHour
DateToStr = Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
Case "Y-m-d H:I:S"
If Len(DateHour)<2 Then DateHour = "0"&DateHour
If Len(DateSecond)<2 Then DateSecond = "0"&DateSecond
DateToStr = Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
Case "YmdHIS"
DateSecond = Second(DateTime)
If Len(DateHour)<2 Then DateHour = "0"&DateHour
If Len(DateSecond)<2 Then DateSecond = "0"&DateSecond
DateToStr = Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond
Case "ym"
DateToStr = Right(Year(DateTime), 2)&DateMonth
Case "d"
DateToStr = DateDay
Case "ymd"
DateToStr = Right(Year(DateTime), 4)&DateMonth&DateDay
Case "mdy"
Dim DayEnd
Select Case DateDay
Case 1
DayEnd = "st"
Case 2
DayEnd = "nd"
Case 3
DayEnd = "rd"
Case Else
DayEnd = "th"
End Select
DateToStr = Fullmonth(DateMonth -1)&" "&DateDay&DayEnd&" "&Right(Year(DateTime), 4)
Case "w,d m y H:I:S"
DateSecond = Second(DateTime)
If Len(DateHour)<2 Then DateHour = "0"&DateHour
If Len(DateSecond)<2 Then DateSecond = "0"&DateSecond
DateToStr = shortWeekday(DateWeek -1)&","&DateDay&" "& Left(Fullmonth(DateMonth -1), 3) &" "&Right(Year(DateTime), 4)&" "&DateHour&":"&DateMinute&":"&DateSecond&" "&TimeZone1
Case "y-m-dTH:I:S"
If Len(DateHour)<2 Then DateHour = "0"&DateHour
If Len(DateSecond)<2 Then DateSecond = "0"&DateSecond
DateToStr = Year(DateTime)&"-"&DateMonth&"-"&DateDay&"T"&DateHour&":"&DateMinute&":"&DateSecond&TimeZone2
Case Else
If Len(DateHour)<2 Then DateHour = "0"&DateHour
DateToStr = Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
End Select
End Function
'*************************************
'分页函数
'*************************************
Dim FirstShortCut, ShortCut
FirstShortCut = False
'*************************************
'切割内容 - 按行分割
'*************************************
Function SplitLines(byVal Content, byVal ContentNums)
Dim ts, i, l
ContentNums = Int(ContentNums)
If IsNull(Content) Then Exit Function
i = 1
ts = 0
For i = 1 To Len(Content)
l = LCase(Mid(Content, i, 5))
If l = "
" Then
ts = ts + 1
End If
l = LCase(Mid(Content, i, 4))
If l = "
" Then
ts = ts + 1
End If
l = LCase(Mid(Content, i, 3))
If l = "" Then
ts = ts + 1
End If
If ts>ContentNums Then Exit For
Next
If ts>ContentNums Then
Content = Left(Content, i -1)
End If
SplitLines = Content
End Function
'*************************************
'切割内容 - 按字符分割
'*************************************
Function CutStr(byVal Str, byVal StrLen)
Dim l, t, c, i
If IsNull(Str) Then
CutStr = ""
Exit Function
End If
l = Len(Str)
StrLen = Int(StrLen)
t = 0
For i = 1 To l
c = Asc(Mid(Str, i, 1))
If c<0 Or c>255 Then t = t + 2 Else t = t + 1
If t>= StrLen Then
CutStr = Left(Str, i)&"..."
Exit For
Else
CutStr = Str
End If
Next
End Function
'*************************************
'Trackback Function
'*************************************
Function Trackback(trackback_url, url, title, excerpt, blog_name)
Dim query_string, objXMLHTTP
query_string = "title="&cutStr(Server.URLEncode(title), 100)&"&url="&Server.URLEncode(url)&"&blog_name="&Server.URLEncode(blog_name)&"&excerpt="&cutStr(Server.URLEncode(excerpt), 252)
Set objXMLHTTP = Server.CreateObject(getXMLHTTP())
objXMLHTTP.Open "POST", trackback_url, False
objXMLHTTP.setRequestHeader "Content-Type", "application/x-www-Form-urlencoded"
'HAndling timeout
On Error Resume Next
objXMLHTTP.Send query_string
Err.Clear
Set objXMLHTTP = Nothing
End Function
'*************************************
'删除引用标签
'*************************************
Function DelQuote(strContent)
If IsNull(strContent) Then Exit Function
Dim re, iarray, i
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
iarray = Array("quote","reply", "img", "swf|wma|wmv|rm|ra|qt", "mid", "url", "ed2k", "email", "align", "color", "size", "font", "b", "i", "u", "s", "sup", "sub", "fly", "down", "mDown", "cc", "code", "hidden", "html")
for i = 0 to UBound(iarray)
re.Pattern = "\[quote\](.[^\]]*?)\[\/quote\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[quote=(.[^\]]*)\](.[^\]]*?)\[\/quote\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[reply=(.[^\]]*),(.[^\]]*)\](.*?)\[\/reply\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[reply=(.[^\]]*)\](.[^\]]*?)\[\/reply\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\["&iarray(i)&"\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\["&iarray(i)&"=(.[^\]]*)\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[\/"&iarray(i)&"\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[\/"&iarray(i)&"=(.[^\]]*)\]"
strContent = re.Replace(strContent, "")
next
Dim log_Smilies, log_SmiliesContent
For Each log_Smilies IN Arr_Smilies
log_SmiliesContent = Split(log_Smilies, "|")
strContent = Replace(strContent, log_SmiliesContent(2), "")
Next
Set re = Nothing
DelQuote = strContent
End Function
'*************************************
'获取客户端IP
'*************************************
Function getIP()
Dim strIP, IP_Ary, strIP_list
strIP_list = Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "'", "")
If InStr(strIP_list, ",")<>0 Then
IP_Ary = Split(strIP_list, ",")
strIP = IP_Ary(0)
Else
strIP = strIP_list
End If
If strIP = Empty Then strIP = Replace(Request.ServerVariables("REMOTE_ADDR"), "'", "")
getIP = strIP
End Function
'*************************************
'获取客户端浏览器信息
'*************************************
Function getBrowser(strUA)
Dim arrInfo, strType, temp1, temp2
strType = ""
strUA = LCase(strUA)
arrInfo = Array("Unkown", "Unkown")
'浏览器判断
If InStr(strUA, "mozilla")>0 Then arrInfo(0) = "Mozilla"
If InStr(strUA, "icab")>0 Then arrInfo(0) = "iCab"
If InStr(strUA, "lynx")>0 Then arrInfo(0) = "Lynx"
If InStr(strUA, "links")>0 Then arrInfo(0) = "Links"
If InStr(strUA, "elinks")>0 Then arrInfo(0) = "ELinks"
If InStr(strUA, "jbrowser")>0 Then arrInfo(0) = "JBrowser"
If InStr(strUA, "konqueror")>0 Then arrInfo(0) = "konqueror"
If InStr(strUA, "wget")>0 Then arrInfo(0) = "wget"
If InStr(strUA, "ask jeeves")>0 Or InStr(strUA, "teoma")>0 Then arrInfo(0) = "Ask Jeeves/Teoma"
If InStr(strUA, "wget")>0 Then arrInfo(0) = "wget"
If InStr(strUA, "opera")>0 Then arrInfo(0) = "opera"
If InStr(strUA, "gecko")>0 Then
strType = "[Gecko]"
arrInfo(0) = "Mozilla"
If InStr(strUA, "aol")>0 Then arrInfo(0) = "AOL"
If InStr(strUA, "netscape")>0 Then arrInfo(0) = "Netscape"
If InStr(strUA, "firefox")>0 Then arrInfo(0) = "FireFox"
If InStr(strUA, "chimera")>0 Then arrInfo(0) = "Chimera"
If InStr(strUA, "camino")>0 Then arrInfo(0) = "Camino"
If InStr(strUA, "galeon")>0 Then arrInfo(0) = "Galeon"
If InStr(strUA, "k-meleon")>0 Then arrInfo(0) = "K-Meleon"
arrInfo(0) = arrInfo(0) + strType
End If
If InStr(strUA, "bot")>0 Or InStr(strUA, "crawl")>0 Then
strType = "[Bot/Crawler]"
arrInfo(0) = ""
If InStr(strUA, "grub")>0 Then arrInfo(0) = "Grub"
If InStr(strUA, "googlebot")>0 Then arrInfo(0) = "GoogleBot"
If InStr(strUA, "msnbot")>0 Then arrInfo(0) = "MSN Bot"
If InStr(strUA, "slurp")>0 Then arrInfo(0) = "Yahoo! Slurp"
arrInfo(0) = arrInfo(0) + strType
End If
If InStr(strUA, "applewebkit")>0 Then
strType = "[AppleWebKit]"
arrInfo(0) = ""
If InStr(strUA, "omniweb")>0 Then arrInfo(0) = "OmniWeb"
If InStr(strUA, "safari")>0 Then arrInfo(0) = "Safari"
arrInfo(0) = arrInfo(0) + strType
End If
If InStr(strUA, "msie")>0 Then
strType = "[MSIE"
temp1 = Mid(strUA, (InStr(strUA, "msie") + 4), 6)
temp2 = InStr(temp1, ";")
temp1 = Left(temp1, temp2 -1)
strType = strType & temp1 &"]"
arrInfo(0) = "Internet Explorer"
If InStr(strUA, "msn")>0 Then arrInfo(0) = "MSN"
If InStr(strUA, "aol")>0 Then arrInfo(0) = "AOL"
If InStr(strUA, "webtv")>0 Then arrInfo(0) = "WebTV"
If InStr(strUA, "myie2")>0 Then arrInfo(0) = "MyIE2"
If InStr(strUA, "maxthon")>0 Then arrInfo(0) = "Maxthon"
If InStr(strUA, "gosurf")>0 Then arrInfo(0) = "GoSurf"
If InStr(strUA, "netcaptor")>0 Then arrInfo(0) = "NetCaptor"
If InStr(strUA, "sleipnir")>0 Then arrInfo(0) = "Sleipnir"
If InStr(strUA, "avant browser")>0 Then arrInfo(0) = "AvantBrowser"
If InStr(strUA, "greenbrowser")>0 Then arrInfo(0) = "GreenBrowser"
If InStr(strUA, "slimbrowser")>0 Then arrInfo(0) = "SlimBrowser"
arrInfo(0) = arrInfo(0) + strType
End If
'操作系统判断
If InStr(strUA, "windows")>0 Then arrInfo(1) = "Windows"
If InStr(strUA, "windows ce")>0 Then arrInfo(1) = "Windows CE"
If InStr(strUA, "windows 95")>0 Then arrInfo(1) = "Windows 95"
If InStr(strUA, "win98")>0 Then arrInfo(1) = "Windows 98"
If InStr(strUA, "windows 98")>0 Then arrInfo(1) = "Windows 98"
If InStr(strUA, "windows 2000")>0 Then arrInfo(1) = "Windows 2000"
If InStr(strUA, "windows xp")>0 Then arrInfo(1) = "Windows XP"
If InStr(strUA, "windows nt")>0 Then
arrInfo(1) = "Windows NT"
If InStr(strUA, "windows nt 5.0")>0 Then arrInfo(1) = "Windows 2000"
If InStr(strUA, "windows nt 5.1")>0 Then arrInfo(1) = "Windows XP"
If InStr(strUA, "windows nt 5.2")>0 Then arrInfo(1) = "Windows 2003"
End If
If InStr(strUA, "x11")>0 Or InStr(strUA, "unix")>0 Then arrInfo(1) = "Unix"
If InStr(strUA, "sunos")>0 Or InStr(strUA, "sun os")>0 Then arrInfo(1) = "SUN OS"
If InStr(strUA, "powerpc")>0 Or InStr(strUA, "ppc")>0 Then arrInfo(1) = "PowerPC"
If InStr(strUA, "macintosh")>0 Then arrInfo(1) = "Mac"
If InStr(strUA, "mac osx")>0 Then arrInfo(1) = "MacOSX"
If InStr(strUA, "freebsd")>0 Then arrInfo(1) = "FreeBSD"
If InStr(strUA, "linux")>0 Then arrInfo(1) = "Linux"
If InStr(strUA, "palmsource")>0 Or InStr(strUA, "palmos")>0 Then arrInfo(1) = "PalmOS"
If InStr(strUA, "wap ")>0 Then arrInfo(1) = "WAP"
'arrInfo(0)=strUA
getBrowser = arrInfo
End Function
'*************************************
'计算随机数
'*************************************
Function randomStr(intLength)
Dim strSeed, seedLength, pos, Str, i
strSeed = "abcdefghijklmnopqrstuvwxyz1234567890"
seedLength = Len(strSeed)
Str = ""
Randomize
For i = 1 To intLength
Str = Str + Mid(strSeed, Int(seedLength * Rnd) + 1, 1)
Next
randomStr = Str
End Function
'*************************************
'自动闭合UBB
'*************************************
Function closeUBB(strContent)
Dim arrTags, i, OpenPos, ClosePos, re, strMatchs, j, Match
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
arrTags = Array("code", "quote", "list", "color", "align", "font", "size", "b", "i", "u", "s", "html")
For i = 0 To UBound(arrTags)
OpenPos = 0
ClosePos = 0
re.Pattern = "\[" + arrTags(i) + "(=[^\[\]]+|)\]"
Set strMatchs = re.Execute(strContent)
For Each Match in strMatchs
OpenPos = OpenPos + 1
Next
re.Pattern = "\[/" + arrTags(i) + "\]"
Set strMatchs = re.Execute(strContent)
For Each Match in strMatchs
ClosePos = ClosePos + 1
Next
For j = 1 To OpenPos - ClosePos
strContent = strContent + "[/" + arrTags(i) + "]"
Next
Next
closeUBB = strContent
End Function
'*************************************
'自动闭合HTML
'*************************************
Function closeHTML(strContent)
Dim arrTags, i, OpenPos, ClosePos, re, strMatchs, j, Match
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
arrTags = Array("p", "div", "span", "table", "ul", "font", "b", "u", "i", "h1", "h2", "h3", "h4", "h5", "h6")
For i = 0 To UBound(arrTags)
OpenPos = 0
ClosePos = 0
re.Pattern = "\<" + arrTags(i) + "( [^\<\>]+|)\>"
Set strMatchs = re.Execute(strContent)
For Each Match in strMatchs
OpenPos = OpenPos + 1
Next
re.Pattern = "\"
Set strMatchs = re.Execute(strContent)
For Each Match in strMatchs
ClosePos = ClosePos + 1
Next
For j = 1 To OpenPos - ClosePos
strContent = strContent + ""
Next
Next
closeHTML = strContent
End Function
'*************************************
'读取文件
'*************************************
Function LoadFromFile(ByVal File)
Dim objStream
Dim RText
RText = Array(0, "")
Set objStream = Server.CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
.Charset = "utf-8"
.Position = objStream.Size
On Error Resume Next
.LoadFromFile Server.MapPath(File)
If Err Then
RText = Array(Err.Number, Err.Description)
LoadFromFile = RText
Err.Clear
Exit Function
End If
RText = Array(0, .ReadText)
.Close
End With
LoadFromFile = RText
Set objStream = Nothing
End Function
'*************************************
'保存文件
'*************************************
Function SaveToFile(ByVal strBody, ByVal File)
Dim objStream
Dim RText
RText = Array(0, "")
Set objStream = Server.CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Open
.Charset = "utf-8"
.Position = objStream.Size
.WriteText = strBody
On Error Resume Next
.SaveToFile Server.MapPath(File), 2
If Err Then
RText = Array(Err.Number, Err.Description)
SaveToFile = RText
Err.Clear
Exit Function
End If
.Close
End With
RText = Array(0, "保存文件成功!")
SaveToFile = RText
Set objStream = Nothing
End Function
'*************************************
'数据库添加修改操作
'*************************************
Function DBQuest(table, DBArray, Action)
Dim AddCount, TempDB, i, v
If Action<>"insert" Or Action<>"update" Then Action = "insert"
If Action = "insert" Then v = 2 Else v = 3
If Not IsArray(DBArray) Then
DBQuest = -1
Exit Function
Else
Set TempDB = Server.CreateObject("ADODB.RecordSet")
On Error Resume Next
TempDB.Open table, Conn, 1, v
If Err Then
DBQuest = -2
Exit Function
End If
If Action = "insert" Then TempDB.addNew
AddCount = UBound(DBArray, 1)
For i = 0 To AddCount
TempDB(DBArray(i)(0)) = DBArray(i)(1)
Next
TempDB.update
TempDB.Close
Set TempDB = Nothing
DBQuest = 0
End If
End Function
'*************************************
'显示帮助信息
'*************************************
Sub showmsg(title, des, icon, showType)
session(CookieName&"_ShowMsg") = True
session(CookieName&"_title") = title
session(CookieName&"_des") = des
session(CookieName&"_icon") = icon
'icon 类型
'MessageIcon
'ErrorIcon
'WarningIcon
'QuestionIcon
If showType = "plugins" Then
RedirectUrl("../../showmsg.asp")
Else
RedirectUrl("showmsg.asp")
End If
End Sub
'*************************************
'垃圾关键字过滤
'*************************************
Function filterSpam(Str, Path)
filterSpam = False
Dim spamXml, spamItem
Set spamXml = Server.CreateObject(getXMLDOM())
spamXml.async = False
spamXml.load(Server.MapPath(Path))
If spamXml.parseerror.errorcode = 0 Then
For Each spamItem in spamXml.selectNodes("//key")
If InStr(LCase(Str), LCase(spamItem.text))<>0 Then
filterSpam = True
Exit Function
End If
Next
End If
Set spamXml = Nothing
End Function
Function regFilterSpam(Str, Path)
regFilterSpam = False
Dim spamXml, spamItem, r
Set spamXml = Server.CreateObject(getXMLDOM())
spamXml.async = False
spamXml.load(Server.MapPath(Path))
If spamXml.parseerror.errorcode = 0 Then
For Each spamItem in spamXml.selectNodes("//key")
'r = rgExec(Str, spamItem.getAttribute("re"), spamItem.getAttribute("times"))
r = rgExec(str,replace(spamItem.getAttribute("re"),"\\","\"),spamItem.getAttribute("times"))
If r>0 Then
regFilterSpam = True
Exit Function
End If
Next
End If
Set spamXml = Nothing
End Function
Function getServerKey
Dim serverTime, diffDay
If Len(Application(CookieName&"_server_Time"))>0 Then '判断是否要更新serverKey
serverTime = Application(CookieName&"_server_Time")
diffDay = DateDiff("h", Now, serverTime)
If diffDay > 0 Or diffDay<0 Then updateServerKey '每个1个小时更新一次 serverKey
Else
updateServerKey
End If
Dim exc
exc = Split(Application(CookieName&"_server_excursion"), "|")
Dim sKey
sKey = exc(0) & Request.ServerVariables("INSTANCE_META_PATH") & Request.ServerVariables("APPL_PHYSICAL_PATH") & Request.ServerVariables("SERVER_SOFTWARE")
getServerKey = Mid(sha1(sKey), exc(1) + 1, 10)
End Function
Function updateServerKey
Randomize
Application.Lock
Application(CookieName&"_server_Time") = Now
Application(CookieName&"_server_excursion") = Int(Rnd * 10000000) & "|" & Int(Rnd * 26)
Application.UnLock
End Function
Function getTempKey
getTempKey = randomStr(20)
session(CookieName&"tempKey") = getTempKey
End Function
'*************************************
'水印函数
'*************************************
Sub CreateView(imgName,mode,UpLoadSet)
'imgName:图片地址，mode：水印样式，UpLoadSet：水印参数
'UpLoadSet = "0|0|0|PJBlog|PJBlog|0|1|10|10|FFFFFF|0|10|10|0.5|images/wind.png|120|35|www.pjhome.net|FFFFFF|18|宋体|1|0|000000|0|0"
'防盗链|文件命名|文件命名2|前缀|后缀|水印位置|计数边距|离左边距|离顶边距|边框颜色|边框宽度|水平边距|垂直边距|透明度|图片水印|图宽|图高|文字|字体颜色|字体大小|字体类型|加粗|斜体|阴影颜色|阴影向右偏移量|阴影向下偏移量
' 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
UpLoadSet = Split(UpLoadSet,"|")
If UBound(UpLoadSet) <> 25 then
UpLoadSet = "0|0|0|PJBlog|PJBlog|0|0|10|10|FFFFFF|0|10|10|0.5|images/wind.png|120|35|www.pjhome.net|000000|18|宋体|1|0|000000|0|0"
UpLoadSet = Split(UpLoadSet,"|")
End If
Dim nSYWZPosition, UpPlace, UpCalculate, UpSYX, UpSYY, UpSYPenColor, UpSYPenWidth, UpSYPaddingH, UpSYPaddingV, UpSYAlpha
Dim UpPicPath, UpPicWidth, UpPicHeight
Dim UpCharacter, UpFontColor, UpFontSize, UpFontFamily, UpFontBold, UpFontItalic
Dim UpFontShadowColor, UpFontShadowXOffset, UpFontShadowYOffset
UpPlace = UpLoadSet(5) '水印位置
UpCalculate = UpLoadSet(6) '计数边距
UpSYX = UpLoadSet(7) '离左边距
UpSYY = UpLoadSet(8) '离顶边距
UpSYPenColor = "&H"&UpLoadSet(9) '边框颜色
UpSYPenWidth = UpLoadSet(10) '边框宽度
UpSYPaddingH = UpLoadSet(11) '水平边距
UpSYPaddingV = UpLoadSet(12) '垂直边距
UpSYAlpha = UpLoadSet(13) '透明度
UpPicPath = UpLoadSet(14) '图片水印
UpPicWidth = UpLoadSet(15) '图宽
UpPicHeight = UpLoadSet(16) '图高
UpCharacter = UpLoadSet(17) '文字
UpFontColor = "&H"&UpLoadSet(18) '字体颜色
UpFontSize = UpLoadSet(19) '字体大小
UpFontFamily = UpLoadSet(20) '字体类型
UpFontBold = CBool(UpLoadSet(21)) '加粗
UpFontItalic = CBool(UpLoadSet(22)) '斜体
UpFontShadowColor = "&H"&UpLoadSet(23) '阴影颜色
UpFontShadowXOffset = UpLoadSet(24) '阴影向右偏移量
UpFontShadowYOffset = UpLoadSet(25) '阴影向下偏移量
On Error Resume Next
Dim Jpeg,Logobox,LogoPath
Set Jpeg = Server.CreateObject("Persits.Jpeg")
dim UpSYHx,UpSYVy,UpjpegX,UpjpegY,UpfontX,UpfontY
If UpCalculate = 1 then
UpSYHx = 0
UpSYVy = 0
Else
UpSYHx = UpSYPaddingH
UpSYVy = UpSYPaddingV
End IF
If mode = 2 Then '图片水印
LogoPath = Server.MapPath(UpPicPath)
Set Logobox = Server.CreateObject("Persits.Jpeg")
Logobox.Open LogoPath
Logobox.Width = UpPicWidth
Logobox.Height = Logobox.Width * Logobox.OriginalHeight / Logobox.OriginalWidth
Jpeg.Open Trim(Server.MapPath(imgName))
If Jpeg.OriginalWidth > Logobox.Width and Jpeg.OriginalHeight > Logobox.Height then
UpjpegX = Jpeg.OriginalWidth-Logobox.Width-UpSYHx
UpjpegY = Jpeg.OriginalHeight-Logobox.Height-UpSYVy
Select Case UpPlace
Case 0 '水印随机位置
randomize
nSYWZPosition = Int(rnd()*9+1)
UpSYX = getSYPosX(nSYWZPosition, Jpeg.OriginalWidth, Logobox.Width, UpSYPaddingH )
UpSYY = getSYPosY(nSYWZPosition, Jpeg.OriginalHeight, Logobox.Height, UpSYPaddingV )
Case 1 '水印顶部左侧
UpSYX = UpSYHx
UpSYY = UpSYVy
Case 2 '水印顶部居中
UpSYX = UpjpegX \ 2
UpSYY = UpSYVy
Case 3 '水印顶部右侧
UpSYX = UpjpegX
UpSYY = UpSYVy
Case 4 '水印中部左侧
UpSYX = UpSYHx
UpSYY = UpjpegY \ 2
Case 5 '水印中部居中
UpSYX = UpjpegX \ 2
UpSYY = UpjpegY \ 2
Case 6 '水印中部右侧
UpSYX = UpjpegX
UpSYY = UpjpegY \ 2
Case 7 '水印底部左侧
UpSYX = UpSYHx
UpSYY = UpjpegY
Case 8 '水印底部居中
UpSYX = UpjpegX \ 2
UpSYY = UpjpegY
Case 9 '水印底部右侧
UpSYX = UpjpegX
UpSYY = UpjpegY
Case Else '水印默认位置
UpSYX = UpSYX
UpSYY = UpSYY
End Select
If UpSYPenWidth > 0 then
Jpeg.Canvas.Pen.Color = UpSYPenColor
Jpeg.Canvas.Pen.Width = UpSYPenWidth
Jpeg.Canvas.Brush.Solid = False
Jpeg.Canvas.Bar 0, 0, Jpeg.Width, Jpeg.Height
End If
Jpeg.DrawImage UpSYX, UpSYY, Logobox, UpSYAlpha, UpSYPenColor
Jpeg.Save Server.MapPath(imgName)
Logobox.close : Set Logobox = Nothing
Jpeg.close : Set Jpeg = Nothing
End If
Else '文字水印
Jpeg.Open Server.MapPath(imgName)
Dim aa,MyJpeg,Logo,bb
aa = Jpeg.Binary
If Jpeg.OriginalWidth>(len(UpCharacter)*UpFontsize) and Jpeg.OriginalHeight>(1*UpFontsize) then
UpfontX = Jpeg.OriginalWidth-(bLen(UpCharacter)*UpFontsize)+UpFontShadowXOffset-UpSYHx
UpfontY = Jpeg.OriginalHeight-UpFontsize+UpFontShadowYOffset-UpSYVy
Select Case UpPlace
Case 10 '水印随机位置
randomize
nSYWZPosition = Int(rnd()*9+1)
UpSYX = getSYPosX(nSYWZPosition, Jpeg.OriginalWidth, (bLen(UpCharacter)*UpFontsize)+UpFontShadowXOffset, UpSYPaddingH )
UpSYY = getSYPosY(nSYWZPosition, Jpeg.OriginalHeight, UpFontsize+UpFontShadowYOffset, UpSYPaddingV )
Case 1 '水印顶部左侧
UpSYX = UpSYHx
UpSYY = UpSYVy
Case 2 '水印顶部居中
UpSYX = UpfontX \ 2
UpSYY = UpSYVy
Case 3 '水印顶部右侧
UpSYX = UpfontX
UpSYY = UpSYVy
Case 4 '水印中部左侧
UpSYX = UpSYHx
UpSYY = UpfontY \ 2
Case 5 '水印中部居中
UpSYX = UpfontX \ 2
UpSYY = UpfontY \ 2
Case 6 '水印中部右侧
UpSYX = UpfontX
UpSYY = UpfontY \ 2
Case 7 '水印底部左侧
UpSYX = UpSYHx
UpSYY = UpfontY
Case 8 '水印底部居中
UpSYX = UpfontX \ 2
UpSYY = UpfontY
Case 9 '水印底部右侧
UpSYX = UpfontX
UpSYY = UpfontY
Case Else '水印默认位置
UpSYX = UpSYX
UpSYY = UpSYY
End Select
Jpeg.Canvas.Font.Color = UpFontColor
Jpeg.Canvas.Font.Family = UpFontFamily
Jpeg.Canvas.Font.Size = UpFontSize
Jpeg.Canvas.Font.Bold = UpFontBold
Jpeg.Canvas.Font.Italic = UpFontItalic
Jpeg.Canvas.Font.Quality = 2
Jpeg.Canvas.Font.ShadowColor = UpFontShadowColor
Jpeg.Canvas.Font.ShadowXOffset = UpFontShadowXOffset
Jpeg.Canvas.Font.ShadowYOffset = UpFontShadowYOffset
Jpeg.Canvas.Print UpSYX, UpSYY, UpCharacter
Set MyJpeg = Server.CreateObject("Persits.Jpeg")
MyJpeg.OpenBinary aa
MyJpeg.DrawImage 0,0, Jpeg, UpSYAlpha
If UpSYPenWidth > 0 then
MyJpeg.Canvas.Pen.Color = UpSYPenColor
MyJpeg.Canvas.Pen.Width = UpSYPenWidth
MyJpeg.Canvas.Brush.Solid = False
MyJpeg.Canvas.Bar 0, 0, MyJpeg.Width, MyJpeg.Height
End If
MyJpeg.Save Server.MapPath(imgName)
Jpeg.close
Set aa = nothing
MyJpeg.Close
End If
End If
End Sub
'*************************************
'识别中英文字符，计算文字水印长度
'*************************************
Function bLen(str)
Dim strLen,charLen,ascChar,i
strLen = len(str)
charLen = 0
For i = 1 to strLen
ascChar = asc(mid(str,i,1))
If ascChar < 0 then ascChar = ascChar+65536
If ascChar > 255 then
charLen= charLen + 1.02
Else
charLen = charLen + 0.56
End If
Next
bLen = charLen
End Function
'*************************************
'计算随机水印水平坐标（随机位置，原图宽度，水印宽度，左右边距）
'*************************************
Function getSYPosX(posFlag, originalW, syW, paddingH)
Select Case posFlag
Case 1, 2, 3
getSYPosX = paddingH
Case 4, 5, 6
getSYPosX = (originalW - syW) \ 2
Case 7, 8, 9
getSYPosX = originalW - paddingH - syW
End Select
End Function
'*************************************
'计算随机水印垂直坐标（随机位置，原图高度，水印高度，上下边距）
'*************************************
Function getSYPosY(posFlag, originalH, syH, paddingV)
Select Case posFlag
Case 1, 4, 7
getSYPosY = paddingV
Case 2, 5, 8
getSYPosY = (originalH - syH) \ 2
Case 3, 6, 9
getSYPosY = originalH - paddingV - syH
End Select
End Function
'*************************************
'截取文件名
'*************************************
Function getF_Name(n)
getF_Name = mid(n,1,Cint(InstrRev(n,"."))-1)
End Function
'*************************************
'日期补0
'*************************************
Function lenNum(n)
IF len(n)=1 then
lenNum="0"&n
Else
lenNum=n
End If
End Function
%>
<%
'***************PJblog2 模块与类处理*******************
' PJblog2 Copyright 2005
' Update:2005-10-20
'**************************************************
'**********************************************
'BLOG日历
'**********************************************
Function Calendar(C_Year, C_Month, C_Day, update)
Dim C_YM, S_Date, E_Date, isDo, Dclass, RS_Month, Link_TF, i, DayCount, DayStr, NotCM, TS_Date, TE_Date
If C_Year = Empty Then C_Year = Year(Now())
If C_Month = Empty Then C_Month = Month(Now())
If C_Day = Empty Then C_Day = 0
C_Year = CInt(C_Year)
C_Month = CInt(C_Month)
C_Day = CInt(C_Day)
C_YM = C_Year & "-" & C_Month
Dim PY, PM, NY, NM
PM = C_Month -1
If PM<1 Then
PM = 12
PY = C_Year -1
Else
PY = C_Year
End If
NM = C_Month + 1
If NM>12 Then
NM = 1
NY = C_Year + 1
Else
NY = C_Year
End If
Calendar = "
"
Calendar = Calendar & "
"
'--->计算当前月份的日期
i = Weekday(C_YM & "-" & 1) -1
TS_Date = DateSerial(C_Year, C_Month, 1 - i)
TE_Date = DateAdd("d", 42, TS_Date)
S_Date = Year(TS_Date)&"-"&Month(TS_Date)&"-"&Day(TS_Date)
E_Date = Year(TE_Date)&"-"&Month(TE_Date)&"-"&Day(TE_Date)
'--->保存日志日历缓存
Dim Link_Count, Link_Days, CalendarArray, doUpdate, upTime
upTime = Year(Now())&"-"&Month(Now())
doUpdate = False
If Not IsArray(Application(CookieName&"_blog_Calendar")) Then '判断日期更新条件
doUpdate = True
ElseIf Application(CookieName&"_blog_Calendar")(1)<>upTime Then
doUpdate = True
ElseIf upTime<>C_Year&"-"&C_Month Then
doUpdate = True
ElseIf update = 2 Then
doUpdate = True
End If
If doUpdate Then
ReDim Link_Days(4, 0)
Link_Count = 0
SQL = "SELECT C.log_id,C.log_title,C.log_PostTime,C.log_IsShow FROM blog_Content as C,blog_Category as A where C.log_PostTime Between #"&S_Date&" 00:00:00# And #"&E_Date&" 23:59:59# and C.log_IsDraft=false and C.log_CateID=A.cate_ID and A.cate_Secret=false ORDER BY C.log_PostTime"
Set RS_Month = Conn.Execute(SQL)
SQLQueryNums = SQLQueryNums + 1
Dim the_Day, TempTitle, TempCount, TempSplit
the_Day = 0
TempCount = 0
TempTitle = ""
Do While Not RS_Month.EOF
If Day(RS_Month("log_PostTime"))<>the_Day Then
the_Day = Day(RS_Month("log_PostTime"))
ReDim PreServe Link_Days(4, Link_Count)
Link_Days(0, Link_Count) = Year(RS_Month("log_PostTime"))
Link_Days(1, Link_Count) = Month(RS_Month("log_PostTime"))
Link_Days(2, Link_Count) = Day(RS_Month("log_PostTime"))
Link_Days(3, Link_Count) = "default.asp?log_Year="&Year(RS_Month("log_PostTime"))&"&log_Month="&Month(RS_Month("log_PostTime"))&"&log_Day="&Day(RS_Month("log_PostTime"))
TempCount = 1
If RS_Month("log_IsShow") Then
TempTitle = Chr(13) & " - " & RS_Month("log_title")
Else
TempTitle = Chr(13) & " - [私密日志]"
End If
Link_Days(4, Link_Count) = "当天共写了" & TempCount &"篇日志" & TempTitle
Link_Count = Link_Count + 1
Else
TempCount = TempCount + 1
If RS_Month("log_IsShow") Then
Link_Days(4, Link_Count -1) = Link_Days(4, Link_Count -1) & Chr(10) & " - " & RS_Month("log_title")
Else
Link_Days(4, Link_Count -1) = Link_Days(4, Link_Count -1) & Chr(10) & " - [私密日志]"
End If
TempSplit = Split(Link_Days(4, Link_Count -1), Chr(13))
TempSplit(0) = "当天共写了" & TempCount &"篇日志" & Chr(13)
If UBound(TempSplit)>0 Then Link_Days(4, Link_Count -1) = TempSplit(0) & TempSplit(1)
End If
RS_Month.MoveNext
Loop
Set RS_Month = Nothing
'response.write ""
If upTime = C_Year&"-"&C_Month Then
CalendarArray = Array(Link_Days, upTime)
Application.Lock
Application(CookieName&"_blog_Calendar") = CalendarArray
Application.UnLock
'response.write ""
End If
Else
Link_Days = Application(CookieName&"_blog_Calendar")(0)
Link_Count = UBound(Link_Days, 2) + 1
'response.write ""
End If
If update = 2 Then Exit Function
Dim DayEnd, Calendar_Count
Calendar_Count = 0
DayEnd = False
DayCount = 0
Dclass = ""
DayStr = ""
isDo = 0
NotCM = 1
Do Until Month(S_Date)<>C_Month And NotCM = 7
If DayCount>6 Then
Calendar = Calendar & "
"
DayCount = 0
DayStr = ""
End If
If Calendar_Count = Link_Count Then
Calendar_Count = Link_Count -1
DayEnd = True
End If
If Month(S_Date) = C_Month Then NotCM = 0
If Month(S_Date)<>C_Month Then
Dclass = "class=""otherday"""
NotCM = NotCM + 1
ElseIf Year(S_Date) = Year(Now()) And Month(S_Date) = Month(Now()) And Day(S_Date) = Day(Now()) Then
Dclass = "class=""today"""
Else
Dclass = ""
End If
If Link_Count>0 Then
If Link_Days(1, Calendar_Count) = Month(S_Date) And Link_Days(2, Calendar_Count) = Day(S_Date) And DayEnd = False Then
If Month(S_Date)<>C_Month Then
Dclass = "class=""otherday"""
ElseIf Day(S_Date) = C_Day Then
Dclass = "class=""click"""
ElseIf C_Year = Year(Now()) And C_Month = Month(Now()) And Day(S_Date) = Day(Now()) Then
Dclass = "class=""DayD"""
Else
Dclass = "class=""haveD"""
End If
DayStr = DayStr&"
"&Day(S_Date)&""
Calendar_Count = Calendar_Count + 1
Else
DayStr = DayStr&"
"&Day(S_Date)&""
End If
Else
DayStr = DayStr&"
"&Day(S_Date)&""
End If
DayCount = DayCount + 1
S_Date = DateAdd("d", 1, S_Date)
Loop
Calendar = Calendar & "
你的权限: "&stat_title&"
"
If stat_Admin = True Then userPanel = userPanel + "系统管理"
If stat_AddAll = True Or stat_Add = True Then userPanel = userPanel + "发表新日志"
If (stat_AddAll = True Or stat_Add = True) And (stat_EditAll Or stat_Edit) Then
If IsEmpty(session(CookieName&"_draft_"&memName)) Then
session(CookieName&"_draft_"&memName) = conn.Execute("select count(log_ID) from blog_Content where log_Author='"&memName&"' and log_IsDraft=true")(0)
SQLQueryNums = SQLQueryNums + 1
End If
If session(CookieName&"_draft_"&memName)>0 Then
userPanel = userPanel + "编辑草稿 ["&session(CookieName&"_draft_"&memName)&"]"
Else
userPanel = userPanel + "编辑草稿"
End If
End If
If memName<>Empty Then
userPanel = userPanel&"修改个人资料退出系统"
Else
userPanel = userPanel&"登录用户注册"
End If
End Function
'**********************************************
'输出日志统计信息
'**********************************************
Function info_code(Str)
Dim vOnline
vOnline = getOnline
Str = Replace(Str, "$blog_LogNums$", blog_LogNums)
Str = Replace(Str, "$blog_CommNums$", blog_CommNums)
Str = Replace(Str, "$blog_TbCount$", blog_TbCount)
Str = Replace(Str, "$blog_MessageNums$", blog_MessageNums)
Str = Replace(Str, "$blog_MemNums$", blog_MemNums)
Str = Replace(Str, "$blog_VisitNums$", blog_VisitNums)
Str = Replace(Str, "$blog_OnlineNums$", vOnline)
info_code = Str
End Function
'**********************************************
'获取在线人数
'**********************************************
Function getOnline
getOnline = 1
If Len(Application(CookieName&"_onlineCount"))>0 Then
If DateDiff("s", Application(CookieName&"_userOnlineCountTime"), Now())>60 Then
Application.Lock()
Application(CookieName&"_online") = Application(CookieName&"_onlineCount")
Application(CookieName&"_onlineCount") = 1
Application(CookieName&"_onlineCountKey") = randomStr(2)
Application(CookieName&"_userOnlineCountTime") = Now()
Application.Unlock()
Else
If Session(CookieName&"userOnlineKey")<>Application(CookieName&"_onlineCountKey") Then
Application.Lock()
Application(CookieName&"_onlineCount") = Application(CookieName&"_onlineCount") + 1
Application.Unlock()
Session(CookieName&"userOnlineKey") = Application(CookieName&"_onlineCountKey")
End If
End If
Else
Application.Lock
Application(CookieName&"_online") = 1
Application(CookieName&"_onlineCount") = 1
Application(CookieName&"_onlineCountKey") = randomStr(2)
Application(CookieName&"_userOnlineCountTime") = Now()
Application.Unlock
End If
getOnline = Application(CookieName&"_online")
End Function
'**********************************************
'侧边模版处理
'**********************************************
Sub Side_Module_Replace()
'日历处理
Dim Cal_code
Cal_code = Calendar(log_Year, log_Month, log_Day, 1)
side_html_default = Replace(side_html_default, "$calendar_code$", Cal_code)
side_html = Replace(side_html, "$calendar_code$", Cal_code)
side_html_static = Replace(side_html_static, "$calendar_code$", Cal_code)
'用户面板处理
Dim user_code
user_code = userPanel
side_html_default = Replace(side_html_default, "$user_code$", user_code)
side_html = Replace(side_html, "$user_code$", user_code)
side_html_static = Replace(side_html_static, "$user_code$", user_code)
'归档面板处理
Dim archive_code
archive_code = Archive(1)
side_html_default = Replace(side_html_default, "$archive_code$", archive_code)
side_html = Replace(side_html, "$archive_code$", archive_code)
side_html_static = Replace(side_html_static, "$archive_code$", archive_code)
'树形分类处理
Dim Category_code
Category_code = CategoryList(1)
side_html_default = Replace(side_html_default, "$Category_code$", Category_code)
side_html = Replace(side_html, "$Category_code$", Category_code)
side_html_static = Replace(side_html_static, "$Category_code$", Category_code)
'显示统计信息
side_html_default = info_code(side_html_default)
side_html = info_code(side_html)
side_html_static = info_code(side_html_static)
'处理最新评论内容
Dim Comment_code
Comment_code = NewComment(1)
side_html_default = Replace(side_html_default, "$comment_code$", Comment_code)
side_html = Replace(side_html, "$comment_code$", Comment_code)
side_html_static = Replace(side_html_static, "$comment_code$", Comment_code)
'处理友情链接内容
Dim Link_Code
Link_Code = Bloglinks(1)
side_html_default = Replace(side_html_default, "$Link_Code$", Link_Code)
side_html = Replace(side_html, "$Link_Code$", Link_Code)
side_html_static = Replace(side_html_static, "$Link_Code$", Link_Code)
End Sub
'==============================================================
' Blog Class
'==============================================================
'*******************************************
' 分类读取Class
'*******************************************
Class Category
Public cate_ID
Public cate_Name
Public cate_Part
Public cate_Order
Public cate_Intro
Public cate_OutLink
Public cate_URL
Public cate_icon
Public cate_count
Public cate_Lock
Public cate_local
Public cate_Secret
Private LastID
Private Loaded
Private Sub Class_Initialize()
cate_ID = 0
cate_Name = ""
cate_Part = ""
cate_Order = 0
cate_Intro = ""
cate_OutLink = False
cate_URL = ""
cate_icon = ""
cate_count = ""
cate_Lock = False
cate_local = ""
cate_Secret = False
LastID = -99
Loaded = False
End Sub
Private Sub Class_Terminate()
End Sub
Public Sub Reload
CategoryList(2) '更新分类缓存
End Sub
Public Function Load(ID)
Dim blog_Cate, blog_CateArray, Category_Len, i
If Int(ID) = LastID Then Exit Function
If Not IsArray(Application(CookieName&"_blog_Category")) Then Reload
blog_CateArray = Application(CookieName&"_blog_Category")
If UBound(blog_CateArray, 1) = 0 Then Exit Function
Category_Len = UBound(blog_CateArray, 2)
For i = 0 To Category_Len
If Int(blog_CateArray(0, i)) = Int(ID) Then
cate_ID = blog_CateArray(0, i)
cate_Name = blog_CateArray(1, i)
cate_Order = blog_CateArray(2, i)
cate_Intro = blog_CateArray(3, i)
cate_OutLink = blog_CateArray(4, i)
cate_URL = blog_CateArray(5, i)
cate_icon = blog_CateArray(6, i)
cate_count = blog_CateArray(7, i)
cate_Lock = blog_CateArray(8, i)
cate_local = blog_CateArray(9, i)
cate_Secret = blog_CateArray(10, i)
cate_Part = blog_CateArray(11, i)
LastID = Int(ID)
Loaded = True
Exit Function
End If
Next
End Function
End Class
'*******************************************
' Tag Class
'*******************************************
Class Tag
Private Sub Class_Initialize()
If Not IsArray(Application(CookieName&"_blog_Tags")) Then Reload
End Sub
Private Sub Class_Terminate()
End Sub
Public Sub Reload
Tags(2) '更新Tag缓存
End Sub
Public Function insert(tagName) '插入标签,返回ID号
If checkTag(tagName) Then
conn.Execute("update blog_tag set tag_count=tag_count+1 where tag_name='"&tagName&"'")
insert = conn.Execute("select top 1 tag_id from blog_tag where tag_name='"&tagName&"'")(0)
Else
conn.Execute("insert into blog_tag (tag_name,tag_count) values ('"&tagName&"',1)")
insert = conn.Execute("select top 1 tag_id from blog_tag order by tag_id desc")(0)
End If
End Function
Public Function Remove(tagID) '清除标签
If checkTagID(tagID) Then
conn.Execute("update blog_tag set tag_count=tag_count-1 where tag_id="&tagID)
End If
End Function
Public Function filterHTML(Str) '过滤标签
If IsEmpty(Str) Or IsNull(Str) Or Len(Str) = 0 Then
Exit Function
filterHTML = Str
Else
Dim log_Tag, log_TagItem
For Each log_TagItem IN Arr_Tags
log_Tag = Split(log_TagItem, "||")
Str = Replace(Str, "{"&log_Tag(0)&"}", ""&log_Tag(1)&""&log_Tag(1)&" ")
Next
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\{(\d)\}"
Str = re.Replace(Str, "")
filterHTML = Str
End If
End Function
Public Function filterEdit(Str) '过滤标签进行编辑
If IsEmpty(Str) Or IsNull(Str) Or Len(Str) = 0 Then
Exit Function
filterEdit = Str
Else
Dim log_Tag, log_TagItem
For Each log_TagItem IN Arr_Tags
log_Tag = Split(log_TagItem, "||")
Str = Replace(Str, "{"&log_Tag(0)&"}", log_Tag(1)&" ")
Next
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\{(\d)\}"
Str = re.Replace(Str, "")
filterEdit = Left(Str, Len(Str) -1)
End If
End Function
Private Function checkTag(tagName) '检测是否存在此标签（根据名称）
checkTag = False
Dim log_Tag, log_TagItem
For Each log_TagItem IN Arr_Tags
log_Tag = Split(log_TagItem, "||")
If LCase(log_Tag(1)) = LCase(tagName) Then
checkTag = True
Exit Function
End If
Next
End Function
Private Function checkTagID(tagID) '检测是否存在此标签（根据ID）
checkTagID = False
Dim log_Tag, log_TagItem
For Each log_TagItem IN Arr_Tags
log_Tag = Split(log_TagItem, "||")
If Int(log_Tag(0)) = Int(tagID) Then
checkTagID = True
Exit Function
End If
Next
End Function
Public Function getTagID(tagName) '获得Tag的ID
getTagID = 0
Dim log_Tag, log_TagItem
For Each log_TagItem IN Arr_Tags
log_Tag = Split(log_TagItem, "||")
If LCase(log_Tag(1)) = LCase(ClearHTML(tagName)) Then
getTagID = log_Tag(0)
Exit Function
End If
Next
End Function
End Class
%>
<%
'===========PBlog2 UBB代码转换代码==========
' Author:PuterJam
' Copryright PBlog2
' Update: 2005-12-29
'===========================================
Function UBBCode(ByVal strContent, DisSM, DisUBB, DisIMG, AutoURL, AutoKEY)
If IsEmpty(strContent) Or IsNull(strContent) Then
Exit Function
Else
Dim re, strMatchs, strMatch, rndID, tmpStr1, tmpStr2, tmpStr3, tmpStr4
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
If AutoURL = 1 Then
re.Pattern = "([^=\]][\s]*?|^)(http|https|rstp|ftp|mms|ed2k)://([A-Za-z0-9\.\/=\?%\-_~`@':+!]*)"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = checkURL(strMatch.SubMatches(2))
strContent = Replace(strContent, strMatch.Value, tmpStr1&""&tmpStr2&"://"&tmpStr3&"", 1, -1, 0)
Next
're.Pattern="(^|\s)(www\.\S+)"
'strContent=re.Replace(strContent,"$1$2")
End If
'防止xss注入
strContent = Replace(strContent, "expression", "expression", 1, -1, 0)
If Not DisUBB = 1 Then
If Not DisIMG = 1 Then
re.Pattern = "(\[img\])(.[^\]]*)\[\/img\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = (strMatch.SubMatches(1))
strContent = Replace(strContent, strMatch.Value, "![]()
", 1, -1, 0)
Next
re.Pattern = "\[img=(left|right|center|absmiddle|)\](.[^\]]*)(\[\/img\])"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = checkURL(strMatch.SubMatches(1))
strContent = Replace(strContent, strMatch.Value, "![]()
", 1, -1, 0)
Next
re.Pattern = "\[img=(\d*|),(\d*|)\](.[^\]]*)\[\/img\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = checkURL(strMatch.SubMatches(2))
strContent = Replace(strContent, strMatch.Value, "![]()
", 1, -1, 0)
Next
re.Pattern = "\[img=(\d*|),(\d*|),(left|right|center|absmiddle|)\](.[^\]]*)(\[\/img\])"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = strMatch.SubMatches(2)
tmpStr4 = checkURL(strMatch.SubMatches(3))
strContent = Replace(strContent, strMatch.Value, "![]()
", 1, -1, 0)
Next
Else
re.Pattern = "(\[img\])(.[^\]]*)\[\/img\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(1))
strContent = Replace(strContent, strMatch.Value, "![]()
查看图片", 1, -1, 0)
Next
re.Pattern = "\[img=(left|right|center|absmiddle|)\](.[^\]]*)(\[\/img\])"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = checkURL(strMatch.SubMatches(1))
strContent = Replace(strContent, strMatch.Value, "![]()
查看图片", 1, -1, 0)
Next
re.Pattern = "\[img=(\d*|),(\d*|)\](.[^\]]*)\[\/img\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = checkURL(strMatch.SubMatches(2))
strContent = Replace(strContent, strMatch.Value, "![]()
查看图片", 1, -1, 0)
Next
re.Pattern = "\[img=(\d*|),(\d*|),(left|right|center|absmiddle|)\](.[^\]]*)(\[\/img\])"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = strMatch.SubMatches(0)
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = strMatch.SubMatches(2)
tmpStr4 = checkURL(strMatch.SubMatches(3))
strContent = Replace(strContent, strMatch.Value, "![]()
查看图片", 1, -1, 0)
Next
End If
'-----------多媒体标签----------------
re.Pattern = "\[(swf|wma|wmv|rm|ra|qt)(=\d*?|)(,\d*?|)\]([^<>]*?)\[\/(swf|wma|wmv|rm|ra|qt)\]"
Set strMatchs = re.Execute(strContent)
Dim strType, strWidth, strHeight, strSRC, TitleText
For Each strMatch in strMatchs
Randomize
strType = strMatch.SubMatches(0)
If strType = "swf" Then
TitleText = "![]()
Flash动画"
ElseIf strType = "wma" Then
TitleText = "![]()
播放音频文件"
ElseIf strType = "wmv" Then
TitleText = "![]()
播放视频文件"
ElseIf strType = "rm" Then
TitleText = "![]()
播放real视频流文件"
ElseIf strType = "ra" Then
TitleText = "![]()
播放real音频流文件"
ElseIf strType = "qt" Then
TitleText = "![]()
播放mov视频文件"
End If
strWidth = strMatch.SubMatches(1)
strHeight = strMatch.SubMatches(2)
If (Len(strWidth) = 0) Then
strWidth = "400"
Else
strWidth = Right(strWidth, (Len(strWidth) -1))
End If
If (Len(strHeight) = 0) Then
strHeight = "300"
Else
strHeight = Right(strHeight, (Len(strHeight) -1))
End If
strSRC = checkURL(strMatch.SubMatches(3))
rndID = "temp"&Int(100000 * Rnd)
strContent = Replace(strContent, strMatch.Value, "")
Next
Set strMatchs = Nothing
re.Pattern = "(\[mid\])(.[^\]]*)\[\/mid\]"
strContent = re.Replace(strContent, "")
'-----------常规标签----------------
re.Pattern = "\[url=(.[^\]]*)\](.[^\[]*)\[\/url]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
strContent = Replace(strContent, strMatch.Value, ""&tmpStr2&"", 1, -1, 0)
Next
re.Pattern = "\[url](.[^\[]*)\[\/url]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
strContent = Replace(strContent, strMatch.Value, ""&tmpStr1&"", 1, -1, 0)
Next
re.Pattern = "\[ed2k=([^\r]*?)\]([^\r]*?)\[\/ed2k]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
strContent = Replace(strContent, strMatch.Value, "![]()
"&tmpStr2&"", 1, -1, 0)
Next
re.Pattern = "\[ed2k]([^\r]*?)\[\/ed2k]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
strContent = Replace(strContent, strMatch.Value, "![]()
"&tmpStr1&"", 1, -1, 0)
Next
re.Pattern = "\[email=(.[^\]]*)\](.[^\[]*)\[\/email]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
strContent = Replace(strContent, strMatch.Value, ""&tmpStr2&"", 1, -1, 0)
Next
re.Pattern = "\[email](.[^\[]*)\[\/email]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
strContent = Replace(strContent, strMatch.Value, ""&tmpStr1&"", 1, -1, 0)
Next
'-----------字体格式----------------
re.Pattern = "\[align=(\w{4,6})\]([^\r]*?)\[\/align\]"
strContent = re.Replace(strContent, "$2
")
re.Pattern = "\[color=(#\w{3,10}|\w{3,10})\]([^\r]*?)\[\/color\]"
strContent = re.Replace(strContent, "$2")
re.Pattern = "\[size=(\d{1,2})\]([^\r]*?)\[\/size\]"
strContent = re.Replace(strContent, "$2")
re.Pattern = "\[font=([^\r]*?)\]([^\r]*?)\[\/font\]"
strContent = re.Replace(strContent, "$2")
re.Pattern = "\[b\]([^\r]*?)\[\/b\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[i\]([^\r]*?)\[\/i\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[u\]([^\r]*?)\[\/u\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[s\]([^\r]*?)\[\/s\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[sup\]([^\r]*?)\[\/sup\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[sub\]([^\r]*?)\[\/sub\]"
strContent = re.Replace(strContent, "$1")
re.Pattern = "\[fly\]([^\r]*?)\[\/fly\]"
strContent = re.Replace(strContent, "")
'-----------特殊标签----------------
dim rndnum11, rndnum22, rndnum33, rndnum44
re.Pattern = "\[down=(download\.asp\?id=)(.[^\[]*)\](.[^\[]*)\[\/down]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = strMatch.SubMatches(2)
rndnum11 = randomStr(10)
strContent = Replace(strContent, strMatch.Value, "", 1, -1, 0)
Next
re.Pattern = "\[down\](download\.asp\?id=)(.[^\[]*)\[\/down\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
rndnum22 = randomStr(10)
strContent = Replace(strContent, strMatch.Value, "", 1, -1, 0)
Next
re.Pattern = "\[mDown=(download\.asp\?id=)(.[^\[]*)\](.[^\[]*)\[\/mDown]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
tmpStr3 = strMatch.SubMatches(2)
rndnum33 = randomStr(10)
strContent = Replace(strContent, strMatch.Value, "", 1, -1, 0)
Next
re.Pattern = "\[mDown\](download\.asp\?id=)(.[^\[]*)\[\/mDown]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
rndnum44 = randomStr(10)
strContent = Replace(strContent, strMatch.Value, "", 1, -1, 0)
Next
re.Pattern = "\[down=(.[^\]]*)\](.[^\[]*)\[\/down]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
strContent = Replace(strContent, strMatch.Value, "![]()
"&tmpStr2&"", 1, -1, 0)
Next
re.Pattern = "\[down\](.[^\[]*)\[\/down]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
strContent = Replace(strContent, strMatch.Value, "![]()
下载此文件", 1, -1, 0)
Next
re.Pattern = "\[mDown=(.[^\]]*)\](.[^\[]*)\[\/mDown]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
tmpStr2 = strMatch.SubMatches(1)
dim rndnum1:rndnum1=randomStr(10)
strContent = Replace(strContent, strMatch.Value, "
", 1, -1, 0)
Next
re.Pattern = "\[mDown\](.[^\[]*)\[\/mDown]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
tmpStr1 = checkURL(strMatch.SubMatches(0))
dim rndnum2:rndnum2=randomStr(10)
strContent = Replace(strContent, strMatch.Value, "
", 1, -1, 0)
Next
'-----------CC Video标签------------
re.Pattern = "\[cc\](.*?)\[\/cc\]"
strContent = re.Replace(strContent, "")
'-----------代码标签----------------
re.Pattern = "\[code\](.*?)\[\/code\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
Randomize
rndID = "code"&Int(100000 * Rnd)
strContent = Replace(strContent, strMatch.Value, ""&strMatch.SubMatches(0)&"
![]()
引用内容
$1
![]()
引用来自 $1
$2
![]()
显示被隐藏内容
$1
![]()
隐藏内容
该内容已经被作者隐藏,只有会员才允许查阅
登录 |
注册![]()
显示被隐藏内容来自 $1
$2
![]()
隐藏内容
该内容已经被作者隐藏,只有会员才允许查阅
登录 |
注册")
re.Pattern = "\[list=(.[^\]]*)\]"
strContent = re.Replace(strContent, "")
re.Pattern = "\[\*\](.[^\[]*)(\n|)"
strContent = re.Replace(strContent, "- $1
")
strContent = Replace(strContent, "[/list]", "
")
End If
'-----------回复标签----------------
re.Pattern = "\[reply=(.[^\]]*),(.[^\]]*)\](.*?)\[\/reply\]"
strContent = re.Replace(strContent, "![]()
$1 于
$2 回复
$3
![]()
$1 回复
$2
![]()
")
Next
End If
'-----------关键词识别----------------
If AutoKEY = 1 Then
Dim log_Keywords, log_KeywordsContent
For Each log_Keywords IN Arr_Keywords
log_KeywordsContent = Split(log_Keywords, "$|$")
If log_KeywordsContent(3)<>"None" Then
strContent = Replace(strContent, log_KeywordsContent(1), "![]()
"&log_KeywordsContent(1)&"")
Else
strContent = Replace(strContent, log_KeywordsContent(1), ""&log_KeywordsContent(1)&"")
End If
Next
End If
Set re = Nothing
UBBCode = strContent
End If
End Function
%>
<%
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)
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
MD5 = UCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function
%>
<%
'===============================================================
' Check User For PJblog2
' 更新时间: 2006-5-29
'===============================================================
Dim UserID, memName, memStatus
memStatus = "Guest"
Function login(UserName, Password)
Dim validate, ReInfo, HashKey
UserName = CheckStr(UserName)
Password = CheckStr(Password)
validate = Trim(request.Form("validate"))
ReInfo = Array("错误信息", "", "MessageIcon", False)
If Trim(UserName) = "" Or Trim(Password) = "" Then
ReInfo(0) = "错误信息"
ReInfo(1) = "请将信息输入完整
请返回重新输入
"
ReInfo(2) = "WarningIcon"
login = ReInfo
logout(False)
Exit Function
End If
If validate = "" Then
ReInfo(0) = "错误信息"
ReInfo(1) = "请输入登录验证码
请返回重新输入
"
ReInfo(2) = "WarningIcon"
login = ReInfo
logout(False)
Exit Function
End If
If IsValidUserName(UserName) = False Then
ReInfo(0) = "错误信息"
ReInfo(1) = "非法用户名！
请尝试使用其他用户名！
单击返回
"
ReInfo(2) = "ErrorIcon"
login = ReInfo
logout(False)
Exit Function
End If
If CStr(LCase(Session("GetCode")))<>CStr(LCase(validate)) Then
ReInfo(0) = "错误信息"
ReInfo(1) = "验证码有误，请返回重新输入
请返回重新输入
"
ReInfo(2) = "ErrorIcon"
login = ReInfo
logout(False)
Exit Function
End If
HashKey = SHA1(randomStr(6)&Now())
Dim memLogin
Set memLogin = Server.CreateObject("ADODB.Recordset")
SQL = "SELECT Top 1 mem_Name,mem_Password,mem_salt,mem_Status,mem_LastIP,mem_lastVisit,mem_hashKey FROM blog_member WHERE mem_Name='"&UserName&"' AND mem_salt<>''"
memLogin.Open SQL, conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If memLogin.EOF And memLogin.BOF Then
memLogin.Close
SQL = "SELECT Top 1 mem_Name,mem_Password,mem_salt,mem_Status,mem_LastIP,mem_lastVisit,mem_hashKey FROM blog_member WHERE mem_Name='"&UserName&"' AND mem_Password='"&md5(Password)&"'"
memLogin.Open SQL, conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If memLogin.EOF And memLogin.BOF Then
ReInfo(0) = "错误信息"
ReInfo(1) = "用户名与密码错误
请返回重新输入
"
ReInfo(2) = "ErrorIcon"
logout(False)
Else
'进行MD5密码验证，转换旧帐户密码验证方式
Dim strSalt
strSalt = randomStr(6)
memLogin("mem_salt") = strSalt
memLogin("mem_LastIP") = getIP()
memLogin("mem_lastVisit") = Now()
memLogin("mem_hashKey") = HashKey
memLogin("mem_Password") = SHA1(Password&strSalt)
Response.Cookies(CookieName)("memName") = memLogin("mem_Name")
Response.Cookies(CookieName)("memHashKey") = HashKey
If Request.Form("KeepLogin") = "1" Then
Response.Cookies(CookieName).Expires = Date+365
Response.Cookies(CookieName)("exp") = DateAdd("d", 365, date())
End If
memLogin.Update
ReInfo(0) = "登录成功"
ReInfo(1) = ""&memLogin("mem_Name")&"，欢迎你的再次光临。
点击返回主页"
ReInfo(2) = "MessageIcon"
ReInfo(3) = True
End If
Else
If memLogin("mem_Password")<>SHA1(Password&memLogin("mem_salt")) Then
ReInfo(0) = "错误信息"
ReInfo(1) = "用户名与密码错误
请返回重新输入
"
ReInfo(2) = "ErrorIcon"
logout(False)
Else
memLogin("mem_LastIP") = getIP()
memLogin("mem_lastVisit") = Now()
memLogin("mem_hashKey") = HashKey
Response.Cookies(CookieName)("memName") = memLogin("mem_Name")
Response.Cookies(CookieName)("memHashKey") = HashKey
If Request.Form("KeepLogin") = "1" Then
Response.Cookies(CookieName).Expires = Date+365
Response.Cookies(CookieName)("exp") = DateAdd("d", 365, date())
End If
memLogin.Update
ReInfo(0) = "登录成功"
ReInfo(1) = ""&memLogin("mem_Name")&"，欢迎你的再次光临。
点击返回主页"
ReInfo(2) = "MessageIcon"
ReInfo(3) = True
End If
End If
memLogin.Close
Set memLogin = Nothing
login = ReInfo
End Function
Function login2(UserName, Password)
Dim validate, ReInfo, HashKey
UserName = CheckStr(UserName)
Password = CheckStr(Password)
ReInfo = Array("错误信息", "", "MessageIcon", False)
If Trim(UserName) = "" Or Trim(Password) = "" Then
ReInfo(0) = "错误信息"
ReInfo(1) = "请将信息输入完整
请返回重新输入
"
ReInfo(2) = "WarningIcon"
login2 = ReInfo
logout(False)
UserRight(1)
Exit Function
End If
If IsValidUserName(UserName) = False Then
ReInfo(0) = "错误信息"
ReInfo(1) = "非法用户名！
请尝试使用其他用户名！
单击返回
"
ReInfo(2) = "ErrorIcon"
login2 = ReInfo
logout(False)
UserRight(1)
Exit Function
End If
HashKey = SHA1(randomStr(6)&Now())
Dim memLogin
Set memLogin = Server.CreateObject("ADODB.Recordset")
SQL = "SELECT Top 1 mem_Name,mem_Password,mem_salt,mem_Status,mem_LastIP,mem_lastVisit,mem_hashKey FROM blog_member WHERE mem_Name='"&UserName&"' AND mem_salt<>''"
memLogin.Open SQL, conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If memLogin.EOF And memLogin.BOF Then
memLogin.Close
SQL = "SELECT Top 1 mem_Name,mem_Password,mem_salt,mem_Status,mem_LastIP,mem_lastVisit,mem_hashKey FROM blog_member WHERE mem_Name='"&UserName&"' AND mem_Password='"&md5(Password)&"'"
memLogin.Open SQL, conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If memLogin.EOF And memLogin.BOF Then
ReInfo(0) = "错误信息"
ReInfo(1) = "用户名与密码错误
请返回重新输入
"
ReInfo(2) = "ErrorIcon"
logout(False)
Else
'进行MD5密码验证，转换旧帐户密码验证方式
Dim strSalt
strSalt = randomStr(6)
memLogin("mem_salt") = strSalt
memLogin("mem_LastIP") = getIP()
memLogin("mem_lastVisit") = Now()
memLogin("mem_hashKey") = HashKey
memLogin("mem_Password") = SHA1(Password&strSalt)
memLogin.Update
memName = memLogin("mem_Name")
memStatus = memLogin("mem_Status")
ReInfo(0) = "登录成功"
ReInfo(1) = ""&memLogin("mem_Name")&"，欢迎你的再次光临。
点击返回主页"
ReInfo(2) = "MessageIcon"
ReInfo(3) = True
End If
Else
If memLogin("mem_Password")<>SHA1(Password&memLogin("mem_salt")) Then
ReInfo(0) = "错误信息"
ReInfo(1) = "用户名与密码错误
请返回重新输入
"
ReInfo(2) = "ErrorIcon"
logout(False)
Else
memName = memLogin("mem_Name")
memStatus = memLogin("mem_Status")
ReInfo(0) = "登录成功"
ReInfo(1) = ""&memLogin("mem_Name")&"，欢迎你的再次光临。
点击返回主页"
ReInfo(2) = "MessageIcon"
ReInfo(3) = True
End If
End If
UserRight(1)
memLogin.Close
Set memLogin = Nothing
login2 = ReInfo
End Function
Sub checkCookies()
Dim Guest_IP, Guest_Browser, Guest_Refer
Guest_IP = getIP()
Guest_Browser = getBrowser(Request.ServerVariables("HTTP_USER_AGENT"))
If Session("GuestIP")<>Guest_IP Then
Conn.Execute("UPDATE blog_Info SET blog_VisitNums=blog_VisitNums+1")
SQLQueryNums = SQLQueryNums + 1
getInfo(2)
Session("GuestIP") = Guest_IP
If blog_CountNum>0 And Guest_Browser(1)<>"Unkown" Then
Dim tmpC
tmpC = conn.Execute("select count(coun_ID) as cnt from [blog_Counter]")(0)
SQLQueryNums = SQLQueryNums + 1
Guest_Refer = Trim(Request.ServerVariables("HTTP_REFERER"))
If tmpC>= blog_CountNum Then
Dim tmpLC
tmpLC = conn.Execute("select top 1 coun_ID from [blog_Counter] order by coun_Time ASC")(0)
Conn.Execute("update [blog_Counter] set coun_Time=#"&Now()&"#,coun_IP='"&Guest_IP&"',coun_OS='"&Guest_Browser(1)&"',coun_Browser='"&Guest_Browser(0)&"',coun_Referer='"&HTMLEncode(CheckStr(Guest_Refer))&"' where coun_ID="&tmpLC)
SQLQueryNums = SQLQueryNums + 2
Else
Conn.Execute("INSERT INTO blog_Counter(coun_IP,coun_OS,coun_Browser,coun_Referer) VALUES ('"&Guest_IP&"','"&Guest_Browser(1)&"','"&Guest_Browser(0)&"','"&HTMLEncode(CheckStr(Guest_Refer))&"')")
SQLQueryNums = SQLQueryNums + 1
End If
End If
End If
Dim tempName, tempHashKey
tempName = CheckStr(Request.Cookies(CookieName)("memName"))
tempHashKey = CheckStr(Request.Cookies(CookieName)("memHashKey"))
If tempHashKey = "" Then
logout(False)
Else
Dim CheckCookie
Set CheckCookie = Server.CreateObject("ADODB.RecordSet")
SQL = "SELECT Top 1 mem_ID,mem_Name,mem_Password,mem_salt,mem_Status,mem_LastIP,mem_lastVisit,mem_hashKey FROM blog_member WHERE mem_Name='"&tempName&"' AND mem_hashKey='"&tempHashKey&"' AND mem_hashKey<>''"
CheckCookie.Open SQL, Conn, 1, 1
SQLQueryNums = SQLQueryNums + 1
If CheckCookie.EOF And CheckCookie.BOF Then
logout(False)
Else
UserID = CheckCookie("mem_ID")
' If CheckCookie("mem_LastIP")<>Guest_IP Or IsNull(CheckCookie("mem_LastIP")) Then
' logout(True)
' Else
memName = CheckStr(Request.Cookies(CookieName)("memName"))
memStatus = CheckCookie("mem_Status")
' End If
End If
CheckCookie.Close
Set CheckCookie = Nothing
End If
End Sub
Sub logout(clearHashKey)
On Error Resume Next
If clearHashKey Then conn.Execute("UPDATE blog_member set mem_hashKey='' where mem_ID="&UserID)
If Err Then Err.Clear
Response.Cookies(CookieName)("memName") = ""
Response.Cookies(CookieName)("memHashKey") = ""
memStatus = "Guest"
End Sub
%>
<%
'=================================================
' moduleSetting Class for PJBlog2
' Author: PuterJam
' UpdateDate: 2005-7-31
'=================================================
Class ModSet
Private ModSetArray
Private ModName
Private state
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
'=================================================
' 打开模块Open(ModName)
'=================================================
Public Function Open(LoadName)
ModName = LoadName
If Not IsArray(Application(CookieName&"_Mod_"&ModName))Then
state = -18902
ReLoad()
Else
ModSetArray = Application(CookieName&"_Mod_"&ModName)
state = 0
End If
End Function
'=================================================
' 从数据库里重新读取模块到缓存ReLoad()
'=================================================
Public Function ReLoad()
If ModName = "" Then
state = -18901
Exit Function
End If
Dim ModDB, KeyLen, i, GetPlugPath
i = 0
KeyLen = conn.Execute("select count(*) from blog_ModSetting where set_ModName='"&ModName&"'")(0)
Set ModDB = conn.Execute("select * from blog_ModSetting where set_ModName='"&ModName&"'")
ReDim ModSetArray(KeyLen, 1)
Do Until ModDB.EOF
ModSetArray(i, 0) = ModDB("set_KeyName")
ModSetArray(i, 1) = ModDB("set_KeyValue")
i = i + 1
ModDB.movenext
Loop
ModSetArray(KeyLen, 0) = "PlugingPath"
Set GetPlugPath = conn.Execute("select InstallFolder from blog_module where name='"&ModName&"'")
If GetPlugPath.EOF Then
state = -18903
Exit Function
Else
ModSetArray(KeyLen, 1) = GetPlugPath(0)
End If
Application.Lock
Application(CookieName&"_Mod_"&ModName) = ModSetArray
Application.UnLock
state = 0
End Function
'=================================================
' 读取字段名称getKeyValue(KeyName)
'=================================================
Public Function getKeyValue(KeyName)
Dim KeysLen, i
getKeyValue = ""
KeysLen = UBound(ModSetArray, 1)
For i = 0 To KeysLen
If ModSetArray(i, 0) = KeyName Then
getKeyValue = ModSetArray(i, 1)
Exit Function
End If
Next
End Function
'=================================================
' 获得出错信息ReLoad()
'=================================================
Public Function PasreError
PasreError = state
' -18901 没有打开模块
' -18902 缓存里没有任何信息
' -18903 没有安装插件
End Function
'=================================================
' 获得插件所在路径
'=================================================
Public Function GetPath
Dim KeysLen, i
GetPath = ""
KeysLen = UBound(ModSetArray, 1)
GetPath = ModSetArray(KeysLen, 1)
End Function
'=================================================
' 清除插件占用的 Application 地址
'=================================================
Public Function RemoveApplication
Application.Lock
Application.Contents.Remove(CookieName&"_Mod_"&ModName)
Application.UnLock
End Function
End Class
%>
<%
'==================================
' 日志编辑类
' 更新时间: 2006-1-22
'==================================
Class logArticle
Private weblog
Public categoryID, logTitle, logAuthor, logEditType
Public logIsShow, logIsDraft, logWeather, logLevel, logCommentOrder, logReadpw, logPwtips, logPwtitle, logPwcomm
Public logDisableComment, logIsTop, logFrom, logFromURL, isajax, logdescriptionFilt
Public logDisableImage, logDisableSmile, logDisableURL, logDisableKeyWord, logMeta, logKeyWords, logDescription, TagMeta
Public logQuote, logMessage, logIntro, logIntroCustom, logTags, logPublishTimeType, logPubTime, logTrackback, logCommentCount, logQuoteCount, logViewCount, logCname, logCtype
Private logUbbFlags, PubTime, sqlString
Private Sub Class_Initialize()
Set weblog = Server.CreateObject("ADODB.RecordSet")
categoryID = 0
logTitle = ""
logEditType = 1
logIntroCustom = 0
logIntro = ""
logAuthor = "null"
logWeather = "sunny"
logLevel = "level3"
logCommentOrder = 1
logDisableComment = 0
logIsShow = True
logIsTop = False
logIsDraft = False
logFrom = "本站原创"
logFromURL = siteURL
logDisableImage = 0
logDisableSmile = 0
logDisableURL = 0
logDisableKeyWord = 0
logCommentCount = 0
logQuoteCount = 0
logViewCount = 0
logMessage = ""
logTrackback = ""
logTags = ""
logPubTime = "2006-1-1 00:00:00"
logPublishTimeType = "now"
If blog_postFile = 2 Then
logCname = ""
logCtype = "0"
End If
logReadpw = ""
logPwtips = ""
logPwtitle = False
logPwcomm = False
logmeta = 0
logKeyWords = ""
logDescription = ""
isajax = false
End Sub
Private Sub Class_Terminate()
Set weblog = Nothing
End Sub
'*********************************************
'发表新日志
'*********************************************
Public Function postLog()
postLog = Array( -4, "准备发表日志!", -1)
weblog.Open "blog_Content", Conn, 1, 2
SQLQueryNums = SQLQueryNums + 1
If stat_AddAll<>True And stat_Add<>True Then
postLog = Array( -3, "您没有权限发表日志!", -1)
Exit Function
End If
TagMeta = logTags
'-------------------处理Tags--------------------
Dim tempTags,tempTags2, loadTagString, loadTags, loadTag, getTags
tempTags = Split(CheckStr(logTags), ",")
Set getTags = New Tag
Dim post_tag,post_tag2, post_taglist
post_taglist = ""
'添加新的Tag
For Each post_tag in tempTags
tempTags2 = Split(post_tag," ")
If UBound(tempTags2)>0 Then
For Each post_tag2 in tempTags2
If Len(Trim(post_tag2))>0 Then
post_taglist = post_taglist & "{" & getTags.insert(CheckStr(Trim(post_tag2))) & "}"
End If
Next
Else
If Len(Trim(post_tag))>0 Then
post_taglist = post_taglist & "{" & getTags.insert(CheckStr(Trim(post_tag))) & "}"
End If
End If
Next
logTags = post_taglist
Call Tags(2)
Set getTags = Nothing
'--------------处理日期---------------------
If CheckStr(logPublishTimeType) = "now" Then
PubTime = DateToStr(Now(), "Y-m-d H:I:S")
Else
PubTime = DateToStr(CheckStr(logPubTime), "Y-m-d H:I:S")
End If
'---------------分割日志--------------------
If logIntroCustom = 1 Then
If Int(logEditType) = 1 Then
logdescriptionFilt = closeUBB(logIntro)
Else
logdescriptionFilt = closeHTML(logIntro)
End If
Else
If Int(logEditType) = 1 Then
If blog_SplitType Then
logdescriptionFilt = closeUBB(SplitLines(logMessage, blog_introLine))
Else
logdescriptionFilt = closeUBB(CutStr(logMessage, blog_introChar))
End If
Else
logdescriptionFilt = closeHTML(SplitLines(logMessage, blog_introLine))
End If
End If
If logIntroCustom = 1 Then
If Int(logEditType) = 1 Then
logIntro = closeUBB(CheckStr(HTMLEncode(logIntro)))
Else
logIntro = closeHTML(CheckStr(logIntro))
End If
Else
If Int(logEditType) = 1 Then
If blog_SplitType Then
logIntro = closeUBB(SplitLines(CheckStr(HTMLEncode(logMessage)), blog_introLine))
Else
logIntro = closeUBB(CutStr(CheckStr(HTMLEncode(logMessage)), blog_introChar))
End If
Else
logIntro = closeHTML(SplitLines(CheckStr(logMessage), blog_introLine))
End If
End If
'日志基本状态
logIsShow = CBool(logIsShow)
logCommentOrder = CBool(logCommentOrder)
logDisableComment = CBool(logDisableComment)
logIsTop = CBool(logIsTop)
logIsDraft = CBool(logIsDraft)
logPwtitle = CBool(logPwtitle)
logPwcomm = CBool(logPwcomm)
logMeta = CBool(logMeta)
'UBB 特别属性
If logDisableSmile = 1 Then logDisableSmile = 1 Else logDisableSmile = 0
If logDisableImage = 1 Then logDisableImage = 1 Else logDisableImage = 0
If logDisableURL = 1 Then logDisableURL = 0 Else logDisableURL = 1
If logDisableKeyWord = 1 Then logDisableKeyWord = 0 Else logDisableKeyWord = 1
If logIntroCustom = 1 Then logIntroCustom = 0 Else logIntroCustom = 1
logUbbFlags = logDisableSmile & "0" & logDisableImage & logDisableURL & logDisableKeyWord & logIntroCustom
'Meta特别属性
If logMeta <> true Then
logDescription = FilterHtmlTags(logdescriptionFilt)
Else
logDescription = FilterHtmlTags(logDescription)
End If
If logMeta <> true Then
logKeyWords = CheckStr(TagMeta)
If len(logKeyWords) = 0 Then
logKeyWords = CheckStr(logTitle)
Else
logKeyWords = Replace(Replace(Replace(logKeyWords, ",", "|"), " ", "|"), "|", ",")
End If
End If
weblog.addNew
If len(logCname) < 1 or logCname = "" or logCname = empty or logCname = null Then
logCname = weblog("log_ID")
End If
weblog("log_CateID") = CheckStr(categoryID)
weblog("log_Author") = CheckStr(logAuthor)
weblog("log_Title") = CheckStr(logTitle)
weblog("log_weather") = CheckStr(logWeather)
weblog("log_Level") = CheckStr(logLevel)
weblog("log_From") = CheckStr(logFrom)
weblog("log_FromURL") = CheckStr(logFromURL)
weblog("log_Content") = CheckStr(logMessage)
weblog("log_Intro") = logIntro
weblog("log_Tag") = logTags
weblog("log_UbbFlags") = logUbbFlags
weblog("log_IsShow") = logIsShow
weblog("log_IsTop") = logIsTop
weblog("log_PostTime") = PubTime
weblog("log_IsDraft") = logIsDraft
weblog("log_DisComment") = logDisableComment
weblog("log_EditType") = logEditType
weblog("log_ComOrder") = logCommentOrder
weblog("log_Cname") = logCname
weblog("log_Ctype") = logCtype
weblog("log_Readpw") = logReadpw
weblog("log_Pwtips") = logPwtips
weblog("log_Pwtitle") = logPwtitle
weblog("log_Pwcomm") = logPwcomm
weblog("log_Meta") = logMeta
weblog("log_KeyWords") = logKeyWords
weblog("log_Description") = logDescription
SQLQueryNums = SQLQueryNums + 2
weblog.update
weblog.Close
'------------------统计日志-----------------------------
Dim PostLogID
PostLogID = Conn.Execute("SELECT TOP 1 log_ID FROM blog_Content ORDER BY log_ID DESC")(0)
if isajax <> true then
Conn.Execute("UPDATE blog_Member SET mem_PostLogs=mem_PostLogs+1 WHERE mem_Name='"&logAuthor&"'")
end if
If Not logIsDraft Then
if isajax <> true then
Conn.Execute("UPDATE blog_Info SET blog_LogNums=blog_LogNums+1")
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count+1 where cate_ID="&categoryID)
SQLQueryNums = SQLQueryNums + 2
end if
End If
'-------------------输出静态日志档案--------------------
Dim preLog, nextLog
'输出日志到文件
if isajax = false then
PostArticle PostLogID, False
end if
'输出附近的日志到文件
Set preLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&PubTime&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime>#"&PubTime&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
if isajax = false then
If Not preLog.EOF Then PostArticle preLog("log_ID"), False
If Not nextLog.EOF Then PostArticle nextLog("log_ID"), False
end if
Call updateCache
Session(CookieName&"_LastDo") = "AddArticle"
session(CookieName&"_draft_"&logAuthor) = conn.Execute("select count(log_ID) from blog_Content where log_Author='"&logAuthor&"' and log_IsDraft=true")(0)
SQLQueryNums = SQLQueryNums + 1
If logIsDraft Then
postLog = Array(1, "日志成功保存为草稿!", PostLogID)
Else
postLog = Array(0, "恭喜!日志发表成功!", PostLogID)
End If
'-------------------引用通告-------------------
If logTrackback<>Empty And logIsShow = True And logIsDraft = False Then
Dim log_QuoteEvery, log_QuoteArr, logid, LastID
Set LastID = Conn.Execute("SELECT TOP 1 log_ID FROM blog_Content ORDER BY log_ID DESC")
logid = LastID("log_ID")
log_QuoteArr = Split(logTrackback, ",")
For Each log_QuoteEvery In log_QuoteArr
Trackback Trim(log_QuoteEvery), siteURL&"default.asp?id="&logid, logTitle, CutStr(CheckStr(logIntro), 252), siteName
Set LastID = Nothing
Next
End If
End Function
'*********************************************
'编辑日志
'*********************************************
Public Function editLog(id)
editLog = Array( -4, "准备编辑日志!", -1)
If IsEmpty(id) Then
getLog = Array( -5, "ID号不能为空!")
Exit Function
End If
If Not IsInteger(id) Then
editLog = Array( -1, "非法ID号!", -1)
Exit Function
End If
sqlString = "SELECT top 1 * FROM blog_Content WHERE log_ID="&id&""
weblog.Open sqlString, Conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If weblog.EOF Or weblog.bof Then
editLog = Array( -2, "无法找到相应文章!", -1)
Exit Function
End If
If stat_EditAll<>True And (stat_Edit And weblog("log_Author") = logAuthor)<>True Then
editLog = Array( -3, "您没有权限编辑日志!", -1)
Exit Function
End If
logAuthor = weblog("log_Author")
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count-1 where cate_ID="&weblog("log_CateID"))
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count+1 where cate_ID="&CheckStr(categoryID))
TagMeta = logTags
'-------------------处理Tags--------------------
Dim tempTags,tempTags2, loadTagString, loadTags, loadTag, getTags
tempTags = Split(CheckStr(logTags), ",")
loadTagString = weblog("log_Tag")
Set getTags = New Tag
'清除旧的Tag
If Len(loadTagString)>0 Then
loadTagString = Replace(loadTagString, "}{", ",")
loadTagString = Replace(loadTagString, "}", "")
loadTagString = Replace(loadTagString, "{", "")
loadTags = Split(loadTagString, ",")
For Each loadTag in loadTags
getTags.Remove loadTag
Next
End If
Dim post_tag,post_tag2, post_taglist
post_taglist = ""
'添加新的Tag
For Each post_tag in tempTags
tempTags2 = Split(post_tag," ")
If UBound(tempTags2)>0 Then
For Each post_tag2 in tempTags2
If Len(Trim(post_tag2))>0 Then
post_taglist = post_taglist & "{" & getTags.insert(CheckStr(Trim(post_tag2))) & "}"
End If
Next
Else
If Len(Trim(post_tag))>0 Then
post_taglist = post_taglist & "{" & getTags.insert(CheckStr(Trim(post_tag))) & "}"
End If
End If
Next
logTags = post_taglist
Call Tags(2)
Set getTags = Nothing
'--------------处理日期---------------------
If CheckStr(logPublishTimeType) = "now" Then
PubTime = DateToStr(Now(), "Y-m-d H:I:S")
Else
PubTime = DateToStr(CheckStr(logPubTime), "Y-m-d H:I:S")
End If
'---------------分割日志--------------------
If logIntroCustom = 1 Then
If Int(logEditType) = 1 Then
logdescriptionFilt = closeUBB(logIntro)
Else
logdescriptionFilt = closeHTML(logIntro)
End If
Else
If Int(logEditType) = 1 Then
If blog_SplitType Then
logdescriptionFilt = closeUBB(SplitLines(logMessage, blog_introLine))
Else
logdescriptionFilt = closeUBB(CutStr(logMessage, blog_introChar))
End If
Else
logdescriptionFilt = closeHTML(SplitLines(logMessage, blog_introLine))
End If
End If
If logIntroCustom = 1 Then
If Int(logEditType) = 1 Then
logIntro = closeUBB(CheckStr(HTMLEncode(logIntro)))
Else
logIntro = closeHTML(CheckStr(logIntro))
End If
Else
If Int(logEditType) = 1 Then
If blog_SplitType Then
logIntro = closeUBB(SplitLines(CheckStr(HTMLEncode(logMessage)), blog_introLine))
Else
logIntro = closeUBB(CutStr(CheckStr(HTMLEncode(logMessage)), blog_introChar))
End If
Else
logIntro = closeHTML(SplitLines(CheckStr(logMessage), blog_introLine))
End If
End If
'日志基本状态
logIsShow = CBool(logIsShow)
logCommentOrder = CBool(logCommentOrder)
logDisableComment = CBool(logDisableComment)
logIsTop = CBool(logIsTop)
logIsDraft = CBool(logIsDraft)
logPwtitle = CBool(logPwtitle)
logPwcomm = CBool(logPwcomm)
logMeta = CBool(logMeta)
'UBB 特别属性
If logDisableSmile = 1 Then logDisableSmile = 1 Else logDisableSmile = 0
If logDisableImage = 1 Then logDisableImage = 1 Else logDisableImage = 0
If logDisableURL = 1 Then logDisableURL = 0 Else logDisableURL = 1
If logDisableKeyWord = 1 Then logDisableKeyWord = 0 Else logDisableKeyWord = 1
If logIntroCustom = 1 Then logIntroCustom = 0 Else logIntroCustom = 1
logUbbFlags = logDisableSmile & "0" & logDisableImage & logDisableURL & logDisableKeyWord & logIntroCustom
If logIsDraft = False Then weblog("log_Modify") = "[本日志由 "&memName&" 于 "&DateToStr(Now(), "Y-m-d H:I A")&" 编辑]"
'If logIsDraft = False And weblog("log_IsDraft")<>logIsDraft Then
'if isajax <> true then
'Conn.Execute("UPDATE blog_Info SET blog_LogNums=blog_LogNums+1")
'Conn.Execute("UPDATE blog_Category SET cate_count=cate_count+1 where cate_ID=" & CheckStr(categoryID))
'end if
'SQLQueryNums = SQLQueryNums + 2
' End If
'Meta特别属性
If logMeta <> true Then
logDescription = FilterHtmlTags(logdescriptionFilt)
Else
logDescription = FilterHtmlTags(logDescription)
End If
If logMeta <> true Then
logKeyWords = CheckStr(TagMeta)
If len(logKeyWords) = 0 Then
logKeyWords = CheckStr(logTitle)
Else
logKeyWords = Replace(Replace(Replace(logKeyWords, ",", "|"), " ", "|"), "|", ",")
End If
End If
If len(logCname) < 1 or logCname = "" or logCname = empty or logCname = null Then
logCname = weblog("log_ID")
End If
weblog("log_Title") = CheckStr(logTitle)
weblog("log_weather") = CheckStr(logWeather)
weblog("log_Level") = CheckStr(logLevel)
weblog("log_From") = CheckStr(logFrom)
weblog("log_FromURL") = CheckStr(logFromURL)
weblog("log_Content") = CheckStr(logMessage)
weblog("log_Intro") = logIntro
weblog("log_CateID") = CheckStr(categoryID)
weblog("log_Tag") = logTags
weblog("log_UbbFlags") = logUbbFlags
weblog("log_IsShow") = logIsShow
weblog("log_IsTop") = logIsTop
weblog("log_PostTime") = PubTime
weblog("log_IsDraft") = logIsDraft
weblog("log_DisComment") = logDisableComment
weblog("log_EditType") = logEditType
weblog("log_ComOrder") = logCommentOrder
weblog("log_Cname")=logCname
weblog("log_Ctype")=logCtype
weblog("log_Readpw") = logReadpw
weblog("log_Pwtips") = logPwtips
weblog("log_Pwtitle") = logPwtitle
weblog("log_Pwcomm") = logPwcomm
weblog("log_Meta") = logMeta
weblog("log_KeyWords") = logKeyWords
weblog("log_Description") = logDescription
SQLQueryNums = SQLQueryNums + 2
weblog.update
weblog.Close
Dim preLog, nextLog
'-------------------输出静态日志档案--------------------
'输出日志到文件
If blog_postFile = 2 Then
dim oldcate,oldctype,oldcname,A,B,C,D
On Error Resume Next
'之前如果调用过request.BinaryRead后，不能直接调用request.form了
'live write 就挂在这里
oldcname = Checkxss(request.form("oldcname"))
oldcate = Checkxss(request.form("oldcate"))
oldctype = Checkxss(request.form("oldtype"))
D = conn.execute("select cate_Part from blog_Category where cate_ID="&oldcate)(0)
A = "article/"&D
If D = "" or len(D) = 0 then
A = "article"
End If
B=oldcname
If oldctype="0" Then
C="htm"
Else
C="html"
End If
If oldcname<>request.Form("Cname") or oldcate<>request.Form("log_CateID") or oldctype<>request.Form("Ctype") Then
DeleteFiles Server.MapPath(A&"/"&B&"."&C)
End If
'用来检查是否有
If Err Then
Err.Clear
End If
if isajax = false then
PostArticle id, False
end if
End If
'输出附近的日志到文件
Set preLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&PubTime&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE log_PostTime>#"&PubTime&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
if isajax = false then
If Not preLog.EOF Then PostArticle preLog("log_ID"), False
If Not nextLog.EOF Then PostArticle nextLog("log_ID"), False
end if
Call updateCache
Session(CookieName&"_LastDo") = "EditArticle"
Session(CookieName&"_draft_"&logAuthor) = conn.Execute("select count(log_ID) from blog_Content where log_Author='"&logAuthor&"' and log_IsDraft=true")(0)
SQLQueryNums = SQLQueryNums + 1
If logIsDraft Then
editLog = Array(1, "日志成功保存为草稿!", id)
Else
editLog = Array(0, "恭喜!日志编辑成功!", id)
End If
'-------------------引用通告-------------------
If logTrackback<>Empty And logIsShow = True And logIsDraft = False Then
Dim log_QuoteEvery, log_QuoteArr
log_QuoteArr = Split(logTrackback, ",")
For Each log_QuoteEvery In log_QuoteArr
Trackback Trim(log_QuoteEvery), siteURL&"default.asp?id="&logid, logTitle, CutStr(CheckStr(logIntro), 252), siteName
Next
End If
if isajax = false then
If blog_postFile = 1 Then
PostHalfStatic id,false
End If
end if
End Function
'*********************************************
'删除日志
'*********************************************
Public Function deleteLog(id)
Dim pcmpad
pcmpad=Alias(id)
deleteLog = Array( -4, "准备删除!")
If IsEmpty(id) Then
getLog = Array( -5, "ID号不能为空!")
Exit Function
End If
If Not IsInteger(id) Then
deleteLog = Array( -1, "非法ID号!")
Exit Function
End If
sqlString = "SELECT top 1 * FROM blog_Content WHERE log_ID="&id&""
weblog.Open sqlString, Conn, 1, 3
SQLQueryNums = SQLQueryNums + 1
If weblog.EOF Or weblog.bof Then
deleteLog = Array( -2, "找不到相应文章!")
Exit Function
End If
If stat_DelAll<>True And (stat_Del And weblog("log_Author") = logAuthor)<>True Then
deleteLog = Array( -3, "没有权限删除!")
Exit Function
End If
Dim Pdate, getTag
Dim tempTags, loadTagString, loadTags, loadTag, getTags, post_Tag
Pdate = weblog("log_PostTime")
Conn.Execute("UPDATE blog_Member SET mem_PostLogs=mem_PostLogs-1 WHERE mem_Name='"&weblog("log_Author")&"'")
If Not weblog("log_IsDraft") Then
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count-1 where cate_ID="&weblog("log_CateID"))
Conn.Execute("UPDATE blog_Info SET blog_LogNums=blog_LogNums-1")
Conn.Execute("update blog_Info set blog_CommNums=blog_CommNums-"&weblog("log_CommNums"))
End If
loadTag = weblog("log_Tag")
Set getTag = New Tag
'清除旧的Tag
If Len(loadTag)>0 Then
loadTag = Replace(loadTag, "}{", ",")
loadTag = Replace(loadTag, "}", "")
loadTag = Replace(loadTag, "{", "")
loadTags = Split(loadTag, ",")
For Each post_tag in loadTags
getTag.Remove post_tag
Next
End If
Call Tags(2)
Set getTag = Nothing
Dim preLog, nextLog
Conn.Execute("DELETE * FROM blog_Content WHERE log_ID="&id)
Conn.Execute("DELETE * FROM blog_Comment WHERE blog_ID="&id)
DeleteFiles Server.MapPath("post/"&logid&".asp")
DeleteFiles Server.MapPath("cache/"&logid&".asp")
DeleteFiles Server.MapPath("cache/c_"&logid&".js")
DeleteFiles Server.MapPath(pcmpad)
Set preLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&Pdate&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime>#"&Pdate&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
'输出附近的日志到文件
If Not preLog.EOF Then PostArticle preLog("log_ID"), False
If Not nextLog.EOF Then PostArticle nextLog("log_ID"), False
SQLQueryNums = SQLQueryNums + 5
weblog.Close
Call updateCache
Session(CookieName&"_LastDo") = "DelArticle"
session(CookieName&"_draft_"&logAuthor) = conn.Execute("select count(log_ID) from blog_Content where log_Author='"&logAuthor&"' and log_IsDraft=true")(0)
SQLQueryNums = SQLQueryNums + 1
deleteLog = Array(0, "删除成功!")
End Function
'*********************************************
'获得日志
'*********************************************
Public Function getLog(id)
Dim getTag
getLog = Array( -3, "准备提取日志!")
If IsEmpty(id) Then
getLog = Array( -4, "ID号不能为空!")
Exit Function
End If
If Not IsInteger(id) Then
getLog = Array( -1, "非法ID号!")
Exit Function
End If
sqlString = "SELECT top 1 log_CateID,log_Author,log_Title,log_EditType,log_UbbFlags,log_Intro,log_weather,log_Level,log_ComOrder,log_DisComment,log_IsShow,log_IsTop,log_IsDraft,log_From,log_FromURL,log_Content,log_Tag,log_PostTime,log_CommNums,log_QuoteNums,log_ViewNums,log_Readpw,log_Pwtips,log_Pwtitle,log_Pwcomm,log_Cname,log_Ctype,log_KeyWords,log_Description,log_Meta FROM blog_Content WHERE log_ID="&id&""
weblog.Open sqlString, Conn, 1, 1
SQLQueryNums = SQLQueryNums + 1
If weblog.EOF Or weblog.bof Then
getLog = Array( -2, "找不到相应文章!")
Exit Function
End If
categoryID = weblog("log_CateID")
logAuthor = weblog("log_Author")
logTitle = weblog("log_Title")
logEditType = weblog("log_EditType")
logIntroCustom = Mid(weblog("log_UbbFlags"), 6, 1)
logIntro = weblog("log_Intro")
logWeather = weblog("log_weather")
logLevel = weblog("log_Level")
logCommentOrder = weblog("log_ComOrder")
logDisableComment = weblog("log_DisComment")
logIsShow = weblog("log_IsShow")
logIsTop = weblog("log_IsTop")
logIsDraft = weblog("log_IsDraft")
logFrom = weblog("log_From")
logFromURL = weblog("log_FromURL")
logDisableImage = Mid(weblog("log_UbbFlags"), 3, 1)
logDisableSmile = Mid(weblog("log_UbbFlags"), 1, 1)
logDisableURL = Mid(weblog("log_UbbFlags"), 4, 1)
logDisableKeyWord = Mid(weblog("log_UbbFlags"), 5, 1)
logMessage = weblog("log_Content")
logCommentCount = weblog("log_CommNums")
logQuoteCount = weblog("log_QuoteNums")
logViewCount = weblog("log_ViewNums")
logCname = weblog("log_Cname")
logCtype = weblog("log_Ctype")
logReadpw = Trim(weblog("log_Readpw"))
logPwtips = weblog("log_Pwtips")
logPwtitle = weblog("log_Pwtitle")
logPwcomm = weblog("log_Pwcomm")
logmeta = weblog("log_Meta")
logKeyWords = weblog("log_KeyWords")
logDescription = weblog("log_Description")
logTrackback = ""
Set getTag = New Tag
logTags = getTag.filterEdit(weblog("log_Tag"))
Set getTag = Nothing
logPubTime = weblog("log_PostTime")
logPublishTimeType = "now"
weblog.Close
getLog = Array(0, "成功获取日志!")
End Function
'*********************************************
'删除文件
'*********************************************
Private Function DeleteFiles(FilePath)
Dim FSO
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FilePath) Then
FSO.DeleteFile FilePath, True
DeleteFiles = True
Else
DeleteFiles = False
End If
Set FSO = Nothing
End Function
'*********************************************
'更新缓存
'*********************************************
Private Sub updateCache
Call Archive(2)
Call CategoryList(2)
Call getInfo(2)
Call NewComment(2)
Call Calendar("", "", "", 2)
If blog_postFile>0 Then
Dim lArticle
Set lArticle = New ArticleCache
lArticle.SaveCache
Set lArticle = Nothing
End If
End Sub
End Class
%>
<%
'======================================================
' PJblog2 静态缓存类
'======================================================
Class ArticleCache
Private cacheList
Private cacheStream
Private errorCode
Private Sub Class_Initialize()
cacheList = ""
End Sub
Private Sub Class_Terminate()
End Sub
Private Function clearT(Str)
Dim tempLen
tempLen = Len(Str)
If tempLen>0 Then
Str = Left(Str, tempLen -1)
End If
clearT = Str
End Function
Private Function LoadIntro(id, Cpart, Cname, Ctype, aisshow, aRight, outType)
Dim getIntro, tempI, TempStr, getC, author
If not IsEmpty(Application(CookieName&"_introCache_"&id)) then
getIntro = Application(CookieName&"_introCache_"&id)
Else
If Cpart = "" or Cpart = empty or Cpart = null or len(Cpart) = 0 then
getIntro = LoadFile("cache/" & id & ".asp")
Else
getIntro = LoadFile("cache/" & id & ".asp")
End If
End If
If getIntro = "error" or getIntro="" Then
If stat_Admin Then
response.Write "编号为[" + id + "]的日志读取失败！建议您重新
编辑 此文章获得新的缓存
![]()
"
End If
If stat_DelAll Or (stat_Del And memName = author) Then
TempStr = TempStr&" | ![]()
"
End If
If CBool(Int(aRight)) Or stat_Admin Or (Not CBool(Int(aRight)) And memName = author) Then
tempI = getIntro(3)
Else
tempI = getIntro(5)
End If
'evio
dim ceeurl,chtml
If Ctype = "0" then
chtml = "htm"
Else
chtml = "html"
End If
chtml="."&chtml
ceeurl=""
If blog_postFile = 2 and aisshow = "True" then
If Cpart = "" or Cpart = empty or Cpart = null or len(Cpart) = 0 then
ceeurl = ceeurl&"article/"&cname&chtml
Else
ceeurl = ceeurl&"article/"&cpart&"/"&cname&chtml
End If
Else
ceeurl = ceeurl&"article.asp?id="&id
End If
tempI = Replace(tempI, "<$log_ceeurl$>", ceeurl)
'evio
tempI = Replace(tempI, "<"&"%Article In PJblog2%"&">", "")
tempI = Replace(tempI, "<$editRight$>", TempStr)
tempI = Replace(tempI, "<$log_viewC$>", getIntro(2))
response.Write tempI
End If
End Function
Private Function LoadFile(ByVal File)
On Error Resume Next
LoadFile = "error"
With cacheStream
.Type = 2
.Mode = 3
.Open
.Charset = "utf-8"
.Position = cacheStream.Size
.LoadFromFile Server.MapPath(File)
If Err Then
.Close
Err.Clear
Exit Function
End If
LoadFile = .ReadText
.Close
End With
End Function
Public Function outHTML(loadType, outType, title)
Dim re, strMatchs, strMatch, i, j, id, aRight, hiddenC , aCpart, aCname, aCtype, aisshow
Set cacheStream = Server.CreateObject("ADODB.Stream")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[""([^\r]*?)"";([^\r]*?);\(([^\r]*?)\)\]"
Set strMatchs = re.Execute(cacheList)
For Each strMatch in strMatchs
If loadType = strMatch.SubMatches(0) Then
Dim aList, pageSize
pageSize = blogPerPage
If outType = "list" Then pageSize = pageSize * 4
aList = Split(strMatch.SubMatches(2), ",")
hiddenC = strMatch.SubMatches(1)
If stat_Admin Or stat_ShowHiddenCate Then hiddenC = 0
If (UBound(aList) + 1 - hiddenC)>0 Then
%>
<%
If outType = "list" Then response.Write ""
i = 0
Do Until i >= pageSize
j = i + (CurPage -1) * pageSize
If j<= UBound(aList) Then
id = Split(aList(j), "|")(1)
aRight = Split(aList(j), "|")(0)
aCpart = Split(aList(j), "|")(2)
aCname = Split(aList(j), "|")(3)
aCtype = Split(aList(j), "|")(4)
aisshow = Split(aList(j), "|")(5)
LoadIntro id, aCpart, aCname, aCtype, aisshow, aRight, outType
i = i + 1
Else
If outType = "list" Then response.Write "
<%=MultiPage(ubound(aList)+1-hiddenC,pageSize,CurPage,Url_Add,"","float:Left","")%>
<%
Exit For
End If
Loop
If outType = "list" Then response.Write ""
%>
<%=MultiPage(ubound(aList)+1-hiddenC,pageSize,CurPage,Url_Add,"","float:Left","")%>
<%
Else
response.Write "抱歉，没有找到任何日志！"
End If
Set re = Nothing
Exit Function
End If
Next
Set re = Nothing
Set cacheStream = Nothing
End Function
Public Function loadCache
Dim LoadList
If blog_postFile<1 Then
loadCache = False
Exit Function
End If
If not isEmpty(Application(CookieName&"_listCache")) then
LoadList = Array(0,Application(CookieName&"_listCache"))
Else
LoadList = LoadFromFile("cache/listCache.asp")
End If
If LoadList(0) = 0 Then
cacheList = LoadList(1)
loadCache = True
Else
loadCache = False
End If
End Function
Public Function SaveCache
If blog_postFile<1 Then Exit Function
Dim LogList, LogListArray, SaveList, CateDic, CateHDic, TagsDic
Set CateDic = Server.CreateObject("Scripting.Dictionary")
Set CateHDic = Server.CreateObject("Scripting.Dictionary")
Set TagsDic = Server.CreateObject("Scripting.Dictionary")
SQL = "select T.log_ID,T.log_CateID,T.log_IsShow,C.cate_Secret,C.cate_part,T.log_Cname,T.log_Ctype FROM blog_Content As T,blog_Category As C where T.log_CateID=C.cate_ID and log_IsDraft=false ORDER BY log_IsTop ASC,log_PostTime DESC"
Set LogList = conn.Execute(SQL)
If LogList.EOF Or LogList.BOF Then
dim temp1
temp1 = "[""A"";0;()]" & Chr(13) & "[""G"";0;()]"
SaveList = SaveToFile(temp1, "cache/listCache.asp")
' If memoryCache = true then
Application.Lock
Application(CookieName&"_listCache") = temp1
Application.UnLock
' End If
Set LogList = Nothing
Exit Function
End If
LogListArray = LogList.GetRows()
Set LogList = Nothing
Dim i, AList, AListC, GList, GListC, outIndex, tempS, tempCS, hiddenC
AList = ""
AListC = 0
GList = ""
GListC = 0
outIndex = ""
For i = 0 To UBound(LogListArray, 2)
tempS = 1
hiddenC = 1
'response.write LogListArray(0,i) & " "
If Not LogListArray(2, i) Then tempS = 0
If Not LogListArray(3, i) Then
tempCS = 0
hiddenC = 0
GList = GList & tempS & "|" & LogListArray(0, i) & "|" & LogListArray(4, i) & "|" & LogListArray(5, i) & "|" & LogListArray(6, i) & "|" & LogListArray(2, i) & ","
GListC = GListC + hiddenC
End If
AList = AList & tempS & "|" & LogListArray(0, i) & "|" & LogListArray(4, i) & "|" & LogListArray(5, i) & "|" & LogListArray(6, i) & "|" & LogListArray(2, i) & ","
AListC = AListC + hiddenC
If Not CateDic.Exists("C"&LogListArray(1, i)) Then
CateDic.Add "C"&LogListArray(1, i), tempS & "|" & LogListArray(0, i) & "|" & LogListArray(4, i) & "|" & LogListArray(5, i) & "|" & LogListArray(6, i) & "|" & LogListArray(2, i) &","
Else
CateDic.Item("C"&LogListArray(1, i)) = CateDic.Item("C"&LogListArray(1, i)) & tempS & "|" & LogListArray(0, i) & "|" & LogListArray(4, i) & "|" & LogListArray(5, i) & "|" & LogListArray(6, i) & "|" & LogListArray(2, i) & ","
End If
If Not CateHDic.Exists("CH"&LogListArray(1, i)) Then
CateHDic.Add "CH"&LogListArray(1, i), hiddenC
Else
CateHDic.Item("CH"&LogListArray(1, i)) = CateHDic.Item("CH"&LogListArray(1, i)) + hiddenC
End If
Next
outIndex = outIndex & "[""A"";"&AListC&";("&clearT(AList)&")] " & Chr(13)
outIndex = outIndex & "[""G"";"&GListC&";("&clearT(GList)&")] " & Chr(13)
Dim CateKeys, CateItems, CateHKeys, CateHItems
CateKeys = CateDic.Keys
CateItems = CateDic.Items
CateHKeys = CateHDic.Keys
CateHItems = CateHDic.Items
For i = 0 To CateDic.Count -1
outIndex = outIndex & "["""&CateKeys(i)&""";"&CateHItems(i)&";("&clearT(CateItems(i))&")] " & Chr(13)
Next
SaveList = SaveToFile(outIndex, "cache/listCache.asp")
' If memoryCache = true then
Application.Lock
Application(CookieName&"_listCache") = outIndex
Application.UnLock
' End If
Set CateDic = Nothing
Set CateHDic = Nothing
Set TagsDic = Nothing
call newEtag
End Function
End Class
%>
<%
'======================================================
' PJblog2 动态文章保存
'======================================================
Sub PostArticle(ByVal LogID, ByVal UpdateListOnly)
If blog_postFile = 1 Then
PostHalfStatic LogID, UpdateListOnly
ElseIf blog_postFile = 2 Then
PostFullStatic LogID, UpdateListOnly
End If
call newEtag
End Sub
'======================================================
'半静态化
'======================================================
Sub PostHalfStatic(ByVal LogID, ByVal UpdateListOnly)
Dim SaveArticle, LoadTemplate1, Temp1, TempStr, log_View, preLogC, nextLogC
'读取日志模块
LoadTemplate1 = LoadFromFile("Template/Article.asp")
If LoadTemplate1(0) <> 0 Then Exit Sub'读取成功后写入信息
'读取分类信息
Temp1 = LoadTemplate1(1)
'读取日志内容
SQL = "SELECT TOP 1 * FROM blog_Content WHERE log_ID=" & LogID
SQLQueryNums = SQLQueryNums + 1
Set log_View = conn.Execute(SQL)
Dim blog_Cate, blog_CateArray, comDesc
Dim getCate, getTags
Set getCate = New Category
Set getTags = New Tag
getCate.load(Int(log_View("log_CateID"))) '获取分类信息
If UpdateListOnly then '只更新列表缓存
PostArticleListCache LogID, log_View, getCate, getTags
Set log_View = Nothing
Set getCate = Nothing
Set getTags = Nothing
exit Sub
End If
Temp1 = Replace(Temp1, "<$Cate_icon$>", getCate.cate_icon)
Temp1 = Replace(Temp1, "<$Cate_Title$>", getCate.cate_Name)
Temp1 = Replace(Temp1, "<$log_CateID$>", log_View("log_CateID"))
Temp1 = Replace(Temp1, "<$LogID$>", LogID)
Temp1 = Replace(Temp1, "<$log_Title$>", HtmlEncode(log_View("log_Title")))
Temp1 = Replace(Temp1, "<$log_Author$>", log_View("log_Author"))
Temp1 = Replace(Temp1, "<$log_PostTime$>", DateToStr(log_View("log_PostTime"), "Y-m-d"))
Temp1 = Replace(Temp1, "<$log_weather$>", log_View("log_weather"))
Temp1 = Replace(Temp1, "<$log_level$>", log_View("log_level"))
Temp1 = Replace(Temp1, "<$log_Author$>", log_View("log_Author"))
Temp1 = Replace(Temp1, "<$log_IsShow$>", log_View("log_IsShow"))
If log_View("log_IsShow") and not getCate.cate_Secret Then
Temp1 = Replace(Temp1, "<$log_hiddenIcon$>", "")
Else
If log_View("log_Readpw") <> "" then
Temp1 = Replace(Temp1, "<$log_hiddenIcon$>", "![]()
")
Else
Temp1 = Replace(Temp1, "<$log_hiddenIcon$>", "![]()
")
End If
End If
If Len(log_View("log_Tag"))>0 Then
Temp1 = Replace(Temp1, "<$log_tag$>", getTags.filterHTML(log_View("log_Tag")))
Else
Temp1 = Replace(Temp1, "<$log_tag$>", "")
End If
If log_View("log_ComOrder") Then comDesc = "Desc" Else comDesc = "Asc" End If
Temp1 = Replace(Temp1, "<$comDesc$>", comDesc)
Temp1 = Replace(Temp1, "<$log_DisComment$>", log_View("log_DisComment"))
If log_View("log_EditType") = 1 Then
Temp1 = Replace(Temp1, "<$ArticleContent$>", UnCheckStr(UBBCode(HtmlEncode(log_View("log_Content")), Mid(log_View("log_UbbFlags"), 1, 1), Mid(log_View("log_UbbFlags"), 2, 1), Mid(log_View("log_UbbFlags"), 3, 1), Mid(log_View("log_UbbFlags"), 4, 1), Mid(log_View("log_UbbFlags"), 5, 1))))
Else
Temp1 = Replace(Temp1, "<$ArticleContent$>", UnCheckStr(log_View("log_Content")))
End If
If Len(log_View("log_Modify"))>0 Then
Temp1 = Replace(Temp1, "<$log_Modify$>", ""&log_View("log_Modify")&"
")
Else
Temp1 = Replace(Temp1, "<$log_Modify$>", "")
End If
Temp1 = Replace(Temp1, "<$log_FromUrl$>", log_View("log_FromUrl"))
Temp1 = Replace(Temp1, "<$log_From$>", log_View("log_From"))
Temp1 = Replace(Temp1, "<$trackback$>", SiteURL&"trackback.asp?tbID="&LogID&"&action=view")
Temp1 = Replace(Temp1, "<$log_CommNums$>", log_View("log_CommNums"))
Temp1 = Replace(Temp1, "<$log_QuoteNums$>", log_View("log_QuoteNums"))
Temp1 = Replace(Temp1, "<$log_IsDraft$>", log_View("log_IsDraft"))
Set preLogC = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&DateToStr(log_View("log_PostTime"), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLogC = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime>#"&DateToStr(log_View("log_PostTime"), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
Dim BTemp,urlLink
BTemp = ""
If Not preLogC.EOF Then
If blog_postFile = 2 then
urlLink = Alias(preLogC("log_ID"))
Else
urlLink = "?id="&preLogC("log_ID")
End If
BTemp = BTemp & "![]()
上一篇"
Else
BTemp = BTemp & "![]()
上一篇"
End If
If Not nextLogC.EOF Then
If blog_postFile = 2 then
urlLink = Alias(nextLogC("log_ID"))
Else
urlLink = "?id="&nextLogC("log_ID")
End If
BTemp = BTemp & " | ![]()
下一篇"
Else
BTemp = BTemp & " | ![]()
下一篇"
End If
Temp1 = Replace(Temp1, "<$log_Navigation$>", BTemp)
SaveArticle = SaveToFile(Temp1, "post/" & LogID & ".asp")
PostArticleListCache LogID, log_View, getCate, getTags
Set log_View = Nothing
Set getCate = Nothing
Set getTags = Nothing
'getCate.cate_Secret or (not log_View("Log_IsShow"))
End Sub
'======================================================
'全静态化
'======================================================
Sub PostFullStatic(ByVal LogID, ByVal UpdateListOnly)
Dim SaveArticle, LoadTemplate1, Temp1, TempStr, log_View, preLogC, nextLogC, Category,baseUrl
'读取日志模块
LoadTemplate1 = LoadFromFile("Template/static.htm")
If LoadTemplate1(0) <> 0 Then Exit Sub'读取成功后写入信息
'静态页面特有的属性
baseUrl = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("URL")
baseUrl = Left(baseUrl, InStrRev(baseUrl,"/"))
'读取分类信息
Temp1 = LoadTemplate1(1)
'读取日志内容
SQL = "SELECT TOP 1 * FROM blog_Content WHERE log_ID=" & LogID
SQLQueryNums = SQLQueryNums + 1
Set log_View = conn.Execute(SQL)
blog_currentCategoryID = log_View("log_CateID")
Dim blog_Cate, blog_CateArray, comDesc, CanRead
Dim getCate, getTags
Set getCate = New Category
Set getTags = New Tag
getCate.load(Int(log_View("log_CateID"))) '获取分类信息
If UpdateListOnly then '只更新列表缓存
PostArticleListCache LogID, log_View, getCate, getTags
Set log_View = Nothing
Set getCate = Nothing
Set getTags = Nothing
exit Sub
End If
If log_View("log_IsShow") = false or getCate.cate_Secret then '如果是私密日志
SaveArticle = SaveToFile(""& vbcrlf &_
"加载私密日志"& vbcrlf &_
""& vbcrlf &_
""& vbcrlf &_
"请稍后...正在加载私密日志
"& vbcrlf &_
"
"& vbcrlf &_
""& vbcrlf &_
"
"&log_View("log_Modify")&"
")
Else
Temp1 = Replace(Temp1, "<$log_Modify$>", "")
End If
Temp1 = Replace(Temp1, "<$log_FromUrl$>", log_View("log_FromUrl"))
Temp1 = Replace(Temp1, "<$log_From$>", log_View("log_From"))
Temp1 = Replace(Temp1, "<$trackback$>", SiteURL&"trackback.asp?tbID="&LogID&"&action=view")
Temp1 = Replace(Temp1, "<$log_CommNums$>", log_View("log_CommNums"))
Temp1 = Replace(Temp1, "<$log_QuoteNums$>", log_View("log_QuoteNums"))
Temp1 = Replace(Temp1, "<$log_IsDraft$>", log_View("log_IsDraft"))
Set preLogC = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&DateToStr(log_View("log_PostTime"), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLogC = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime>#"&DateToStr(log_View("log_PostTime"), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
Dim BTemp
BTemp = ""
If Not preLogC.EOF Then
BTemp = BTemp & "![]()
上一篇"
Else
BTemp = BTemp & "![]()
上一篇"
End If
If Not nextLogC.EOF Then
BTemp = BTemp & " | ![]()
下一篇"
Else
BTemp = BTemp & " | ![]()
下一篇"
End If
Temp1 = Replace(Temp1, "<$log_Navigation$>", BTemp)
createfolder "article/"&getCate.cate_Part
SaveArticle = SaveToFile(Temp1, Alias(LogID))
PostArticleListCache LogID, log_View, getCate , getTags
Set log_View = Nothing
Set getCate = Nothing
Set getTags = Nothing
'getCate.cate_Secret or (not log_View("Log_IsShow"))
End Sub
'======================================================
'缓存静态化列表
'======================================================
Sub PostArticleListCache(ByVal LogID,ByVal log_View,ByVal getCate,ByVal getTags)
Dim LoadTemplate2, Temp2, comDesc, SaveArticle
LoadTemplate2 = LoadFromFile("Template/ArticleList.asp")
If LoadTemplate2(0) <> 0 Then Exit Sub
Temp2 = LoadTemplate2(1)
Temp2 = Replace(Temp2, "<$Cate_icon$>", getCate.cate_icon)
Temp2 = Replace(Temp2, "<$Cate_Title$>", getCate.cate_Name)
Temp2 = Replace(Temp2, "<$log_CateID$>", log_View("log_CateID"))
Temp2 = Replace(Temp2, "<$LogID$>", LogID)
Temp2 = Replace(Temp2, "<$log_Title$>", HtmlEncode(log_View("log_Title")))
Temp2 = Replace(Temp2, "<$log_Author$>", log_View("log_Author"))
Temp2 = Replace(Temp2, "<$log_PostTime$>", DateToStr(log_View("log_PostTime"), "Y-m-d"))
Temp2 = Replace(Temp2, "<$log_viewCount$>", log_View("log_ViewNums"))
'article.asp?id=<$LogID$>
If blog_postFile = 2 and log_View("log_IsShow") and not getCate.cate_Secret Then
Temp2 = Replace(Temp2, "<$pLink$>", Alias(LogID))
Else
Temp2 = Replace(Temp2, "<$pLink$>", "article.asp?id=" & LogID)
End If
If log_View("log_IsTop") Then
Temp2 = Replace(Temp2, "<$ShowButton$>", "")
Temp2 = Replace(Temp2, "<$ShowStyle$>", " style=""display:none""")
Else
Temp2 = Replace(Temp2, "<$ShowButton$>", "")
Temp2 = Replace(Temp2, "<$ShowStyle$>", "")
End If
If log_View("log_IsShow") and not getCate.cate_Secret Then
Temp2 = Replace(Temp2, "<$log_hiddenIcon$>", "")
Else
If log_View("log_Readpw") <> "" Then
Temp2 = Replace(Temp2, "<$log_Secret$>", "该日志是加密日志，需要输入正确密码才可以查看！")
Temp2 = Replace(Temp2, "<$log_hiddenIcon$>", "![]()
")
Else
Temp2 = Replace(Temp2, "<$log_Secret$>", "该日志是私密日志，只有管理员或发布者可以查看！")
Temp2 = Replace(Temp2, "<$log_hiddenIcon$>", "![]()
")
End If
If log_View("log_Pwtitle") = False Then
Temp2 = Replace(Temp2, "<$Show_Title$>", HtmlEncode(log_View("log_Title")))
ElseIf log_View("log_Readpw") <> "" Then
Temp2 = Replace(Temp2, "<$Show_Title$>", "[加密日志]")
Else
Temp2 = Replace(Temp2, "<$Show_Title$>", "[私密日志]")
End If
End If
If Len(log_View("log_Tag"))>0 Then
Temp2 = Replace(Temp2, "<$log_tag$>", "Tags: "&getTags.filterHTML(log_View("log_Tag"))&"
")
Else
Temp2 = Replace(Temp2, "<$log_tag$>", "")
End If
If log_View("log_ComOrder") Then comDesc = "Desc" Else comDesc = "Asc" End If
If log_View("log_EditType") = 1 Then
Temp2 = Replace(Temp2, "<$log_Intro$>", UnCheckStr(UBBCode(log_View("log_Intro"), Mid(log_View("log_UbbFlags"), 1, 1), Mid(log_View("log_UbbFlags"), 2, 1), Mid(log_View("log_UbbFlags"), 3, 1), Mid(log_View("log_UbbFlags"), 4, 1), Mid(log_View("log_UbbFlags"), 5, 1))))
If log_View("log_Intro")<>HtmlEncode(log_View("log_Content")) Then
If blog_postFile = 2 and log_View("log_IsShow") and not getCate.cate_Secret Then
Temp2 = Replace(Temp2, "<$log_readMore$>", "查看更多...
")
Else
Temp2 = Replace(Temp2, "<$log_readMore$>", "查看更多...
")
End If
Else
Temp2 = Replace(Temp2, "<$log_readMore$>", "")
End If
Else
Temp2 = Replace(Temp2, "<$log_Intro$>", UnCheckStr(log_View("log_Intro")))
If log_View("log_Intro")<>log_View("log_Content") Then
If blog_postFile = 2 and log_View("log_IsShow") and not getCate.cate_Secret Then
Temp2 = Replace(Temp2, "<$log_readMore$>", "查看更多...
")
Else
Temp2 = Replace(Temp2, "<$log_readMore$>", "查看更多...
")
End If
Else
Temp2 = Replace(Temp2, "<$log_readMore$>", "")
End If
End If
Temp2 = Replace(Temp2, "<$log_CommNums$>", log_View("log_CommNums"))
Temp2 = Replace(Temp2, "<$log_QuoteNums$>", log_View("log_QuoteNums"))
SaveArticle = SaveToFile(Temp2, "cache/" & LogID & ".asp")
If memoryCache = true then
Application.Lock
Application(CookieName&"_introCache_"&LogID) = Temp2
Application.UnLock
End If
End Sub
'======================================================
'模板文件保存到内存里
'======================================================
Sub LoadTemplateFile(Path)
Dim cache
End Sub
%>
<%
'==================================
' 日志类文件
' 更新时间: 2006-1-22
'==================================
'SQL="SELECT top 1 log_ID,log_CateID,log_title,Log_IsShow,log_ViewNums,log_Author,log_comorder,log_DisComment,log_Content,log_PostTime,log_edittype,log_ubbFlags,log_CommNums,log_QuoteNums,log_weather,log_level,log_Modify,log_FromUrl,log_From,log_tag FROM blog_Content WHERE log_ID="&id&" and log_IsDraft=false"
'row序号: 0 ,1 ,2 ,3 ,4 ,5 ,6 ,7 ,8 ,9 ,10 ,11 ,12 ,13 ,14 ,15 ,16 ,17 ,18 ,19
'*******************************************
' 显示日志内容
'*******************************************
Sub updateViewNums(logID, vNums)
If blog_postFile<1 Then Exit Sub
Dim LoadArticle, splitStr, getA, i, tempStr
splitStr = "<"&"%ST(A)%"&">"
tempStr = ""
LoadArticle = LoadFromFile("cache/"&LogID&".asp")
If LoadArticle(0) = 0 Then
getA = Split(LoadArticle(1), splitStr)
getA(2) = vNums
For i = 1 To UBound(getA)
tempStr = tempStr&splitStr&getA(i)
Next
Call SaveToFile (tempStr, "cache/" & LogID & ".asp")
if memoryCache = true then
Application.Lock
Application(CookieName&"_introCache_"&LogID) = tempStr
Application.UnLock
end if
End If
End Sub
Sub ShowArticle(LogID)
If (log_ViewArr(5, 0) = memName And log_ViewArr(3, 0) = False) Or stat_Admin Or log_ViewArr(3, 0) = True or Trim(log_ViewArr(20, 0)) <> "" Then
Else
showmsg "错误信息", "该日志为私密日志，没有权限查看该日志！
单击返回", "ErrorIcon", ""
End If
If (Not getCate.cate_Secret) Or (log_ViewArr(5, 0) = memName And getCate.cate_Secret) Or stat_Admin Or (getCate.cate_Secret And stat_ShowHiddenCate) Then
Else
showmsg "错误信息", "该日志分类为私密类型，无法查看该日志！
单击返回", "ErrorIcon", ""
End If
If log_ViewArr(6, 0) Then comDesc = "Desc" Else comDesc = "Asc" End If
'是否有权限查看日记
Dim CanRead,CheckReadPW
CanRead = False
CheckReadPW = md5(Trim(Request.form("PW")))
If CheckReadPW = "D41D8CD98F00B204E9800998ECF8427E" Then '空白的md5
CheckReadPW = Session("ReadPassWord_"&LogID)
Else
Session("ReadPassWord_"&LogID) = CheckReadPW
End If
If IsNull(Session("CheckOutErr_"&LogID)) Or IsEmpty(Session("CheckOutErr_"&LogID)) Then Session("CheckOutErr_"&LogID) = 0
If stat_Admin = True Then CanRead = True
If log_ViewArr(3, 0) Then CanRead = True
If log_ViewArr(3, 0) = False And log_ViewArr(5, 0) = memName Then CanRead = True
If Trim(log_ViewArr(20,0)) = CheckReadPW Then CanRead = True
'从文件读取日志
If Trim(log_ViewArr(20, 0)) = "" and blog_postFile>0 Then
Dim LoadArticle, TempStr, TempArticle
LoadArticle = LoadFromFile("post/"&LogID&".asp")
If LoadArticle(0) = 0 Then
TempArticle = LoadArticle(1)
TempStr = ""
If stat_EditAll Or (stat_Edit And memName = log_ViewArr(5, 0)) Then
TempStr = TempStr&"![]()
"
End If
If stat_DelAll Or (stat_Del And memName = log_ViewArr(5, 0)) Then
TempStr = TempStr&"![]()
"
End If
TempArticle = Replace(TempArticle, "<"&"%ST(A)%"&">", "")
TempArticle = Replace(TempArticle, "<$EditAndDel$>", TempStr)
TempArticle = Replace(TempArticle, "<$log_ViewNums$>", log_ViewArr(4, 0))
response.Write TempArticle
ShowComm LogID, comDesc, log_ViewArr(7, 0), False, log_ViewArr(3, 0), log_ViewArr(23,0), CanRead
Call updateViewNums(id, log_ViewArr(4, 0))
Else
response.Write "读取日志出错.
" & LoadArticle(0) & " : " & LoadArticle(1)
End If
Exit Sub
End If
'从数据库读取日志
'on error resume Next
Set preLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime<#"&DateToStr(log_ViewArr(9, 0), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime DESC")
Set nextLog = Conn.Execute("SELECT TOP 1 T.log_Title,T.log_ID FROM blog_Content As T,blog_Category As C WHERE T.log_PostTime>#"&DateToStr(log_ViewArr(9, 0), "Y-m-d H:I:S")&"# and T.log_CateID=C.cate_ID and (T.log_IsShow=true or T.log_Readpw<>'') and C.cate_Secret=False and T.log_IsDraft=false ORDER BY T.log_PostTime ASC")
SQLQueryNums = SQLQueryNums + 2
%>
<%
If Not preLog.EOF Then
if blog_postFile = 2 then
urlLink = caload(preLog("log_ID"))
else
urlLink = "?id="&preLog("log_ID")
end if
response.Write ("
![]()
上一篇")
Else
response.Write ("
![]()
上一篇")
End If
If Not nextLog.EOF Then
if blog_postFile = 2 then
urlLink = caload(nextLog("log_ID"))
else
urlLink = "?id="&nextLog("log_ID")
end if
response.Write (" |
![]()
下一篇")
Else
response.Write (" |
![]()
下一篇")
End If
preLog.Close
nextLog.Close
Set preLog = Nothing
Set nextLog = Nothing
%>
<%=getCate.cate_Name%> 
<%If CanRead Then%>
<%=HtmlEncode(log_ViewArr(2, 0))%>
<% Else %>
<%If log_ViewArr(22, 0) = False then%><%=HtmlEncode(log_ViewArr(2, 0))%><%ElseIf Trim(log_ViewArr(20, 0)) <> "" Then%>[加密日志]<%Else%>[私密日志]<%End If%>
<% End If %>
<%if log_ViewArr(3, 0)=False or getCate.cate_Secret then%>
<%If Trim(log_ViewArr(20, 0)) <> "" Then%>
<%Else%>
<%End If%>
<%end if%>
作者:<%=log_ViewArr(5,0)%> 日期:<%=DateToStr(log_ViewArr(9,0),"Y-m-d")%>
<%If CanRead Then '密码访问
keyword = CheckStr(Request.QueryString("keyword"))
If log_ViewArr(10, 0) = 1 Then
response.Write (highlight(UnCheckStr(UBBCode(HtmlEncode(log_ViewArr(8, 0)), Mid(log_ViewArr(11, 0), 1, 1), Mid(log_ViewArr(11, 0), 2, 1), Mid(log_ViewArr(11, 0), 3, 1), Mid(log_ViewArr(11, 0), 4, 1), Mid(log_ViewArr(11, 0), 5, 1))), keyword))
Else
response.Write (highlight(UnCheckStr(log_ViewArr(8, 0)), keyword))
End If
Else
%>
该日志是加密日志，需要输入正确密码才可以查看！
<%if Session("CheckOutErr_"&LogID) >=2 Then '超出范围%>
抱歉，您输入的验证次数已超过最大的次数，日志暂时锁定！
<%
Else
dim pwTips
pwTips = Trim(log_ViewArr(21,0))
%>
<%end if%>
<%
End If
%>
<%if len(log_ViewArr(16,0))>0 then response.write ("
"&log_ViewArr(16,0)&"
")%>
文章来自: <%=log_ViewArr(18,0)%>
引用通告: " target="_blank">查看所有引用 |
我要引用此文章
<%Dim getTag
Set getTag = New tag
%>
Tags: <%=getTag.filterHTML(log_ViewArr(19,0))%>
相关日志:
评论: <%=log_ViewArr(12,0)%> | 引用: <%=log_ViewArr(13,0)%> | 查看次数: <%=log_ViewArr(4,0)%>
<%Set getTag = Nothing
ShowComm LogID, comDesc, log_ViewArr(7, 0), False, log_ViewArr(3, 0), log_ViewArr(23,0), CanRead '显示评论内容
End Sub
'*******************************************
' 显示日志评论内容
'*******************************************
Function ShowComm(ByVal LogID,ByVal comDesc, ByVal DisComment, ByVal forStatic, ByVal logShow, ByVal logPwcomm, ByVal CanRead)
ShowComm = ""
ShowComm = ShowComm&""
Dim blog_Comment, Pcount, comm_Num, blog_CommID, blog_CommAuthor, blog_CommContent, Url_Add, commArr, commArrLen,BaseUrl,aName,aEvent
Set blog_Comment = Server.CreateObject("Adodb.RecordSet")
Pcount = 0
BaseUrl = ""
aEvent = ""
' 带 trackback 的查询
' SQL = "SELECT comm_ID,comm_Content,comm_Author,comm_PostTime,comm_DisSM,comm_DisUBB,comm_DisIMG,comm_AutoURL,comm_PostIP,comm_AutoKEY FROM blog_Comment WHERE blog_ID="&LogID&" UNION ALL SELECT 0,tb_Intro,tb_Title,tb_PostTime,tb_URL,tb_Site,tb_ID,0,'127.0.0.1',0 FROM blog_Trackback WHERE blog_ID="&LogID&" ORDER BY comm_PostTime "&comDesc
' 不带 trackback 的查询，速度较快
SQL = "SELECT comm_ID,comm_Content,comm_Author,comm_PostTime,comm_DisSM,comm_DisUBB,comm_DisIMG,comm_AutoURL,comm_PostIP,comm_AutoKEY FROM blog_Comment WHERE blog_ID="&LogID&" ORDER BY comm_PostTime "&comDesc
blog_Comment.Open SQL, Conn, 1, 1
SQLQueryNums = SQLQueryNums + 1
If (blog_Comment.EOF And blog_Comment.BOF) or (logPwcomm = True and CanRead = False) Then
Else
blog_Comment.PageSize = blogcommpage
blog_Comment.AbsolutePage = CurPage
comm_Num = blog_Comment.RecordCount
commArr = blog_Comment.GetRows(comm_Num)
blog_Comment.Close
Set blog_Comment = Nothing
commArrLen = UBound(commArr, 2)
Url_Add = "?id="&LogID&"&"
aName = "#comm_top"
If blog_postFile = 2 and logShow then '静态页面使用#方式来切换
BaseUrl = caload(LogID)
Url_Add="#"
aName = ""
aEvent = "onclick=""openCommentPage(this)"""
End If
'顶部翻页
ShowComm = ShowComm&""&MultiPage(comm_Num,blogcommpage,CurPage,Url_Add,aName,"float:right", BaseUrl,aEvent)&"
"
'显示评论
Do Until Pcount = commArrLen + 1 Or Pcount = blogcommpage
blog_CommID = commArr(0, Pcount)
blog_CommAuthor = commArr(2, Pcount)
blog_CommContent = commArr(1, Pcount)
ShowComm = ShowComm&"![]()
回复"
ShowComm = ShowComm&"
![]()
"
ShowComm = ShowComm&"
"&blog_CommAuthor&""
ShowComm = ShowComm&"
["&DateToStr(commArr(3,Pcount),"Y-m-d H:I A")&" | ![]()
]"
'删除按钮
' if stat_Admin=true or (stat_CommentDel=true and memName=blog_CommAuthor) then
' response.write (" |
![]()
")
' end if
'ShowComm = ShowComm&"
"
'评论内容
ShowComm = ShowComm&"
"&UBBCode(HtmlEncode(blog_CommContent),commArr(4,Pcount),blog_commUBB,blog_commIMG,commArr(7,Pcount),commArr(9,Pcount))&"
"
Pcount = Pcount + 1
Loop
'底部的翻页
ShowComm = ShowComm&"
"&MultiPage(comm_Num,blogcommpage,CurPage,Url_Add,aName,"float:right" ,BaseUrl,aEvent)&"
"
End If
If not forStatic Then
Response.write ShowComm
'输出发表评论框
Call showCommentPost(logID,DisComment,logPwcomm,CanRead)
End IF
End Function
'===============
' 输出发表评论框
'===============
Sub ShowCommentPost(ByVal logID, ByVal DisComment, ByVal logPwcomm, ByVal CanRead)
If DisComment Then
Exit Sub
End IF
%>
发表评论
<%
If Not stat_CommentAdd Then
response.Write ("你没有权限发表评论！")
response.Write ("
")
Exit Sub
End If
If logPwcomm = True and CanRead = False Then
response.Write ("该日志需要输入正确密码方可发表和查看评论！")
response.Write ("
<%response.Write ("")
end Sub
%>
[an error occurred while processing this directive]
<%
'======================================
' XML-RPC for PJBlog
'======================================
'ȡBlogϢ
getInfo(1)
'дؼб
Keywords(1)
'д
Smilies(1)
'дǩ
Tags(1)
Response.Charset = "UTF-8"
Response.ContentType = "text/xml"
Response.Expires = 60
Response.Buffer = True
Dim DebugOn
DebugOn = False
XmlBin = Request.BinaryRead(Request.TotalBytes)
SaveToFile bin2str(XmlBin),"debug\out_"&randomStr(3)&"_"&Year(now)&Month(now)&Day(now)&Hour(now)&Minute(now)&Second(now)&".txt"
Dim xmlPrc, XmlBin
Set xmlPrc = New PXML
If DebugOn Then
xmlPrc.xmlPath = "out.xml"
xmlPrc.Open()
Else
xmlPrc.OpenXML(XmlBin)
End If
If xmlPrc.getError = 0 Then
Dim strAction
Dim userName, passWord, intPosts, bolPublish, logTitle, logDescription, logPostTime, logCategories, tagWords, logCategoryId, logID, fileBits, fileName,logIntro
strAction = xmlPrc.SelectXmlNodeText("methodName")
Select Case strAction
Case "blogger.getUsersBlogs":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
login2 userName, passWord
If stat_Admin Then Call getUsersBlogs() Else Call returnError(0, "permitted to get Users Blogs.")
Case "metaWeblog.getCategories":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
login2 userName, passWord
If stat_Admin Then Call getCategories() Else Call returnError(0, "permitted to get Categories.")
Case "mt.getCategoryList":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
login2 userName, passWord
If stat_Admin Then Call getCategories() Else Call returnError(0, "permitted to get Categories.")
Case "mt.getPostCategories":
if xmlPrc.GetXmlNodeLength("params/param[0]/value/string")>0 then
logID=xmlPrc.SelectXmlNodeText("params/param[0]/value/string")
else
logID=xmlPrc.SelectXmlNodeText("params/param[0]/value/struct/member[name=""PostID""]/value")
end if
if len(toInt(logID))<1 then Call returnError(0,"parameter error.")
logID=int(toInt(logID))
userName=xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord=xmlPrc.SelectXmlNodeText("params/param[2]/value")
login2 userName,passWord
if stat_Admin then Call getPostCategories(logID) else Call returnError(0,"permitted to get post categories.")
Case "metaWeblog.getRecentPosts":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
intPosts = xmlPrc.SelectXmlNodeText("params/param[3]/value/int")
If intPosts = 0 Then
intPosts = xmlPrc.SelectXmlNodeText("params/param[3]/value/i4")
End If
login2 userName, passWord
If stat_Admin Then Call getRecentPosts(intPosts) Else Call returnError(0, "permitted to get Recent Posts.")
Case "metaWeblog.newPost":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
logTitle = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""title""]/value")
logDescription = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""description""]/value")
logPostTime = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""dateCreated""]/value/dateTime.iso8601")
'tagWords=xmlPrc.GetXmlNodeLength("params/param[3]/value/struct/member[name=""tagwords""]/value/array/data/value")
'֧windows live writerĹؼֺZoundryıǩ
tagWords=xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""mt_keywords""]/value")
logIntro=xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""mt_excerpt""]/value")
bolPublish = xmlPrc.SelectXmlNodeText("params/param[4]/value/boolean")
login2 userName, passWord
If stat_Admin Then Call newPost(logTitle, logDescription,logIntro,logPostTime, tagWords, bolPublish ) Else Call returnError(0, "permitted to post a new log.")
Case "metaWeblog.editPost":
If xmlPrc.GetXmlNodeLength("params/param[0]/value/string")>0 Then
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/string")
Else
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/struct/member[name=""PostID""]/value")
End If
If Len(toInt(logID))<1 Then Call returnError(0, "parameter error.")
logID = Int(toInt(logID))
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
logTitle = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""title""]/value")
logDescription = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""description""]/value")
logPostTime = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""dateCreated""]/value/dateTime.iso8601")
tagWords=xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""mt_keywords""]/value")
logIntro=xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""mt_excerpt""]/value")
'tagWords=xmlPrc.GetXmlNodeLength("params/param[3]/value/struct/member[name=""tagwords""]/value/array/data/value")
bolPublish = xmlPrc.SelectXmlNodeText("params/param[4]/value/boolean")
login2 userName, passWord
If stat_Admin Then Call editPost(logID, logTitle, logDescription,logIntro, logPostTime,tagWords, bolPublish) Else Call returnError(0, "permitted to post a new log.")
Case "mt.setPostCategories":
If xmlPrc.GetXmlNodeLength("params/param[0]/value/string")>0 Then
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/string")
Else
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/struct/member[name=""PostID""]/value")
End If
If Len(toInt(logID))<1 Then Call returnError(0, "parameter error.")
logID = Int(toInt(logID))
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
logCategoryId = xmlPrc.SelectXmlNodeText("params/param[3]/value/array/data/value[0]/struct/member[name=""categoryId""]/value")
login2 userName, passWord
If stat_Admin Then Call setPostCategories(logID, logCategoryId) Else Call returnError(0, "permitted to set post categories.")
Case "metaWeblog.getPost":
If xmlPrc.GetXmlNodeLength("params/param[0]/value/string")>0 Then
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/string")
Else
logID = xmlPrc.SelectXmlNodeText("params/param[0]/value/struct/member[name=""PostID""]/value")
End If
If Len(toInt(logID))<1 Then Call returnError(0, "parameter error.")
logID = Int(toInt(logID))
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
login2 userName, passWord
If stat_Admin Then Call getPost(logID) Else Call returnError(0, "permitted to set post categories.")
Case "metaWeblog.newMediaObject":
userName = xmlPrc.SelectXmlNodeText("params/param[1]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[2]/value")
fileBits = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""bits""]/value")
fileName = xmlPrc.SelectXmlNodeText("params/param[3]/value/struct/member[name=""name""]/value")
login2 userName, passWord
If stat_Admin Then Call newMediaObject(fileName, fileBits) Else Call returnError(0, "permitted to upload file.")
Case "blogger.deletePost":
If xmlPrc.GetXmlNodeLength("params/param[1]/value/string")>0 Then
logID = xmlPrc.SelectXmlNodeText("params/param[1]/value/string")
Else
logID = xmlPrc.SelectXmlNodeText("params/param[1]/value/struct/member[name=""PostID""]/value")
End If
If Len(toInt(logID))<1 Then Call returnError(0, "parameter error.")
logID = Int(toInt(logID))
userName = xmlPrc.SelectXmlNodeText("params/param[2]/value")
passWord = xmlPrc.SelectXmlNodeText("params/param[3]/value")
login2 userName, passWord
If stat_Admin Then Call deletePost(logID) Else Call returnError(0, "permitted to delete log.")
Case Else
xmlPrc.CloseXml()
Call returnError(0, strAction)
End Select
Else
xmlPrc.CloseXml()
Call returnError(0, "action Error2.")
End If
'=================Function In XML-PRC=========================
'----------------------return response Error---------------------------
Function returnError(faultCode, faultString)
Response.Clear
Response.Write ""
Response.Write ""
Response.Write "faultCode"&faultCode&""
Response.Write "faultString"&faultString&""
Response.Write ""
Response.Write ""
Response.End
End Function
'----------------------blogger.getUsersBlogs---------------------------
Function getUsersBlogs()
Response.Clear
Response.Write ""
Response.Write ""
Response.Write "url"
Response.Write "blogid"
Response.Write "blogName"
Response.Write ""
Response.End
End Function
'----------------------metaWeblog.getRecentPosts---------------------------
Function getRecentPosts(intNum)
Dim RecentPosts
Dim RS, dbRow, i
SQL = "SELECT TOP "&intNum&" L.log_ID,L.log_Title,L.log_Author,L.log_Content,L.log_PostTime,L.log_edittype,C.cate_Name,L.log_IsDraft FROM blog_Content AS L,blog_Category AS C WHERE C.cate_ID=L.log_cateID ORDER BY L.log_PostTime DESC"
Set RS = Conn.Execute(SQL)
If RS.EOF Or RS.BOF Then
ReDim dbRow(0, 0)
Else
dbRow = RS.getrows()
End If
RS.Close
Set RS = Nothing
Call CloseDB
RecentPosts = ""
If UBound(dbRow, 1)<>0 Then
For i = 0 To UBound(dbRow, 2)
RecentPosts = RecentPosts & ""
RecentPosts = RecentPosts & "title"
If dbRow(5, i) = 1 Then
t = AddSiteURL(UBBCode(HTMLEncode(dbRow(3, i)), 0, 0, 0, 1, 1))
RecentPosts = RecentPosts & "description"
Else
t = AddSiteURL(UnCheckStr(dbRow(3, i)))
RecentPosts = RecentPosts & "description"
End If
RecentPosts = RecentPosts & "dateCreated"&DateToStr(dbRow(4, i), "y-m-dTH:I:S")&""
RecentPosts = RecentPosts & "categories"&dbRow(6, i)&""
RecentPosts = RecentPosts & "tagwords"
RecentPosts = RecentPosts & "postid"
RecentPosts = RecentPosts & "userid"
RecentPosts = RecentPosts & "link"
RecentPosts = RecentPosts & "permaLink"
RecentPosts = RecentPosts & ""
Next
End If
RecentPosts = RecentPosts & ""
'SaveToFile RecentPosts,"debug\recent2_"&randomStr(3)&"_"&Year(now)&Month(now)&Day(now)&Hour(now)&Minute(now)&Second(now)&".txt"
Response.Clear
Response.Write RecentPosts
End Function
'----------------------metaWeblog.getPost---------------------------
Function getPost(lID)
Dim RecentPosts,getLog,lArticle
Set lArticle = New logArticle
getLog = lArticle.getLog(lID)
If getLog(0)<0 Then
Call returnError(0, "Can't find log.")
Set RecentPosts = nothing
Call CloseDB
exit Function
End If
' SQL = "SELECT TOP 1 L.log_ID,L.log_Title,L.log_Author,L.log_Content,L.log_PostTime,L.log_edittype,C.cate_Name,L.log_IsDraft FROM blog_Content AS L,blog_Category AS C WHERE C.cate_ID=L.log_cateID And L.log_ID="&lID&" ORDER BY L.log_PostTime DESC"
RecentPosts = ""
RecentPosts = RecentPosts & ""
RecentPosts = RecentPosts & "title"
If lArticle.logEditType = 1 Then
t = AddSiteURL(UBBCode(HTMLEncode(lArticle.logMessage), 0, 0, 0, 1, 1))
RecentPosts = RecentPosts & "description"
Else
t = AddSiteURL(UnCheckStr(lArticle.logMessage))
RecentPosts = RecentPosts & "description"
End If
RecentPosts = RecentPosts & "dateCreated"&DateToStr(lArticle.logPubTime, "y-m-dTH:I:S")&""
RecentPosts = RecentPosts & "categories"&lArticle.categoryID&""
RecentPosts = RecentPosts & "mt_keywords"
if not CBool(lArticle.logIntroCustom) then
RecentPosts = RecentPosts & "mt_excerpt"
else
RecentPosts = RecentPosts & "mt_excerpt"
end if
RecentPosts = RecentPosts & "postid"
RecentPosts = RecentPosts & "userid"
RecentPosts = RecentPosts & "link"
RecentPosts = RecentPosts & "permaLink"
RecentPosts = RecentPosts & ""
RecentPosts = RecentPosts & ""
response.Write RecentPosts
Call CloseDB
End Function
'----------------------mt.getCategoryList/metaWeblog.getCategories---------------------------
Function getCategories()
Dim Categories
Categories = ""
Dim Arr_Category, Category_Len, i
CategoryList(3)
Arr_Category = Application(CookieName&"_blog_Category")
If UBound(Arr_Category, 1) = 0 Then Call returnError(0, "no Categories")
Category_Len = UBound(Arr_Category, 2)
For i = 0 To Category_Len
If Not Arr_Category(4, i) Then
Categories = Categories & ""
Categories = Categories & "description"
Categories = Categories & "httpUrl"
Categories = Categories & "rssUrl"
Categories = Categories & "title"
Categories = Categories & "categoryId"
Categories = Categories & "categoryName"
Categories = Categories & ""
End If
Next
Categories = Categories & ""
Response.Write Categories
End Function
'----------------------metaWeblog.newPost---------------------------
Function newPost(lTitle, lDescription,lIntro, lPostTime, lTagwords, lPublish)
'====get Last Category
Dim Arr_Category, Category_Len, i, lastCID
CategoryList(1)
Arr_Category = Application(CookieName&"_blog_Category")
If UBound(Arr_Category, 1) = 0 Then Call returnError(0, "no Categories")
Category_Len = UBound(Arr_Category, 2)
For i = 0 To Category_Len
If Not Arr_Category(4, i) Then
lastCID = Arr_Category(0, i)
Exit For
End If
Next
Dim newPostStr
Dim lArticle, postLog
Set lArticle = New logArticle
lArticle.categoryID = lastCID
lArticle.logTitle = lTitle
lArticle.logEditType = 0
lArticle.logIsDraft = Not CBool(lPublish)
lArticle.logMessage = lDescription
lArticle.logPubTime = Now()
lArticle.logTags = lTagwords
if len(Trim(lIntro))>0 then
lArticle.logIntroCustom = 1
lArticle.logIntro = lIntro
else
lArticle.logIntroCustom = 0
end if
lArticle.logAuthor = memName
postLog = lArticle.postLog
Set lArticle = Nothing
If postLog(2)<0 Then
Call returnError(0, postLog(1))
Else
newPostStr = ""
newPostStr = newPostStr & ""&postLog(2)&""
newPostStr = newPostStr & ""
response.Write newPostStr
End If
End Function
'----------------------metaWeblog.editPost---------------------------
Function editPost(lID, lTitle, lDescription,lIntro, lPostTime, lTagwords,lPublish)
'====get Last Category
Dim editPostStr
Dim lArticle, editLog
Set lArticle = New logArticle
editLog = lArticle.getLog(lID)
If editLog(0)<0 Then Call returnError(0, "Can't find log.")
lArticle.logTitle = lTitle
lArticle.logEditType = 0
lArticle.logIsDraft = Not CBool(lPublish)
lArticle.logMessage = lDescription
lArticle.logPubTime = Now()
if len(Trim(lIntro))>0 then
lArticle.logIntroCustom = 1
lArticle.logIntro = lIntro
else
lArticle.logIntroCustom = 0
end if
lArticle.logTags = lTagwords
editLog = lArticle.editLog(lID)
Set lArticle = Nothing
If editLog(2)<0 Then
Call returnError(0, editLog(1))
Else
editPostStr = ""
editPostStr = editPostStr & ""
editPostStr = editPostStr & "PostID"&editLog(2)&""
editPostStr = editPostStr & ""
editPostStr = editPostStr & ""
response.Write editPostStr
End If
End Function
'----------------------mt.setPostCategories---------------------------
Function setPostCategories(lID, lCID)
Dim returnStr
Dim lArticle, editLog
Set lArticle = New logArticle
editLog = lArticle.getLog(lID)
Set lArticle = Nothing
If editLog(0)<0 Then
Call returnError(0, "Can't find log.")
Else
If IsInteger(lCID) Then
Dim lastCID
lastCID = conn.Execute("select top 1 log_cateID from blog_Content where log_ID="&lID)(0)
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count-1 where cate_ID="&lastCID)
Conn.Execute("UPDATE blog_Category SET cate_count=cate_count+1 where cate_ID="&lCID)
Conn.Execute("UPDATE blog_Content SET log_cateID="&lCID&" where log_ID="&lID)
End If
If blog_postFile>0 Then
Set lArticle = New ArticleCache
lArticle.SaveCache
Set lArticle = Nothing
PostArticle lID, False
End If
returnStr = "1"
response.Write returnStr
End If
End Function
Function deletePost(lID)
Dim lArticle, DeleteLog, returnStr
Set lArticle = New logArticle
DeleteLog = lArticle.deleteLog(lID)
Set lArticle = Nothing
If DeleteLog(0) = 0 Then
returnStr = "1"
response.Write returnStr
Else
Call returnError(0, "Can't delete log.")
End If
End Function
'----------------------metaWeblog.newMediaObject"--------------------------
Function newMediaObject(fName, fBits)
'On Error Resume Next
If stat_FileUpLoad = False Then Call returnError(0, "permitted to upload file.")
Dim upl, FSOIsOK
FSOIsOK = 1
Set upl = Server.CreateObject("Scripting.FileSystemObject")
If Err<>0 Then
Err.Clear
Set upl = Nothing
Call returnError(0, "Can't create folder.")
End If
Dim D_Name
D_Name = "month_"&DateToStr(Now(), "ym")
If upl.FolderExists(Server.MapPath("attachments/"&D_Name)) = False Then
upl.CreateFolder Server.MapPath("attachments/"&D_Name)
End If
Dim FileExt, i
FileExt = ""
For i = Len(fName) To 1 step -1
If Mid(fName, i, 1) = "." Then Exit For
FileExt = Mid(fName, i, 1) & FileExt
Next
Dim tStream, base64M
Set base64M = New base64
Set tStream = Server.CreateObject("adodb.stream")
tStream.Type = 1
tStream.Mode = 3
tStream.Open
tStream.Position = 0
tStream.Write base64M.decode(fBits)
If tStream.Size > Int(UP_FileSize) Then
tStream.Close
Set tStream = Nothing
Set base64M = Nothing
Call returnError(0, "permitted to upload file.")
End If
If IsvalidFile(UCase(FixName(FileExt))) = False Then
tStream.Close
Set tStream = Nothing
Set base64M = Nothing
Call returnError(0, "permitted to upload file.")
End If
Dim fullPath
fName = randomStr(1)&Year(Now)&Month(Now)&Day(Now)&Hour(Now)&Minute(Now)&Second(Now)&"."&FileExt
fullPath = "attachments/"&D_Name&"/"&fName
tStream.SaveToFile Server.MapPath(fullPath)
If Err<>0 Then
tStream.Close
Set tStream = Nothing
Set base64M = Nothing
Call returnError(0, Err.Description)
Err.Clear
End If
tStream.Close
Set tStream = Nothing
Set base64M = Nothing
response.Write "url"&fullPath&""
End Function
'----------------------mt.getPostCategories---------------------------
Function getPostCategories(lID)
dim RecentPosts
Dim RS,dbRow,i
SQL="Select TOP 1 L.log_ID,L.log_Title,L.log_Author,L.log_Content,L.log_PostTime,L.log_edittype,C.cate_Name,L.log_IsDraft,C.cate_ID FROM blog_Content AS L,blog_Category AS C Where C.cate_ID=L.log_cateID And L.log_ID="&lID&" orDER BY L.log_PostTime DESC"
Set RS=Conn.ExeCute(SQL)
if RS.EOF or RS.BOF then
ReDim dbRow(0,0)
Call returnError(0,"Can't find log.")
else
dbRow=RS.getrows()
end if
RS.close
set RS=nothing
call CloseDB
RecentPosts=""
i=0
RecentPosts = RecentPosts & ""
RecentPosts = RecentPosts & "categoryId"
RecentPosts = RecentPosts & "categoryName"
RecentPosts = RecentPosts & ""
RecentPosts = RecentPosts & ""
response.write RecentPosts
End Function
'------------------------------------------------------------------
Function bin2str(binstr)
Dim varlen, clow, ccc, skipflag, i
'ַSkip־
skipflag = 0
ccc = ""
If Not IsNull(binstr) Then
varlen = LenB(binstr)
For i = 1 To varlen
If skipflag = 0 Then
clow = MidB(binstr, i, 1)
'жǷĵַ
If AscB(clow)>127 Then
'AscWѶƵ˫ַֽλ͵λתҪȰĵĸߵλת
ccc =ccc & Chr(AscW(MidB(binstr,i+1,1) & clow))
skipflag = 1
Else
ccc = ccc & Chr(AscB(clow))
End If
Else
skipflag = 0
End If
Next
End If
bin2str = ccc
End Function
Function AddSiteURL(ByVal Str)
If IsNull(Str) Then
AddSiteURL = ""
Exit Function
End If
Dim re
Set re = New RegExp
With re
.IgnoreCase = True
.Global = True
.Pattern = "![]()
47 And Asc(Mid(Str, i, 1))<58 Then
tmS = tmS&Mid(Str, i, 1)
End If
Next
toInt = tmS
End Function
'=====================base64 encode/decode==============
Class base64
Private objXmlDom
Private objXmlNode
Private Sub Class_Initialize()
Set objXmlDom = Server.CreateObject(getXMLDOM())
End Sub
Private Sub Class_Terminate()
Set objXmlDom = Nothing
End Sub
Public Function encode(AnsiCode)
encode = ""
Set objXmlNode = objXmlDom.createElement("file")
objXmlNode.datatype = "bin.base64"
objXmlNode.nodeTypedvalue = AnsiCode
encode = objXmlNode.text
Set objXmlNode = Nothing
End Function
Public Function decode(base64Code)
decode = ""
Set objXmlNode = objXmlDom.createElement("file")
objXmlNode.datatype = "bin.base64"
objXmlNode.text = base64Code
decode = objXmlNode.nodeTypedvalue
Set objXmlNode = Nothing
End Function
End Class
%>
%>.gif)
%>.gif)
%>.gif)
<%if stat_EditAll or (stat_Edit and log_ViewArr(5,0)=memName) then %> 
<%end if%>
<%if stat_DelAll or (stat_Del and log_ViewArr(5,0)=memName) then %> 
<%end if%>