<%@ 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 域，必须修改，否则可能运行不正常 Const CookieName="XINLINGBlog" Const CookieNameSetting="XINLINGBlogSetting" Const IPViewURL="http://www.dheart.net/ip/index.php?ip=" 'IP查询网站地址 Response.Cookies(CookieNameSetting).Expires=Date+365 '站点开关操作 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 '定义数据库链接文件，根据自己的情况修改 Const AccessFile="db#xinling.asp" '定义数据库连接 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 OR Curpage<0 Then Curpage=1 Else Curpage=1 End If %> <% '***************PJblog2 连接数据库******************* ' PJblog2 Copyright 2005 ' Update:2005-9-2 '*************************************************** 'IF Not IsObject(Application(CookieName&"_blog_Conn")) Then on error resume next Set Conn= Server.CreateObject("ADODB.Connection") Conn.ConnectionString="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(AccessFile) Conn.Open If Err Then err.Clear Set Conn = Nothing Response.Write("
数据库连接出错，请检查连接字串!
") Response.End end if 'Else ' Set Conn=Application(CookieName&"_blog_Conn") 'End IF %> <% '================================== ' 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 %> <% '=============================================================== ' Function For PJblog2 ' 更新时间: 2006-6-2 '=============================================================== '************************************* '防止外部提交 '************************************* function ChkPost() dim server_v1,server_v2 chkpost=false server_v1=Cstr(Request.ServerVariables("HTTP_REFERER")) server_v2=Cstr(Request.ServerVariables("SERVER_NAME")) If Mid(server_v1,8,Len(server_v2))<>server_v2 then chkpost=False else chkpost=True end If end function '************************************* 'IP过滤 '************************************* function MatchIP(IP) on error resume next 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 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) on error resume next 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 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), " ") 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), " ") 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)) 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 MultiPage(Numbers,Perpage,Curpage,Url_Add,aname,Style) CurPage=Int(Curpage) Numbers=Int(Numbers) Dim URL URL=Request.ServerVariables("Script_Name")&Url_Add MultiPage="" Dim Page,Offset,PageI ' If Int(Numbers)>Int(PerPage) Then Page=9 Offset=4 Dim Pages,FromPage,ToPage If Numbers Mod Cint(Perpage)=0 Then Pages=Int(Numbers/Perpage) Else Pages=Int(Numbers/Perpage)+1 End If FromPage=Curpage-Offset ToPage=Curpage+Page-Offset-1 If Page>Pages Then FromPage=1 ToPage=Pages Else If FromPage<1 Then Topage=Curpage+1-FromPage FromPage=1 If (ToPage-FromPage)Pages Then FromPage =Curpage-Pages +ToPage ToPage=Pages If (ToPage-FromPage)" ' End If FirstShortCut=true End Function '************************************* '切割内容 - 按行分割 '************************************* 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 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 Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="\[quote\](.[^\]]*?)\[\/quote\]" strContent= re.Replace(strContent,"") re.Pattern="\[quote=(.[^\]]*)\](.[^\]]*?)\[\/quote\]" strContent= re.Replace(strContent,"") 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","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,"") On Error Resume Next Set objStream = Server.CreateObject("ADODB.Stream") If Err Then RText=array(Err.Number,Err.Description) LoadFromFile=RText Err.Clear exit function End If With objStream .Type = 2 .Mode = 3 .Open .Charset = "utf-8" .Position = objStream.Size .LoadFromFile Server.MapPath(File) If Err.Number<>0 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,"") On Error Resume Next Set objStream = Server.CreateObject("ADODB.Stream") If Err Then RText=array(Err.Number,Err.Description) Err.Clear exit function End If With objStream .Type = 2 .Open .Charset = "utf-8" .Position = objStream.Size .WriteText = strBody .SaveToFile Server.MapPath(File),2 .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 '************************************* '检测系统组件是否安装 '************************************* Function CheckObjInstalled(strClassString) On Error Resume Next Dim Temp Err = 0 Dim TmpObj Set TmpObj = Server.CreateObject(strClassString) Temp = Err IF Temp = 0 OR Temp = -2147221477 Then CheckObjInstalled=true ElseIF Temp = 1 OR Temp = -2147221005 Then CheckObjInstalled=false End IF Err.Clear Set TmpObj = Nothing Err = 0 End Function '************************************* '判断服务器Microsoft.XMLDOM '************************************* Function getXMLDOM On Error Resume Next Dim Temp getXMLDOM="Microsoft.XMLDOM" Err = 0 Dim TmpObj Set TmpObj = Server.CreateObject(getXMLDOM) Temp = Err IF Temp = 1 OR Temp = -2147221005 Then getXMLDOM="Msxml2.DOMDocument.5.0" End IF Err.Clear Set TmpObj = Nothing Err = 0 end function '************************************* '判断服务器MSXML2.ServerXMLHTTP '************************************* Function getXMLHTTP On Error Resume Next Dim Temp getXMLHTTP="MSXML2.ServerXMLHTTP" Err = 0 Dim TmpObj Set TmpObj = Server.CreateObject(getXMLHTTP) Temp = Err IF Temp = 1 OR Temp = -2147221005 Then getXMLHTTP="Msxml2.ServerXMLHTTP.5.0" End IF Err.Clear Set TmpObj = Nothing Err = 0 end function '************************************* '检查插件是否成功安装 '************************************* Function Checkplugins Dim PlugS,Plug,PlugItem Checkplugins=-1 PlugS=Split(function_Plugin,"$*$") For Each Plug In PlugS PlugItem = Split(Plug,"%|%") If Getplugins=PlugItem(0) Then Checkplugins=PlugItem Exit Function End If Next End Function '************************************* '显示帮助信息 '************************************* sub showmsg(title,des,icon,showType) on error resume next Conn.close set Conn=nothing Err.Clear 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 Response.Redirect("../../showmsg.asp") else Response.Redirect("showmsg.asp") end if end sub '************************************* '垃圾关键字过滤 '************************************* function filterSpam(str,path) on error resume next filterSpam = false dim spamXml,spamItem Set spamXml = Server.CreateObject(getXMLDOM) If Err Then Err.clear exit function end if 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 Encrypt(theNumber) On Error Resume Next Dim n, szEnc, t, HiN, LoN, i n = CDbl((theNumber + 1570) ^ 2 - 7 * (theNumber + 1570) - 450) If n < 0 Then szEnc = "R" Else szEnc = "J" n = CStr(abs(n)) For i = 1 To Len(n) step 2 t = Mid(n, i, 2) If Len(t) = 1 Then szEnc = szEnc & t Exit For End If HiN = (CInt(t) And 240) / 16 LoN = CInt(t) And 15 szEnc = szEnc & Chr(Asc("M") + HiN) & Chr(Asc("C") + LoN) Next Encrypt = szEnc End Function Function Decrypt(theNumber) On Error Resume Next Dim e, n, sign, t, HiN, LoN, NewN, i e = theNumber If Left(e, 1) = "R" Then sign = -1 Else sign = 1 e = Mid(e, 2) NewN = "" For i = 1 To Len(e) step 2 t = Mid(e, i, 2) If Asc(t) >= Asc("0") And Asc(t) <= Asc("9") Then NewN = NewN & t Exit For End If HiN = Mid(t, 1, 1) LoN = Mid(t, 2, 1) HiN = (Asc(HiN) - Asc("M")) * 16 LoN = Asc(LoN) - Asc("C") t = CStr(HiN or LoN) If Len(t) = 1 Then t = "0" & t NewN = NewN & t Next e = CDbl(NewN) * sign Decrypt = CLng((7 + sqr(49 - 4 * (-450 - e))) / 2 - 1570) 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 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,"

"&TitleText&"
在线播放
") Next Set strMatchs=nothing re.Pattern="(\[mid\])(.[^\]]*)\[\/mid\]" strContent= re.Replace(strContent,"") '-----------常规标签---------------- re.Pattern = "\[url=(.[^\]]*)\](.[^\[]*)\[\/url]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) tmpStr2=strMatch.SubMatches(1) strContent=replace(strContent,strMatch.Value,""&tmpStr2&"",1,-1,0) Next re.Pattern = "\[url](.[^\[]*)\[\/url]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) strContent=replace(strContent,strMatch.Value,""&tmpStr1&"",1,-1,0) Next re.Pattern = "\[ed2k=([^\r]*?)\]([^\r]*?)\[\/ed2k]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) tmpStr2=strMatch.SubMatches(1) strContent=replace(strContent,strMatch.Value,""&tmpStr2&"",1,-1,0) Next re.Pattern = "\[ed2k]([^\r]*?)\[\/ed2k]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) strContent=replace(strContent,strMatch.Value,""&tmpStr1&"",1,-1,0) Next re.Pattern = "\[email=(.[^\]]*)\](.[^\[]*)\[\/email]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) tmpStr2=strMatch.SubMatches(1) strContent=replace(strContent,strMatch.Value,""&tmpStr2&"",1,-1,0) Next re.Pattern = "\[email](.[^\[]*)\[\/email]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) strContent=replace(strContent,strMatch.Value,""&tmpStr1&"",1,-1,0) Next '-----------字体格式---------------- re.Pattern="\[align=(\w{4,6})\]([^\r]*?)\[\/align\]" strContent=re.Replace(strContent,"
$2
") re.Pattern="\[color=(#\w{3,10}|\w{3,10})\]([^\r]*?)\[\/color\]" strContent=re.Replace(strContent,"$2") re.Pattern="\[size=(\d{1,2})\]([^\r]*?)\[\/size\]" strContent=re.Replace(strContent,"$2") re.Pattern="\[font=([^\r]*?)\]([^\r]*?)\[\/font\]" strContent=re.Replace(strContent,"$2") re.Pattern="\[b\]([^\r]*?)\[\/b\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[i\]([^\r]*?)\[\/i\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[u\]([^\r]*?)\[\/u\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[s\]([^\r]*?)\[\/s\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[sup\]([^\r]*?)\[\/sup\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[sub\]([^\r]*?)\[\/sub\]" strContent=re.Replace(strContent,"$1") re.Pattern="\[fly\]([^\r]*?)\[\/fly\]" strContent=re.Replace(strContent,"$1") End IF '-----------特殊标签---------------- re.Pattern = "\[down=(.[^\]]*)\](.[^\[]*)\[\/down]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) tmpStr2=strMatch.SubMatches(1) strContent=replace(strContent,strMatch.Value," "&tmpStr2&"",1,-1,0) Next re.Pattern = "\[down\](.[^\[]*)\[\/down]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) strContent=replace(strContent,strMatch.Value," 下载此文件",1,-1,0) Next re.Pattern = "\[mDown=(.[^\]]*)\](.[^\[]*)\[\/mDown]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) tmpStr2=strMatch.SubMatches(1) if len(memName)>0 then strContent=replace(strContent,strMatch.Value," "&tmpStr2&"",1,-1,0) else strContent=replace(strContent,strMatch.Value," 该文件只允许会员下载! 登录 | 注册",1,-1,0) end if Next re.Pattern = "\[mDown\](.[^\[]*)\[\/mDown]" Set strMatchs=re.Execute(strContent) For Each strMatch in strMatchs tmpStr1=checkURL(strMatch.SubMatches(0)) if len(memName)>0 then strContent=replace(strContent,strMatch.Value," 下载此文件",1,-1,0) else strContent=replace(strContent,strMatch.Value," 该文件只允许会员下载! 登录 | 注册",1,-1,0) end if Next re.Pattern="\[code\](.*?)\[\/code\]" strContent= re.Replace(strContent,"
程序代码
$1
") re.Pattern="\[quote\](.*?)\[\/quote\]" strContent= re.Replace(strContent,"
引用内容
$1
") re.Pattern="\[quote=(.[^\]]*)\](.*?)\[\/quote\]" strContent= re.Replace(strContent,"
引用来自 $1
$2
") re.Pattern="\[hidden\](.*?)\[\/hidden\]" if len(memName)>0 then strContent= re.Replace(strContent,"
显示被隐藏内容
$1
") else strContent= re.Replace(strContent,"
隐藏内容
该内容已经被作者隐藏,只有会员才允许查阅 登录 | 注册
") end if re.Pattern="\[hidden=(.[^\]]*)\](.*?)\[\/hidden\]" if len(memName)>0 then strContent= re.Replace(strContent,"
显示被隐藏内容来自 $1
$2
") else strContent= re.Replace(strContent,"
隐藏内容
该内容已经被作者隐藏,只有会员才允许查阅 登录 | 注册
") end if 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 '-----------List标签---------------- strContent = Replace(strContent,"[list]","") end if if action=1 then Category_code="" if ubound(Arr_Category,1)=0 then exit Sub 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 Category_code=Category_code&(""&Arr_Category(1,i)&"
") else Category_code=Category_code&(""&Arr_Category(1,i)&"
") end if else if cbool(Arr_Category(10,i)) then if stat_ShowHiddenCate or stat_Admin then Category_code=Category_code&(""&Arr_Category(1,i)&" ["&Arr_Category(7,i)&"]
") else Category_code=Category_code&(""&Arr_Category(1,i)&" ["&Arr_Category(7,i)&"]
") end if end if end if Next end if End Sub '========================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]) Desc" 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 if ubound(blog_archive,1)=0 then archive="":exit function Month_array=Array("一月","二月","三月","四月","五月","六月","七月","八月","九月","十月","十一月","十二月") archive_item_Len=ubound(blog_archive,2) For i=0 to archive_item_Len archive=archive&""&blog_archive(1,i)&"年"&Month_array(blog_archive(2,i)-1)&" ["&blog_archive(0,i)&"]" 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 Comment_Item_Len=ubound(blog_Comment,2) For i=0 to Comment_Item_Len 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,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="" '普通页面侧栏代码 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 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 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) 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)) '普通页面侧栏代码 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 %> <% 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 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 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 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 Private XMLMorntekDocument Private Sub Class_Initialize() errorcode=-1 end sub Private Sub Class_Terminate() end sub '------------------------------------------------ '函数名字：Open() 'Open=0，XMLMorntekDocument就是一个成功装载XML文档的对象了。 '------------------------------------------------ Public function Open() on error resume next dim strSourceFile,strError Set XMLMorntekDocument = Server.CreateObject(getXMLDOM) If Err Then errorcode=-18239123 Err.clear exit function end if XMLMorntekDocument.async = false strSourceFile = Server.MapPath(XmlPath) XMLMorntekDocument.load(strSourceFile) errorcode=XMLMorntekDocument.parseerror.errorcode end function '------------------------------------------------ '函数名字：OpenXML() 'Open=0，XMLMorntekDocument就是一个成功装载XML文档的对象了。 '------------------------------------------------ Public function OpenXML(xmlStr) on error resume next dim strSourceFile,strError Set XMLMorntekDocument = Server.CreateObject(getXMLDOM) If Err Then errorcode=-18239123 Err.clear exit function end if XMLMorntekDocument.async = false XMLMorntekDocument.load(xmlStr) errorcode=XMLMorntekDocument.parseerror.errorcode end function '------------------------------------------------ '函数名字：getError() '------------------------------------------------ Public function getError() getError=errorcode end function '------------------------------------------------ '函数名字：CloseXml() '------------------------------------------------ Public function CloseXml() if IsObject(XMLMorntekDocument) then set XMLMorntekDocument=nothing end if end function '------------------------------------------------ 'SelectXmlNodeText(elementname) '获得当个 elementname 元素 '------------------------------------------------ Public function SelectXmlNodeText(elementname) on error resume next dim temp temp=XMLMorntekDocument.getElementsByTagName(elementname).item(0).text selectXmlNodeText= temp if err then selectXmlNodeText=0 end function '------------------------------------------------ 'SelectXmlNode(elementname,itemID) '获得当个 elementname 元素 '------------------------------------------------ Public function SelectXmlNode(elementname,itemID) dim temp set temp=XMLMorntekDocument.getElementsByTagName(elementname).item(itemID) set SelectXmlNode= temp end function '------------------------------------------------ 'GetXmlNodeLength(elementname) '获得当个 elementname 元素的Length值 '------------------------------------------------ Public function GetXmlNodeLength(elementname) on error resume next dim XmlLength XmlLength=XMLMorntekDocument.getElementsByTagName(elementname).length GetXmlNodeLength= XmlLength if err then GetXmlNodeLength=0 end function '------------------------------------------------ 'GetAttributes(elementname,nodeName,ID) '获得当个 elementname 元素的attributes值 '------------------------------------------------ Public function GetAttributes(elementname,nodeName,itemID) dim XmlAttributes,i set XmlAttributes=XMLMorntekDocument.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) on error resume next dim temp temp=XMLMorntekDocument.getElementsByTagName(elementname).item(ID).text SelectXmlNodeItemText= temp if err then SelectXmlNodeItemText="" end function '------------------------------------------------ 'WriteXmlNodeItemText(elementname,ID) '写入当个某 elementname 元素的text值 '------------------------------------------------ Public function WriteXmlNodeItemText(elementname,ID,str) on error resume next WriteXmlNodeItemText=0 dim temp,temp1 set temp=XMLMorntekDocument.getElementsByTagName(elementname).item(ID) temp.childNodes(0).text=str XMLMorntekDocument.save Server.MapPath(XmlPath) if err then WriteXmlNodeItemText=err.Description end function '------------------------------------------------ 'IsXmlNode(elementname) '检测是否存在 elementname 元素 'True代表存在,False代表不存在 '------------------------------------------------ Public function IsXmlNode(elementname) dim Temp IsXmlNode=true on error resume next Temp=XMLMorntekDocument.getElementsByTagName(elementname).item(0).text if err>0 then err.clear 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 dim Tid If CheckStr(Request.QueryString("id"))<>Empty Then Tid=CheckStr(Request.QueryString("id")) End If if len(Tid)>0 then Response.Redirect ("article.asp?id="&Tid) end if if inStr(Replace(Lcase(Request.ServerVariables("URL")),"\","/"),"/article.asp")=0 then getBlogHead BlogTitle,"",-1 end if '输出文件头 sub getBlogHead(Title,CateTitle,CateID) %> <%=Title%> <%if len(CateTitle)>0 and CateID>0 then %> <%else%> <%end if%> <%getSkinFlash%>
<% end sub 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") & "" if CBool(SkinXML.SelectXmlNodeText("Flash/UseFlash")) then %>
;top:<%=SkinXML.SelectXmlNodeText("Flash/FlashTop")%>px">
<% end if SkinXML.CloseXml set SkinXML=nothing end if end if end sub %> <% '================================================= ' moduleSetting Class for PJBlog2 ' Author: PuterJam ' UpdateDate: 2005-7-31 '================================================= Class ModSet Private ModSetArray Private ModName Private state Private Sub Class_Initialize() end sub Private Sub Class_Terminate() end sub '================================================= ' 打开模块Open(ModName) '================================================= Public Function Open(LoadName) ModName=LoadName IF Not IsArray(Application(CookieName&"_Mod_"&ModName))Then state=-18902 ReLoad() Else ModSetArray=Application(CookieName&"_Mod_"&ModName) state=0 End If End Function '================================================= ' 从数据库里重新读取模块到缓存ReLoad() '================================================= Public Function ReLoad() If ModName="" Then state=-18901:Exit Function Dim ModDB,KeyLen,i,GetPlugPath i=0 KeyLen= conn.Execute("select count(*) from blog_ModSetting where set_ModName='"&ModName&"'")(0) Set ModDB=conn.Execute("select * from blog_ModSetting where set_ModName='"&ModName&"'") ReDim ModSetArray(KeyLen,1) Do Until ModDB.eof ModSetArray(i,0)=ModDB("set_KeyName") ModSetArray(i,1)=ModDB("set_KeyValue") i=i+1 ModDB.movenext Loop ModSetArray(KeyLen,0)="PlugingPath" set GetPlugPath=conn.Execute("select InstallFolder from blog_module where name='"&ModName&"'") if GetPlugPath.eof then state=-18903 exit function else ModSetArray(KeyLen,1)=GetPlugPath(0) end if Application.Lock Application(CookieName&"_Mod_"&ModName)=ModSetArray Application.UnLock state=0 End Function '================================================= ' 读取字段名称getKeyValue(KeyName) '================================================= Public Function getKeyValue(KeyName) Dim KeysLen,i getKeyValue="" KeysLen=UBound(ModSetArray,1) For i=0 To KeysLen If ModSetArray(i,0)=KeyName Then getKeyValue=ModSetArray(i,1) Exit Function End If Next End Function '================================================= ' 获得出错信息ReLoad() '================================================= Public Function PasreError PasreError=state ' -18901 没有打开模块 ' -18902 缓存里没有任何信息 ' -18903 没有安装插件 End Function '================================================= ' 获得插件所在路径 '================================================= Public Function GetPath Dim KeysLen,i GetPath="" KeysLen=UBound(ModSetArray,1) GetPath=ModSetArray(KeysLen,1) End Function '================================================= ' 清除插件占用的 Application 地址 '================================================= Public Function RemoveApplication Application.Lock Application.Contents.Remove(CookieName&"_Mod_"&ModName) Application.UnLock End Function end Class %> <%'---- ASPCode For AboutMeForPJBlog ----%> <%'---- ASPCode For GuestBookForPJBlog ----%> <%'---- ASPCode For GuestBookForPJBlogSubItem1 ----%> <% function NewMessage(ByVal action) Dim blog_Message IF Not IsArray(Application(CookieName&"_blog_Message")) or action=2 Then Dim book_Messages,book_Message Set book_Messages=Conn.Execute("SELECT top 10 * FROM blog_book order by book_PostTime Desc") SQLQueryNums=SQLQueryNums+1 TempVar="" Do While Not book_Messages.EOF if book_Messages("book_HiddenReply") then book_Message=book_Message&TempVar&book_Messages("book_ID")&"|,|"&book_Messages("book_Messager")&"|,|"&book_Messages("book_PostTime")&"|,|"&"[隐藏留言]" else book_Message=book_Message&TempVar&book_Messages("book_ID")&"|,|"&book_Messages("book_Messager")&"|,|"&book_Messages("book_PostTime")&"|,|"&book_Messages("book_Content") end if TempVar="|$|" book_Messages.MoveNext Loop Set book_Messages=Nothing blog_Message=Split(book_Message,"|$|") Application.Lock Application(CookieName&"_blog_Message")=blog_Message Application.UnLock Else blog_Message=Application(CookieName&"_blog_Message") End IF if action<>2 then dim Message_Items,Message_Item For Each Message_Items IN blog_Message Message_Item=Split(Message_Items,"|,|") NewMessage=NewMessage&""&CCEncode(CutStr(Message_Item(3),25))&"" Next end if end function '处理最新留言内容 Dim Message_code if Session(CookieName&"_LastDo")="DelMessage" or Session(CookieName&"_LastDo")="AddMessage" then NewMessage(2) Message_code=NewMessage(0) side_html_default=replace(side_html_default,"<$NewMsg$>",Message_code) side_html=replace(side_html,"<$NewMsg$>",Message_code) %> <%'---- ASPCode For SkinSwitchForPJBlog ----%> <% function SkinSwitch Dim ModSetTemp1,SkinNs,SkinPs,bcSkin,SkinN,SkinP,i Set ModSetTemp1=New ModSet ModSetTemp1.Open "SkinSwitchForPJBlog" SkinN=ModSetTemp1.getKeyValue("SkinName") SkinP=ModSetTemp1.getKeyValue("SkinPath") SkinNs=split(SkinN,"|") SkinPs=split(SkinP,"|") SkinSwitch="
"&_ ""&_ "
" end function Dim SkinSwitch_code SkinSwitch_code=SkinSwitch side_html_default=replace(side_html_default,"$SkinSwitchForPJBlog$",SkinSwitch_code) side_html=replace(side_html,"$SkinSwitchForPJBlog$",SkinSwitch_code) %> <%'---- ASPCode For Time Counter ----%> <% Dim TimeMSet Set TimeMSet=New ModSet TimeMSet.open("Time Counter") dim CounterTitle,TargetDate,TargetTime,CounterStyle,Counter,TargetYear,TargetMonth,TargetDay,TargetHour,TargetMinute,TargetSecond CounterTitle=TimeMSet.getKeyValue("CounterTitle") TargetDate=TimeMSet.getKeyValue("TargetDate") TargetTime=TimeMSet.getKeyValue("TargetTime") CounterStyle=TimeMSet.getKeyValue("CounterStyle") TargetYear=Year(TargetDate) TargetMonth=Month(TargetDate)-1 TargetDay=Day(TargetDate) TargetHour=Hour(TargetTime) TargetMinute=Minute(TargetTime) TargetSecond=Second(TargetTime) Counter=TargetYear&","&TargetMonth&","&TargetDay&","&TargetHour&","&TargetMinute&","&TargetSecond side_html_default=replace(side_html_default,"<$CounterTitle$>",CounterTitle) side_html_default=replace(side_html_default,"<$Counter$>",Counter) side_html_default=replace(side_html_default,"<$CounterStyle$>",CounterStyle) side_html=replace(side_html,"<$CounterTitle$>",CounterTitle) side_html=replace(side_html,"<$Counter$>",Counter) side_html=replace(side_html,"<$CounterStyle$>",CounterStyle) %> <%'---- ASPCode For RandomLogForPJBlog ----%> <% function RandomArticle(ByVal action) Dim LoadModSet,RandomMod Set LoadModSet=New ModSet LoadModSet.open("RandomLogForPJBlog") RandomMod=LoadModSet.getKeyValue("RandomMod") Dim blog_RandomArticle IF Not IsArray(Application(CookieName&"_blog_RandomArticle")) or action=2 or RandomMod=0 Then Dim Random_rs,Random_Article,Random_sql,Count_rs,Item_rs,array_rs,Random_i,Random_j,array_str,str,Random_n,Random_m,new_j TempVar="" '========================================= '打开数据库操作 set Random_rs=server.createobject("adodb.recordset") Random_sql="SELECT C.log_ID,C.log_Author,C.log_IsShow,C.log_PostTime,C.log_title,L.cate_ID,L.cate_Secret FROM blog_Content AS C,blog_Category AS L where L.cate_ID=C.log_CateID and L.cate_Secret=false and C.log_IsDraft=false" Random_rs.open Random_sql,conn,1,1 '========================================= Count_rs=Random_rs.RecordCount'----记录总数 Item_rs=LoadModSet.getKeyValue("RandomPage")'---------随机显示记录 array_rs = Random_rs.getrows(Count_rs)'-------将记录集放入数组array_rs中 Randomize'---------初始化随机数生成器。 for Random_i = 0 to Item_rs'----循环显示10条记录 '****************************************************************** '下面这个for是用来如果随机数j有重復就重新生成随机数j,没重復会退出这个for循环 '下面的ubound(array_rs,2) 是数组最大下标，相当记录总数 for Random_m=0 to ubound(array_rs,2) Random_j=int(rnd*Count_rs)'------在记录总数范围内生成随机数j array_str = split(str,",")'----str字符串用来记录以前生成的随机数j,这里将str折成数组用来和新的j比较 '==================================================== '下面这个for是用来检测新生成的随机数j和以前生成的随机数对比， '如果有相同就退出这个for回头重新生成随机数j for Random_n = 0 to uBound(array_str) if cstr(Random_j)=cstr(array_str(Random_n)) then new_j=false'----如果比较后这个新j与前面的有相同,将new_j设為false并退出for exit for else new_j=true'---如果没相同的我们设new_j為true end if next '==================================================== if new_j=true then exit for'----new_j為true说明这个j没有相同的,不须重新生成随机数j，我们退出for next '****************************************************************** str=str&Random_j&"," '----str是记录前面生成的随机数j并用,号隔开方便折成数组 if array_rs(6,Random_j) then Random_Article=Random_Article&TempVar&array_rs(0,Random_j)&"|,|"&array_rs(1,Random_j)&"|,|"&array_rs(3,Random_j)&"|,|"&"[隐藏分类日志]" elseif array_rs(2,Random_j) then Random_Article=Random_Article&TempVar&array_rs(0,Random_j)&"|,|"&array_rs(1,Random_j)&"|,|"&array_rs(3,Random_j)&"|,|"&array_rs(4,Random_j) else Random_Article=Random_Article&TempVar&array_rs(0,Random_j)&"|,|"&array_rs(1,Random_j)&"|,|"&array_rs(3,Random_j)&"|,|"&"[隐藏日志]" end if TempVar="|$|" next Set Random_rs=Nothing blog_RandomArticle=Split(Random_Article,"|$|") Application.Lock Application(CookieName&"_blog_RandomArticle")=blog_RandomArticle Application.UnLock Else blog_RandomArticle=Application(CookieName&"_blog_RandomArticle") End IF if action<>2 then dim Random_Items,Random_Item For Each Random_Items IN blog_RandomArticle Random_Item=Split(Random_Items,"|,|") RandomArticle=RandomArticle&""&CCEncode(CutStr(Random_Item(3),25))&"" Next end if end function '处理随机日志内容 Dim Random_code if Session(CookieName&"_LastDo")="DelArticle" or Session(CookieName&"_LastDo")="AddArticle" or Session(CookieName&"_LastDo")="EditArticle" then RandomArticle(2) Random_code=RandomArticle(0) side_html_default=replace(side_html_default,"<$RandomLog$>",Random_code) side_html=replace(side_html,"<$RandomLog$>",Random_code) %> <%'---- ASPCode For Site Focus ----%> <% Dim ShowMSet Set ShowMSet=New ModSet ShowMSet.open("Site Focus") dim img1,img2,img3,img4,img5,img1text,img2text,img3text,img4text,img5text,img1url,img2url,img3url,img4url,img5url,show_width,show_height,text_height,show_config img1=ShowMSet.getKeyValue("img1") img1text=ShowMSet.getKeyValue("img1text") img1url=ShowMSet.getKeyValue("img1url") img2=ShowMSet.getKeyValue("img2") img2text=ShowMSet.getKeyValue("img2text") img2url=ShowMSet.getKeyValue("img2url") img3=ShowMSet.getKeyValue("img3") img3text=ShowMSet.getKeyValue("img3text") img3url=ShowMSet.getKeyValue("img3url") img4=ShowMSet.getKeyValue("img4") img4text=ShowMSet.getKeyValue("img4text") img4url=ShowMSet.getKeyValue("img4url") img5=ShowMSet.getKeyValue("img5") img5text=ShowMSet.getKeyValue("img5text") img5url=ShowMSet.getKeyValue("img5url") show_width=ShowMSet.getKeyValue("show_width") show_height=ShowMSet.getKeyValue("show_height") text_height=ShowMSet.getKeyValue("text_height") side_html_default=replace(side_html_default,"<$img1$>",img1) side_html_default=replace(side_html_default,"<$img2$>",img2) side_html_default=replace(side_html_default,"<$img3$>",img3) side_html_default=replace(side_html_default,"<$img4$>",img4) side_html_default=replace(side_html_default,"<$img5$>",img5) side_html_default=replace(side_html_default,"<$img1text$>",img1text) side_html_default=replace(side_html_default,"<$img2text$>",img2text) side_html_default=replace(side_html_default,"<$img3text$>",img3text) side_html_default=replace(side_html_default,"<$img4text$>",img4text) side_html_default=replace(side_html_default,"<$img5text$>",img5text) side_html_default=replace(side_html_default,"<$img1url$>",img1url) side_html_default=replace(side_html_default,"<$img2url$>",img2url) side_html_default=replace(side_html_default,"<$img3url$>",img3url) side_html_default=replace(side_html_default,"<$img4url$>",img4url) side_html_default=replace(side_html_default,"<$img5url$>",img5url) side_html_default=replace(side_html_default,"<$show_width$>",show_width) side_html_default=replace(side_html_default,"<$show_height$>",show_height) side_html_default=replace(side_html_default,"<$text_height$>",text_height) side_html=replace(side_html,"<$img1$>",img1) side_html=replace(side_html,"<$img2$>",img2) side_html=replace(side_html,"<$img3$>",img3) side_html=replace(side_html,"<$img4$>",img4) side_html=replace(side_html,"<$img5$>",img5) side_html=replace(side_html,"<$img1text$>",img1text) side_html=replace(side_html,"<$img2text$>",img2text) side_html=replace(side_html,"<$img3text$>",img3text) side_html=replace(side_html,"<$img4text$>",img4text) side_html=replace(side_html,"<$img5text$>",img5text) side_html=replace(side_html,"<$img1url$>",img1url) side_html=replace(side_html,"<$img2url$>",img2url) side_html=replace(side_html,"<$img3url$>",img3url) side_html=replace(side_html,"<$img4url$>",img4url) side_html=replace(side_html,"<$img5url$>",img5url) side_html=replace(side_html,"<$show_width$>",show_width) side_html=replace(side_html,"<$show_height$>",show_height) side_html=replace(side_html,"<$text_height$>",text_height) %> <%'---- ASPCode For NewLogForPJBlog ----%> <% function NewArticle(ByVal action) Dim blog_Article IF Not IsArray(Application(CookieName&"_blog_Article")) or action=2 Then Dim book_Articles,book_Article Set book_Articles=Conn.Execute("SELECT top 10 C.log_ID,C.log_Author,C.log_IsShow,C.log_PostTime,C.log_title,L.cate_ID,L.cate_Secret FROM blog_Content AS C,blog_Category AS L where L.cate_ID=C.log_CateID and L.cate_Secret=false and C.log_IsDraft=false order by log_PostTime Desc") SQLQueryNums=SQLQueryNums+1 TempVar="" Do While Not book_Articles.EOF if book_Articles("cate_Secret") then book_Article=book_Article&TempVar&book_Articles("log_ID")&"|,|"&book_Articles("log_Author")&"|,|"&book_Articles("log_PostTime")&"|,|"&"[隐藏分类日志]" elseif book_Articles("log_IsShow") then book_Article=book_Article&TempVar&book_Articles("log_ID")&"|,|"&book_Articles("log_Author")&"|,|"&book_Articles("log_PostTime")&"|,|"&book_Articles("log_title") else book_Article=book_Article&TempVar&book_Articles("log_ID")&"|,|"&book_Articles("log_Author")&"|,|"&book_Articles("log_PostTime")&"|,|"&"[隐藏日志]" end if TempVar="|$|" book_Articles.MoveNext Loop Set book_Articles=Nothing blog_Article=Split(book_Article,"|$|") Application.Lock Application(CookieName&"_blog_Article")=blog_Article Application.UnLock Else blog_Article=Application(CookieName&"_blog_Article") End IF if action<>2 then dim Article_Items,Article_Item For Each Article_Items IN blog_Article Article_Item=Split(Article_Items,"|,|") NewArticle=NewArticle&""&CCEncode(CutStr(Article_Item(3),25))&"" Next end if end function '处理最新日志内容 Dim Article_code if Session(CookieName&"_LastDo")="DelArticle" or Session(CookieName&"_LastDo")="AddArticle" or Session(CookieName&"_LastDo")="EditArticle" then NewArticle(2) Article_code=NewArticle(0) side_html_default=replace(side_html_default,"<$NewLog$>",Article_code) side_html=replace(side_html,"<$NewLog$>",Article_code) %> <% '================================== ' Tags Cloud ' 更新时间: 2005-10-28 '================================== %>

标签云集

Tags Cloud

<% dim log_Tag,log_TagItem For Each log_TagItem IN Arr_Tags log_Tag=Split(log_TagItem,"||") %> <%=log_Tag(1)%>   <% Next %>
<%Side_Module_Replace '处理系统侧栏模块信息%>
<% Session.CodePage=936 Session(CookieName&"_LastDo")="" '最近的一次数据库操作 'Session(CookieName&"_LastDo")返回值说明 'DelComment 删除评论 'AddComment 添加评论 'EditUser 用户编辑个人资料 'RegisterUser 新用户注册 'AddArticle 添加新日志 'EditArticle 编辑日志 'DelArticle 删除日志 'DelMessage 删除留言 (需要留言本插件支持) 'AddMessage 添加留言 (需要留言本插件支持) CloseDB sub CloseDB '关闭数据库 on error resume next Conn.Close Set Conn=Nothing end sub %> <% function getTagSize(c) dim i for i=1 to 10 if int(c)