<%@ 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
%>
<%
'===========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
%>
<%
Response.ContentType = "application/xml; charset=UTF-8"
'读取Blog设置信息
getInfo(1)
%>
PJBlog3 v<%=blog_version%>
http://www.pjhome.net
<%=siteURL%>