<%@ 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)
%>
<%
'==================================
' Blog插件参数调用页面
' 更新时间: 2005-10-28
'==================================
'读取Blog设置信息
getInfo(1)
'使用界面
Skins = blog_DefaultSkin
'客户端自选界面Cookie
If Len(Request.Cookies(CookieNameSetting)("BlogSkin"))>0 Then Skins = Request.Cookies(CookieNameSetting)("BlogSkin")
If Len(Skins)<1 Then Skins = "default"
'验证用户登录信息
checkCookies
'读取用户权限
UserRight(1)
'写入标签
Tags(1)
'写入表情符号
Smilies(1)
'写入关键字列表
Keywords(1)
'写入自定义模块缓存
log_module(1)
'禁止IP访问
If MatchIP(getIP) Then
response.Write "Blog不欢迎你的访问。"
response.End
End If
Side_Module_Replace '处理系统侧栏模块信息
%>
<%
'===============================================================
' 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, "
")
If Not DisIMG = 1 Then
re.Pattern = "\[html\](.*?)\[\/html\]"
Set strMatchs = re.Execute(strContent)
For Each strMatch in strMatchs
Randomize
rndID = "temp"&Int(100000 * Rnd)
strContent = Replace(strContent, strMatch.Value, "
HTML代码
[Ctrl+A 全部选择 提示：你可先修改部分代码，再按运行]
", 1, -1, 0)
Next
Set strMatchs = Nothing
End If
'-----------List标签----------------
strContent = Replace(strContent, "[list]", "
")
'-----------表情图标----------------
If Not DisSM = 1 Then
Dim log_Smilies, log_SmiliesContent
For Each log_Smilies IN Arr_Smilies
log_SmiliesContent = Split(log_Smilies, "|")
strContent = Replace(strContent, log_SmiliesContent(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
%>
<%
'***************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 = "
"&C_Year&"年"&C_Month&"月
"
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 & "
"&DayStr&"
"
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&"
"
End If
DayCount = DayCount + 1
S_Date = DateAdd("d", 1, S_Date)
Loop
Calendar = Calendar & "
"
End Function
'**********************************************
'用户面板
'**********************************************
Function userPanel()
userPanel = ""
If memName<>Empty Then userPanel = userPanel&" "&memName&"，欢迎你! 你的权限: "&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
%>
<%
'***************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&"
"
Exit Function
End If
Category_Len = UBound(Arr_Category, 2)
Dim cClass,URL,inMod
URL = request.ServerVariables("script_name")
inMod = inStrRev(URL,"LoadMod.asp",-1,1)
For i = 0 To Category_Len
If Int(Arr_Category(9, i)) = 0 Or Int(Arr_Category(9, i)) = 1 Then
CategoryList = CategoryList&Menu_Diver
If Arr_Category(4, i) Then '自定义链接
If CBool(Arr_Category(10, i)) Then
If stat_ShowHiddenCate Or stat_Admin Then CategoryList = CategoryList&"
"
Else
cClass = "menuA"
if isEmpty(blog_currentCategoryID) and InStrRev(URL,Arr_Category(5,i),-1,1) then
cClass = "menuA menuB"
end if
if inMod then
if inStrRev(Arr_Category(5,i),Request.QueryString("plugins"),-1,1) then
cClass = "menuA menuB"
end if
end if
CategoryList = CategoryList&"
"
End If
End If
Menu_Diver = ""
End If
Next
CategoryList = CategoryList&"
"
End If
If action = 1 Then
CategoryList = ""
If UBound(Arr_Category, 1) = 0 Then Exit Function
Category_Len = UBound(Arr_Category, 2)
For i = 0 To Category_Len
If Int(Arr_Category(9, i)) = 0 Or Int(Arr_Category(9, i)) = 2 Then
If Arr_Category(4, i) Then
If CBool(Arr_Category(10, i)) Then
If stat_ShowHiddenCate Or stat_Admin 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 blog_module("IndexOnly") = False Then
side_html = side_html&"
"
If Len(blog_module("title"))>0 Then side_html = side_html&"
"&blog_module("title")&"
"
side_html = side_html&"
"&blog_module("HtmlCode")&"
"
End If
If blog_module("IsSystem") = True Then
side_html_static = side_html_static&"
"
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")&"
"
End If
End If
If blog_module("type") = "content" And blog_module("name")<>"ContentList" Then
If blog_module("SortID")<0 Then
content_html_Top_default = content_html_Top_default&"
"&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
%>
<%
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
%>
<%
'=================================================
' XML Class for PJBlog2
' Author: PuterJam
' UpdateDate: 2006-1-19
'=================================================
Class PXML
Public XmlPath
Private errorcode
Public XMLDocument
Private Sub Class_Initialize()
errorcode = -1
End Sub
Private Sub Class_Terminate()
End Sub
'------------------------------------------------
'函数名字：Open()
'Open=0，XMLDocument就是一个成功装载XML文档的对象了。
'------------------------------------------------
Public Function Open()
Dim strSourceFile, strError, xmlDom
xmlDom = getXMLDOM()
If xmlDom = False Then
errorcode = -18239123
Exit Function
End If
Set XMLDocument = Server.CreateObject(xmlDom)
XMLDocument.async = False
strSourceFile = Server.MapPath(XmlPath)
XMLDocument.load(strSourceFile)
errorcode = XMLDocument.parseerror.errorcode
End Function
'------------------------------------------------
'函数名字：OpenXML()
'Open=0，XMLDocument就是一个成功装载XML文档的对象了。
'------------------------------------------------
Public Function OpenXML(xmlStr)
Dim strSourceFile, strError, xmlDom
xmlDom = getXMLDOM()
If xmlDom = False Then
errorcode = -18239123
Exit Function
End If
Set XMLDocument = Server.CreateObject(getXMLDOM())
XMLDocument.async = False
XMLDocument.load(xmlStr)
errorcode = XMLDocument.parseerror.errorcode
End Function
'------------------------------------------------
'函数名字：getError()
'------------------------------------------------
Public Function getError()
getError = errorcode
End Function
'------------------------------------------------
'函数名字：CloseXml()
'------------------------------------------------
Public Function CloseXml()
If IsObject(XMLDocument) Then
Set XMLDocument = Nothing
End If
End Function
'------------------------------------------------
'SelectXmlNodeText(elementname)
'获得当个 elementname 元素
'------------------------------------------------
Public Function SelectXmlNodeText(elementname)
Dim xmlItems
selectXmlNodeText = ""
Set xmlItems = XMLDocument.getElementsByTagName(elementname)
If xmlItems.Length <> 0 Then selectXmlNodeText = xmlItems.Item(0).text
End Function
'------------------------------------------------
'SelectXmlNode(elementname,itemID)
'获得当个 elementname 元素
'------------------------------------------------
Public Function SelectXmlNode(elementname, itemID)
Set SelectXmlNode = XMLDocument.getElementsByTagName(elementname).Item(itemID)
End Function
'------------------------------------------------
'GetXmlNodeLength(elementname)
'获得当个 elementname 元素的Length值
'------------------------------------------------
Public Function GetXmlNodeLength(elementname)
GetXmlNodeLength = XMLDocument.getElementsByTagName(elementname).Length
End Function
'------------------------------------------------
'GetAttributes(elementname,nodeName,ID)
'获得当个 elementname 元素的attributes值
'------------------------------------------------
Public Function GetAttributes(elementname, nodeName, itemID)
Dim XmlAttributes, i
Set XmlAttributes = XMLDocument.getElementsByTagName(elementname).Item(itemID).Attributes
For i = 0 To XmlAttributes.Length -1
If XmlAttributes(i).Name = nodeName Then
GetAttributes = XmlAttributes(i).Value
Exit Function
End If
Next
GetAttributes = 0
End Function
'------------------------------------------------
'SelectXmlNodeItemText(elementname,ID)
'获得当个某 elementname 元素的Length值
'------------------------------------------------
Public Function SelectXmlNodeItemText(elementname, ID)
Dim xmlItems
SelectXmlNodeItemText = ""
Set xmlItems = XMLDocument.getElementsByTagName(elementname)
If xmlItems.Length <> 0 Then SelectXmlNodeItemText = xmlItems.Item(ID).text
End Function
'------------------------------------------------
'WriteXmlNodeItemText(elementname,ID)
'写入当个某 elementname 元素的text值
'------------------------------------------------
Public Function WriteXmlNodeItemText(elementname, ID, Str)
WriteXmlNodeItemText = 0
Dim temp, temp1
Set temp = XMLDocument.getElementsByTagName(elementname).Item(ID)
temp.childNodes(0).text = Str
XMLDocument.save Server.MapPath(XmlPath)
End Function
'------------------------------------------------
'IsXmlNode(elementname)
'检测是否存在 elementname 元素
'True代表存在,False代表不存在
'------------------------------------------------
Public Function IsXmlNode(elementname)
Dim Temp
IsXmlNode = True
Set Temp = XMLDocument.getElementsByTagName(elementname)
If Temp.Length = 0 Then
IsXmlNode = False
End If
End Function
End Class
%>
<%
'==================================
' Blog顶部
' 更新时间: 2005-10-23
'==================================
'=========================Funciton In Head=============================
'处理标题
Dim BlogTitle
BlogTitle = siteName & "-" & blog_Title
If InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/default.asp")<>0 Then
'备用做304优化
' Dim clientEtag, serverEtag
' serverEtag = getEtag
' clientEtag = Request.ServerVariables("HTTP_IF_NONE_MATCH")
' Response.AddHeader "ETag", getEtag
' if serverEtag = clientEtag then
' Response.Status = "304 Not Modified"
' Session.CodePage = 936
' Call CloseDB
' Response.end
' end if
Dim Tid
If CheckStr(Request.QueryString("id"))<>Empty Then
Tid = CheckStr(Request.QueryString("id"))
End If
If Len(Tid)>0 Then
Dim rUrl
If blog_postFile = 2 Then
rUrl = caload(Tid)
else
rUrl = "article.asp?id=" & Tid
end if
RedirectUrl (rUrl)
Response.end
End If
End If
If InStr(Replace(LCase(Request.ServerVariables("URL")), "\", "/"), "/article.asp") = 0 Then
getBlogHead BlogTitle, "", -1, "", ""
End If
'输出文件头
Sub getBlogHead(Title, CateTitle, CategoryID, KeyWords, Description)
If len(KeyWords) > 0 then blog_KeyWords = KeyWords
If len(Description) > 0 then blog_Description = Description
'高亮分类for首页
If IsInteger(cateID) = True Then
blog_currentCategoryID = cateID
End If
'高亮分类for日志单篇
If IsInteger(CategoryID) = True and CategoryID<>-1 Then
blog_currentCategoryID = CategoryID
End If
%>
<%=Title%>
<%if len(CateTitle)>0 and CategoryID>0 then %>
<%else%>
<%end if%>
<%getSkinFlash%>
<%=siteName%>
<%=blog_Title%>
<%=CategoryList(0)%>
<%
End Sub
'读取Flash导航条
Dim SkinInfo
Sub getSkinFlash
If CheckObjInstalled(getXMLDOM()) Then
Dim SkinXML
Set SkinXML = New PXML
SkinInfo = ""
SkinXML.XmlPath = "skins/"&Skins&"/skin.xml"
SkinXML.Open
If SkinXML.getError = 0 Then
SkinInfo = " , " & SkinXML.SelectXmlNodeText("SkinName") & " Design By " & SkinXML.SelectXmlNodeText("SkinDesigner") & ""
Dim useFlash
useFlash = SkinXML.SelectXmlNodeText("Flash/UseFlash")
If useFlash = "" Then useFlash = "false"
If CBool(useFlash) Then
%>
<%
End If
SkinXML.CloseXml
Set SkinXML = Nothing
'合作信息
SkinInfo = SkinInfo & " "
End If
End If
End Sub
%>
<%
'==================================
' 信息显示页面
' 更新时间: 2005-10-18
'==================================
If Not session(CookieName&"_ShowMsg") Then
RedirectUrl("default.asp")
End If
session(CookieName&"_ShowMsg") = False
%>
<%
Session.CodePage = 936
Session(CookieName&"_LastDo") = "" '最近的一次数据库操作
'Session(CookieName&"_LastDo")返回值说明
'DelComment 删除评论
'AddComment 添加评论
'EditUser 用户编辑个人资料
'RegisterUser 新用户注册
'AddArticle 添加新日志
'EditArticle 编辑日志
'DelArticle 删除日志
'DelMessage 删除留言 (需要留言本插件支持)
'AddMessage 添加留言 (需要留言本插件支持)
Call CloseDB
%>