<%@ 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 %> <% '***************PJblog2 缓存处理******************* ' PJblog2 Copyright 2006 ' Update:2006-1-25 '************************************************** '-------------------------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 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 '=========================日志基本信息缓存======================= 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" & _ " 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=CBool(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_version="2.6 build 02"'当前PJBlog版本号 blog_UpdateDate="2006-7-2"'PJBlog最新更新时间 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)) end sub '=========================End Sub======================== '========================日志分类缓存========================= Dim Category_code Sub CategoryList(ByVal action) '日志分类 '写入日志分类 'action=0 横向菜单 action=1 树状菜单 action=2重建分类 '--------------写入日志分类缓存------------------ 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 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 Dim Category_Len,Menu_Diver '--------------输出日志横向菜单------------------ if action=0 then Menu_Diver="" Response.Write("
"):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))=1 then Response.Write(Menu_Diver) if Arr_Category(4,i) then if cbool(Arr_Category(10,i)) then if stat_ShowHiddenCate or stat_Admin then Response.Write("
  • "&Arr_Category(1,i)&"
  • ") else Response.Write("
  • "&Arr_Category(1,i)&"
  • ") end if else if cbool(Arr_Category(10,i)) then if stat_ShowHiddenCate or stat_Admin then Response.Write("
  • "&Arr_Category(1,i)&"
  • ") else Response.Write("
  • "&Arr_Category(1,i)&"
  • ") end if end if Menu_Diver="
  • " end if Next Response.Write("
  • ") 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 %> <% '=============================================================== ' 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]","