www.gusucode.com > 易心博客[圣诞版] 3.5手动安装码程序 > Ex_Cls/Ex_CommonCls.asp
<!--#include file="../inc/SN.asp"--> <!--#include file="../inc/md5.asp"--> <% '********************************************************* '文件名称: Ex_CommonCls.asp '功能描述: 易心博客通用调用类 '程序制作:易心 '官方网站: http://www.ex123.net '论坛支持:http://bbs.ex123.net '程序演示:http://exblog.ex123.net 'Copyright (C) 2007 ex123.net All rights reserved. 'LastUpdate: 2007-4-21 '********************************************************* class Ex_CommonCls Public AdName,AdPwd,ShowName,BlogName,BlogUrl,LogoUrl,Placard,WordNum,LogNum,NewLog,NewMsg,NewCmt,LogCount,HidePwd Public CmtCount,MsgCount,VisiteCount,BeiAn,CopyRight,LinkMode,HotTags,RunMode,Domain,DefaultSkin,Bottom Private Rs,Re private sub Class_Initialize Set Rs=Server.CreateObject("adodb.recordset") Set Re=new Regexp Re.ignorecase=True Re.global=True Re.multiline=True end sub private sub Class_Terminate Set Rs=Nothing Set Re=Nothing end Sub '********************** '功能:检测易心博客系统是不是初次安装 '参数:str--要过滤得参数值 '********************** Public Sub CheckInstall GetConfig Dim ExLocation,FsoCls Set FsoCls=new Ex_FsoCls ExLocation=GetDomain()&request.servervariables("script_name") If InStr(ExLocation,Application(Sn&"BlogUrl"))=0 And Application(Sn&"Domain")="否" Then If FsoCls.CheckExist("install.asp","file") Then Response.redirect("install.asp") Else Response.write "本次运行需要您从新安装博客。没有在您的空间中找到安装文件install.asp。 <a href=""http://www.ex123.net"">点此下载</a><br>取消此提示请登录后台,把博客站点设置中的启用泛域名转向选是.<br>出现此提示可能是因为您博客更换了域名或初次安装。<a href=""http://bbs.ex123.net/dispbbs.asp?boardid=3&id=1438"">请上传安装文件install.asp进行安装。</a>" End if End If End Sub '********************** '功能:静态模式的情况下 直接输入网址的 转向 '参数:无 '********************** Public Sub GoIndex GetConfig Dim ExReferer ExReferer=request.servervariables("http_referer") 'If InStr(ExReferer,BlogUrl)=0 And runmode="静态" And request.querystring.count=0 And Application(Sn&"musictype")="" Then If InStr(ExReferer,BlogUrl)=0 And request.querystring.count=0 And Application(Sn&"musictype")<>"index.asp" Then Response.redirect(Application(Sn&"musictype")) End if End Sub '********************** '功能:获取文件或文件夹占用空间情况 '参数:GetLocal--要获取的文件或文件夹路径 GetType--获取类型 folder or file '********************* Public Function GetTotalSize(GetLocal,GetType) Dim FSO Set FSO=Server.CreateObject("Scripting.FileSystemObject") IF Err<>0 Then Err.Clear GetTotalSize="服务器关闭FSO,查看占用空间失败" Else Dim SiteFolder IF GetType="Folder" Then Set SiteFolder=FSO.GetFolder(GetLocal) Else Set SiteFolder=FSO.GetFile(GetLocal) End IF GetTotalSize=SiteFolder.Size IF GetTotalSize>1024*1024 Then GetTotalSize=GetTotalSize/1024/1024 IF inStr(GetTotalSize,".") Then GetTotalSize = Left(GetTotalSize,inStr(GetTotalSize,".")+2) GetTotalSize=GetTotalSize&" MB" Else GetTotalSize=Fix(GetTotalSize/1024)&" KB" End IF Set SiteFolder=Nothing End IF Set FSO=Nothing End Function '*********************** '功能:判断用户ip是否允许访问 '参数:无 '********************** Public Sub IsIpAllow If InStr(GetIpCache,GetIp)<>0 And GetIpCache<>"" Then Response.write "您的ip被禁止访问本站,请于管理员联系" Response.End End if End Sub '************************************************** '函数名:GetDoMain() '作 用:取得当前网站访问地址 如:http://127.0.0.1 '参 数:无 '************************************************** Public Function GetDomain() Dim TempPath If LCase(request.ServerVariables("HTTPS")) = "off" Then TempPath = "http://" Else TempPath = "https://" End If If Request.ServerVariables("SERVER_PORT") = "80" Then GetDomain = Request.ServerVariables("SERVER_NAME") Else GetDomain = Request.ServerVariables("SERVER_NAME") & ":" & Request.ServerVariables("SERVER_PORT") End If If Instr(UCASE(GetDomain),"/W3SVC")<>0 Then GetDomain=Left(GetDomain,Instr(GetDomain,"/W3SVC")) End If GetDomain = TempPath & GetDomain End Function '************************************************** '函数名:GetIP '作 用:取得正确的IP '返回值:IP字符串 '************************************************** Public Function GetIP() Dim strIPAddr If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then strIPAddr = Request.ServerVariables("REMOTE_ADDR") ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1) ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1) Else strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") End If GetIP = Replace(Trim(Mid(strIPAddr, 1, 30)), "'", "") End Function '编码转换 Private Function BytesToBstr(ByVal strBody,CodeBase) dim obj set obj=Server.CreateObject("Ad"&"odb.S"&"tr"&"eam") obj.Type=1 obj.Mode=3 obj.Open obj.Write strBody obj.Position=0 obj.Type=2 obj.Charset=CodeBase BytesToBstr=obj.ReadText obj.Close set obj=nothing End Function '获取服务器端数据 Public Function GetServerData(Url) Dim XmlHttp,xmlDNSTimeout,xmlCONTimeout,xmlSNDTimeout,xmlRCVTimeout xmlDNSTimeout = 10000 '解析 DNS 的超时时间,单位:毫秒 xmlCONTimeout = 10000 '建立连接的超时时间,单位:毫秒 xmlSNDTimeout = 30000 '发送数据的超时时间,单位:毫秒 xmlRCVTimeout = 30000 '接收数据的超时时间,单位:毫秒 On Error Resume Next Set XmlHttp=Server.CreateObject("MSX"&"ML2.Se"&"rver"&"XM"&"LHTTP") XmlHttp.setTimeouts xmlDNSTimeout, xmlCONTimeout, xmlSNDTimeout, xmlRCVTimeout XmlHttp.Open "Get",Url,False XmlHttp.Send() If XmlHttp.ReadyState<>4 Then 'ExComm.ShowMsg "获取数据失败,您的空间可能不支持在线安装等功能.如果经常获取数据失败,建议使用易心空间\n或者到官方网站下载升级包进行手动安装.","admin_config.asp" Response.Write("您的空间不支持在线升级等功能") End If If XmlHttp.Status<>200 Or Err.number<>0 Then Err.clear Set XmlHttp=Server.CreateObject("Micro"&"soft.X"&"ML"&"H"&"TT"&"P") XmlHttp.Open "Get",Url,False XmlHttp.Send() End If GetServerData=BytesToBstr(XmlHttp.ResponseBody,"Gb2312") End Function '************************************************** '函数名:ExNow '作 用: '返回值:指定格式的时间字符串 '************************************************** Public Function ExNow() ExNow=Year(now)&"-"&Month(now)&"-"&Day(now)&" "&Hour(now)&":"&Minute(now)&":"&Second(now) End Function '****************** '功能:显示操作信息 '参数:msg--错误信息 url--操作后要转向的地址 如果为空表示返回 '****************** public sub ShowMsg(byval msg,byval url) Response.Write("<script>alert('"&msg&"')</script>") if url="" then Response.Write("<script>history.go(-1)</script>") else Response.Write("<script>window.location='"&url&"'</script>") End If response.end End Sub '********************* '功能:判断管理员是否登陆 有提示 '参数:无 '********************* Public Sub IsAdLogin If session("AdLogin")<>Md5(SN) Then GetConfig If AdName<>Request.Cookies(Md5(SN))("AdName") Or AdPwd<>Request.Cookies(Md5(SN))("AdPwd") Then ShowMsg "您还没有登陆",Application(sn&"blogurl")&"admin_login.asp" End If End If End Sub '********************* '功能:判断一组帐号和密码是不是匹配 '参数:uname upwd '********************* Public Function CheckUNP(ByVal uname,ByVal upwd) If Len(upwd)<=20 Then upwd=md5(upwd) End If If Conn.execute("select count(*) from Ex_user where username='"&uname&"' and userpwd='"&upwd&"' and lock=false")(0)=0 Then CheckUNP=CBool("false") Else CheckUNP=cbool("true") End if End Function '********************* '功能:判断是否登陆 无提示 返回 true or false '参数:utype---类型 admin表示是管理员判断 User表示是用户判断 '********************* Public Function IsLogin(utype) IsLogin=CBool("True") If utype="admin" Then If session("AdLogin")<>Md5(SN) Then GetConfig If AdName<>(Request.Cookies(sn)("AdName")) Or AdPwd<>G(Request.Cookies(sn)("AdPwd")) Then IsLogin=CBool("false") Else IsLogin=CBool("True") End If End If Else If session("user")="" Then Dim username,userpwd,un username=UnDeCode(F(request.Cookies(Md5(sn))("uname"))) userpwd=UnDeCode(F(request.Cookies(Md5(sn))("upwd"))) un=Conn.execute("select count(*) as d from ex_user where username='"&trim(username)&"' and userpwd='"&Trim(userpwd)&"'") If un(0)<>0 Then session("user")=username IsLogin=CBool("True") ElseIf username="" Then IsLogin=CBool("false") Else IsLogin=CBool("false") End if End If End If End Function '************************ '在容器中插入html '参数:id--容器id html--要输出的html代码 '************************* Public Sub InnerHtml(id,html) response.write("<script>document.getElementById('"&id&"').innerHTML='"&html&"';</script>") End Sub '********************* '功能:获得网站配置信息 '参数:无 '********************* Public Sub GetConfig() Dim I Rs.Open "select * from Ex_Config",Conn,1,1 for I=0 to RS.fields.count-1 Execute(RS.Fields(i).Name&"="""&ForValue(trim(RS.Fields(i).Value))&"""") Next Rs.Close End Sub Public Function ForValue(s) If IsNull(s) Then s="" End If ForValue=Replace(s,Chr(10)+Chr(13),"") ForValue=Replace(ForValue,Chr(10),"") ForValue=Replace(ForValue,Chr(13),"") ForValue=Replace(ForValue,"""","") End Function '********************* '功能:获取栏目中日志的数量 '参数:栏目id '********************* Public Function GetClassNum(id) GetClassNum=Conn.execute("select count(*) from Ex_Log where classid="&CInt(id))(0) End Function '********************* '功能:获取日志静态文件名 如果为空 返回日志id '参数:日志id '********************* Public Function GetLogName(id) Dim Temp Temp=Conn.execute("select file_name from Ex_Log where id="&CInt(id))(0) If Temp="" Or IsNull(Temp) Then GetLogName=Id Else GetLogName=Temp End If End Function '********************* '功能:用户访问量统计 '参数:无 '********************* Public Sub visitorCount If Request.Cookies(Md5(Sn))("visitorCount")<>"www.ex123.net" Then Conn.execute("update Ex_Config set VisiteCount=VisiteCount+1") GetVisiteTotalCache Application.lock Application(sn&"visiteCount")=Application(sn&"visiteCount")+1 Application.unlock End If Response.Cookies(Md5(Sn))("visitorCount")="www.ex123.net" End Sub '********************* '功能:构造底部信息 '参数:无 '********************* Public Function BottomInfo Dim TempStr TempStr="<div align=""center"">" If Application(sn&"bottom")<>"" Then TempStr=TempStr&Application(sn&"bottom") Else TempStr=TempStr&"CopyRight©2008 "&Application(sn&"blogname")&" <a href=""http://www.miibeian.gov.cn/"">"&Application(sn&"beian")&"</a><br>" TempStr=TempStr&Application(Sn&"waithtml") TempStr=TempStr&"Powered By "&Application(Sn&"Version")&" Www.ex123.Net .<a href=""http://www.ex123.net""><img src=""images/admin/Exblog_powered.gif"" border=""0""></a>" End If TempStr=TempStr&"</div>"&vbcrlf If Application(Sn&"RunMode")="静态" Then TempStr=TempStr&"<script src=""JsInHtml.asp?action=calendar&c_year=$show_year$&c_month=$show_month$&c_day=$show_day$""></script>"&vbcrlf TempStr=TempStr&"<script src=""JsInHtml.asp?action=login""></script>"&vbcrlf TempStr=TempStr&"<script src=""JsInHtml.asp?action=info""></script>"&vbcrlf TempStr=TempStr&"<script src=""JsInHtml.asp?action=more&ids=$show_logids$""></script>"&vbcrlf TempStr=TempStr&"<script src=""autohtml.asp?id=$show_logids$""></script>"&vbcrlf End If BottomInfo=TempStr End Function '*****************************字符串处理部分开始*************************** '************************************************** '函数名:CheckRe '作 用:检测给定的字符串与正则匹配模式是否匹配 '参 数:str ----要检测的字符串 pat---正则模式[多个模式间用%分割] '返回值:匹配返回true 否则返回 false '************************************************** Public Function CheckRe(str,pat) Dim I If Trim(pat)<>"" Then If InStr(pat,"%")<>0 Then pat=Split(pat,"%") For I=0 To UBound(pat) Re.pattern=pat(I) If Re.Test(str) Then CheckRe=CBool("true") Exit Function Else CheckRe=CBool("false") End If Next Else Re.pattern=pat If Re.Test(str) Then CheckRe=CBool("true") Exit Function Else CheckRe=CBool("false") End If End If Else CheckRe=CBool("False") End If End Function '************************************************** '函数名:SubStr '作 用:返回字符串中 给定开始字符串和结束字符串之间的子字符串 包括开始和结束字符串 '参 数:str ----要检测的字符串 '返回值:返回子字符串 '************************************************** Public Function SubStr(Str,StartStr,EndStr) Dim StartNum,EndNum StartNum=InStr(Str,StartStr) EndNum=InStr(Str,EndStr) SubStr=Mid(Str,StartNum,EndNum+Len(EndStr)-2) End Function '************************************************** '函数名:ReReplace '作 用:根据正则条件去除符合正则部分 '参 数:str ----要检测的字符串 p---正则 '返回值:返回去除后的字符串 '************************************************** Public Function ReReplace(Str,P) Re.pattern=P ReReplace=Re.replace(Str,"") End Function '************************************************** '函数名:Html2Js '作 用:把html代码转换成js形式 '参 数:str ----要转换的字符串 id---被输入容器的id '返回值:转换后的字符串 '************************************************** Public Function Html2Js(id,str) Dim Temp Temp=str Temp=Replace(Temp,"""","\""") Temp=Replace(Temp,"'","\'") Temp=Replace(Temp,"</script>","<\/script>") Temp=Replace(Temp,Chr(10),"<br>") Temp=Replace(Temp,Chr(13),"") If Trim(id)="" Then Html2Js=Temp Else Html2Js="if (chkdiv('"&id&"')) {document.getElementById('"&id&"').innerHTML='"&Temp&"';}" End If End Function '************************************************** '函数名:strLength '作 用:求字符串长度。汉字算两个字符,英文算一个字符。 '参 数:str ----要求长度的字符串 '返回值:字符串长度 '************************************************** Public Function strLength(Str) Dim bolChinese bolChinese= (Len("易心") = 2) If bolChinese Then Dim intLen, intCount,intCode,intIndex intLen = Len(Str) intCount= l For intIndex = 1 To intLen intCode = Ascw(Mid(Str, intIndex, 1)) If intCode > 255 Or intCode<0 Then intCount = intCount + 2 Else intCount =intCount+1 End If Next strLength = intCount Else strLength = Len(Str) End If End Function '***************** '功能:字符串截取 返回截取的字符串 '参数:str---要截取的字符串 num---要截取的字符数 '***************** public function CutStr(byval str,byval num) dim i,l,char,strTemp,ln 'Str = Replace(Replace(Replace(Replace(Str, " ", " "), """, Chr(34)), ">", ">"), "<", "<") l=len(str) ln=0 for i=1 to l char=mid(str,i,1) if ascw(char)>=0 and ascw(char)<=255 then ln=ln+1 else ln=ln+2 end if strTemp=strTemp&Char if cint(ln)>=cint(num) then exit For end if Next 'strTemp = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<") CutStr=strTemp end Function '********************** '功能:过滤获得的参数 返回过滤后的参数值 '参数:str--要过滤得参数值 '********************** public function G(byval Str) if isnull(Str) then Str="" end If Str = replace(Str,"'","''") Re.Pattern="select" Str = Re.Replace(Str,"select") Re.Pattern="join" Str = Re.Replace(Str,"join") Re.Pattern="union" Str = Re.Replace(Str, "union") Re.Pattern="where" Str = Re.Replace(Str,"where") Re.Pattern="insert" Str = Re.Replace(Str,"insert") Re.Pattern="deleter" Str = Re.Replace(Str, "delete") Re.Pattern="update" Str = Re.Replace(Str, "update") Re.Pattern="like" Str = Re.Replace(Str, "like") Re.Pattern="drop" Str = Re.Replace(Str, "drop") Re.Pattern="create" Str = Re.Replace(Str, "create") Re.Pattern="modify" Str = Re.Replace(Str, "modify") Re.Pattern="rename" Str = Re.Replace(Str, "rename") Re.Pattern="alter" Str = Re.Replace(Str, "alter") Re.Pattern="cast" Str = Re.Replace(Str, "cast") Re.pattern="\$show_" Str = Re.Replace(Str, "$show_") G=Str end Function '************************** '功能:过滤表单内容 返回过滤后的值 '参数:str--要过滤的内容 '************************** Public Function F(ByVal Str) Str=Server.htmlencode(Str) Str=G(str) F=Str End Function '************************************************** '纠正html代码中的连接地址 全部转换成相对路径 '参数:str--要转换的内容 '************************************************** Function DoUrl(ByVal str) Re.pattern="src=((?!""|'|ftp|http|https|mailto).*?)>" str=Re.Replace(str,"src="&Application(sn&"blogurl")&"$1>") Re.pattern="src='((?!""|ftp|http|https|mailto).*?)\'" str=Re.Replace(str,"src='"&Application(sn&"blogurl")&"$1'") Re.pattern="src=""((?!'|ftp|http|https|mailto).*?)""" str=Re.Replace(str,"src="""&Application(sn&"blogurl")&"$1""") Re.pattern="url\(((?!""|'|ftp|http|https|mailto).*?)\)" str=Re.Replace(str,"url\("&Application(sn&"blogurl")&"$1\)") Re.pattern="url\('((?!""|ftp|http|https|mailto).*?)\)" str=Re.Replace(str,"url\('"&Application(sn&"blogurl")&"$1\)") Re.pattern="url\(""((?!'|ftp|http|https|mailto).*?)""\)" str=Re.Replace(str,"url\("&Application(sn&"blogurl")&"$1\)") Re.pattern="href=((?!""|'|ftp|http|https|mailto).*?)>" str=Re.Replace(str,"href="&Application(sn&"blogurl")&"$1>") Re.pattern="href='((?!""|ftp|http|https|mailto).*?)'" str=Re.Replace(str,"href='"&Application(sn&"blogurl")&"$1'") Re.pattern="href=""((?!'|ftp|http|https|mailto).*?)""" str=Re.Replace(str,"href="""&Application(sn&"blogurl")&"$1""") Re.pattern="background=((?!""|'|ftp|http|https|mailto).*?)>" str=Re.Replace(str,"background="&Application(sn&"blogurl")&"$1>") Re.pattern="background='((?!""|ftp|http|https|mailto).*?)>" str=Re.Replace(str,"background='"&Application(sn&"blogurl")&"$1>") Re.pattern="background=""((?!'|ftp|http|https|mailto).*?)""" str=Re.Replace(str,"background="""&Application(sn&"blogurl")&"$1""") DoUrl=str End Function '************************************************** '生成静态连接地址 '参数:t-返回数据类型[blogview folderpath filepath] 'classid--分类id或者分类目录名 logid--日志id或者自定义文件名 tags--tag名 page--分页 如果第一页 赋值为空 其它赋值为 -page '************************************************** Public Function CreateUrl(ByVal classid,ByVal logid,ByVal page) Dim Temp,ClassId2 If IsNumeric(logid) Then If Trim(ClassId)="html" Then ClassId2=Conn.Execute("select classid from Ex_log where id="&logid)(0) Else ClassId2=ClassId End If If Trim(page)="" Then page="_1" End If Temp=Application(sn&"blogurl")&classid&"/blogview-"&classid2&"-"&logid&page&".html" Else Temp=Application(sn&"blogurl")&classid&"/"&logid&page&".html" End If CreateUrl=Temp End Function '************************************************** '文本框输入的内容与html代码间常见字符转换 '参数:str--文本框中的内容 '************************************************** Public Function Text2Html(ByVal str) Dim temp temp=Replace(str,Chr(10),"<br>") temp=Replace(temp,Chr(13),"") Text2Html=temp End Function '**************************************************** '清除html标记 '参数 str----要清除的字符串 '**************************************************** Public Function clearHtml(ByVal str) re.pattern="(\<)(.*?)(\>)" re.IgnoreCase =false re.Global=True str=re.Replace(str,"") clearHtml=str End Function '************************************************** '服务器端编码函数 '参数:str--要进行编码的内容 '************************************************** function DeCode(ByVal str) Dim dei,detemp,dechar For dei=Len(str) To 1 Step -1 dechar=Mid(str,dei,1) detemp=detemp&Ascw(dechar) If dei<>1 Then detemp=detemp&"a" End If Next DeCode=detemp End Function '************************************************* '服务器端解码函数 '参数:str--要进行解码的内容 '************************************************* Public Function UnDeCode(ByVal str) Dim uni,untemp str=Split(str,"a") For uni=UBound(str) To 0 Step -1 untemp=untemp&chrw(str(uni)) Next UnDeCode=untemp End Function '************************************************* '判断是不是oblog模板 '参数:无 '************************************************* Public Function IsOblogSkin If IsCache("DefaultSkin")=False Then GetConfigCache("DefaultSkin") End If If IsNumeric(Application(sn&"DefaultSkin")) Then IsOblogSkin=CBool("true") Else IsOblogSkin=CBool("false") End If End Function '*****************************字符串处理部分结束*************************** '*****************************系统缓存部分开始************************** '********************* '功能:获取站点配置信息缓存值 默认缓存 博客名称 application(sn&"blogname") 管理员前台显示名 application(sn$"showname") '博客地址 application(sn&"blogurl") logo地址 application(sn&"logourl") '参数:CacheName--要获取的缓存名 多个缓存名之间用逗号割开 * 代表获取全部配置信息 '********************* Public Function GetConfigCache(ByVal CacheName) Dim I,Arr Arr=Split(CacheName,",") If InStr(CacheName,",")<>0 Then CacheName="" For I=0 To UBound(Arr) If IsCache(Arr(I))=False Then CacheName=CacheName&Arr(I)&"," End If Next If InStr(CacheName,",")<>0 Then CacheName=Left(CacheName,Len(CacheName)-1) End If End If If Trim(CacheName)<>"" Then Application.Lock Rs.open "select "&CacheName&" from Ex_Config",Conn,1,1 For I=0 To Rs.Fields.Count-1 Execute("Application("""&SN&RS.Fields(i).Name&""")="""&ForValue(trim(RS.Fields(i).Value))&"""") Next Rs.close Application.UnLock End If End Function '******************** '获取ip缓存 '参数:无 '******************* Public Function GetIpCache If IsCache("ip")=False Then Rs.open "select lockIp from Ex_LockIp",Conn,1,1 If Not Rs.eof And Not Rs.bof Then Application.Lock Do While Not rs.eof Application(sn&"ip")=Application(sn&"ip")&"|"&Rs(0) Application.UnLock rs.movenext loop End If Rs.close End If GetIpCache=Application(sn&"ip") End Function '******************** '获取分类缓存 把非转向分类缓存 分类之间用а隔开 分类与id之间用б隔开 '参数:无 '******************* Public Sub GetClassCache If IsCache("class")=False Then Application.Lock Rs.open "select id,classx from Ex_Class where `default`=true",Conn,1,1 If Not Rs.eof And Not Rs.bof Then Do While Not rs.eof Application(sn&"class")=Application(sn&"class")&"а"&Rs("id")&"б"&Rs("classx") rs.movenext loop End If Rs.close Application.UnLock End If End Sub '******************** '获取分类缓存 把非转向分类缓存 分类之间用а隔开 分类与id之间用б隔开 '参数:无 '******************* Public Sub GetClassFolderCache If IsCache("classfolder")=False Then Application.Lock Rs.open "select id,classfolder from Ex_Class where default=1",Conn,1,1 If Not Rs.eof And Not Rs.bof Then Do While Not rs.eof Application(sn&"classfolder")=Application(sn&"classfolder")&"а"&Rs("id")&"б"&Rs("classfolder") rs.movenext loop End If Rs.close Application.UnLock End If End Sub '************************************* '获得类静态目录 '参数:clsid--类的id '************************************* Public Function GetClassFolder(ByVal clsid) Dim myclass,classid,i GetClassFolderCache() myclass=application(sn&"classfolder") myclass=Split(myclass,"а") For i=1 To UBound(myclass) classid=Split(myclass(i),"б") If CInt(classid(0))=CInt(clsid) Then If Trim(classid(1))="" Or IsNull(Classid(1)) Then GetClassFolder="html" Else GetClassFolder=classid(1) End If Exit Function End if Next End Function '************************************* '获得类名称 '参数:clsid--类的id '************************************* Public Function GetClassName(ByVal clsid) Dim myclass,classid,i GetClassCache() myclass=application(sn&"class") myclass=Split(myclass,"а") For i=1 To UBound(myclass) classid=Split(myclass(i),"б") If CInt(classid(0))=CInt(clsid) Then GetClassName=classid(1) Exit Function End if Next End Function '******************** '获取分类缓存 以列表框形式 '参数:id--默认被选中项的id '******************* Public Function GetClassSelectCache(id) Dim myclass,classid,i GetClassCache myclass=Mid(application(sn&"class"),2,Len(application(sn&"class"))) myclass=Split(myclass,"а") For i=0 To UBound(myclass) classid=Split(myclass(i),"б") If CInt(classid(0))=CInt(id) Then GetClassSelectCache=GetClassSelectCache&"<option value="""&classid(0)&""" selected>"&classid(1)&"</option>" Else GetClassSelectCache=GetClassSelectCache&"<option value="""&classid(0)&""">"&classid(1)&"</option>" End if Next End Function '******************** '获取相册分类缓存 分类之间用а隔开 分类与id之间用б隔开 '参数:无 '******************* Public Sub GetPhotoClassCache If IsCache("photoclass")=False Then Application.Lock Rs.open "select id,clsname from Ex_PhotoCls",Conn,1,1 If Not Rs.eof And Not Rs.bof Then Do While Not rs.eof Application(sn&"photoclass")=Application(sn&"photoclass")&"а"&Rs("id")&"б"&Rs("clsname") rs.movenext loop End If Rs.close Application.UnLock End If End Sub '******************** '获取相册分类缓存 以列表框形式 '参数:id--默认被选中项的id '******************* Public Function GetPhotoClassSelectCache(id) Dim myclass,classid,i GetPhotoClassCache myclass=Mid(application(sn&"photoclass"),2,Len(application(sn&"photoclass"))) myclass=Split(myclass,"а") For i=0 To UBound(myclass) classid=Split(myclass(i),"б") If CInt(classid(0))=CInt(id) Then GetPhotoClassSelectCache=GetPhotoClassSelectCache&"<option value="""&classid(0)&""" selected>"&classid(1)&"</option>" Else GetPhotoClassSelectCache=GetPhotoClassSelectCache&"<option value="""&classid(0)&""">"&classid(1)&"</option>" End if Next End Function '******************** '获取连接分类缓存 把非转向分类缓存 分类之间用а隔开 分类与id之间用б隔开 '参数:无 '******************* Public Sub GetLinksClassCache If IsCache("Linksclass")=False Then Application.Lock Rs.open "select id,clsname from Ex_LinksCls order by orderx asc",Conn,1,1 If Not Rs.eof And Not Rs.bof Then Do While Not rs.eof Application(sn&"Linksclass")=Application(sn&"Linksclass")&"а"&Rs("id")&"б"&Rs("clsname") rs.movenext loop End If Rs.close Application.UnLock End If End Sub '******************** '获取连接分类缓存 以列表框形式 '参数:id--默认被选中项的id '******************* Public Function GetLinksClassSelectCache(id) Dim myclass,classid,i GetLinksClassCache myclass=Mid(application(sn&"Linksclass"),2,Len(application(sn&"Linksclass"))) myclass=Split(myclass,"а") For i=0 To UBound(myclass) classid=Split(myclass(i),"б") If Not (IsNull(classid(0)) Or IsNull(id)) Then If CInt(classid(0))=CInt(id) Then GetLinksClassSelectCache=GetLinksClassSelectCache&"<option value="""&classid(0)&""" selected>"&classid(1)&"</option>" Else GetLinksClassSelectCache=GetLinksClassSelectCache&"<option value="""&classid(0)&""">"&classid(1)&"</option>" End If Else GetLinksClassSelectCache=GetLinksClassSelectCache&"<option value="""&classid(0)&""">"&classid(1)&"</option>" End If Next End Function '******************* '日志数量缓存 '参数:无 '******************** Public Function GetLogTotalCache() If IsCache("logtotal")=False Then Application.lock Application(sn&"logtotal")=Conn.Execute("select count(*) as n from Ex_log")(0) Application.unlock End If GetLogTotalCache=Application(sn&"logtotal") End Function '******************* '评论数量缓存 '参数:无 '******************** Public Function GetCmtTotalCache() If IsCache("cmttotal")=False Then Application.lock Application(sn&"cmttotal")=Conn.Execute("select count(*) as n from Ex_Comment")(0) Application.unlock End If GetCmtTotalCache=Application(sn&"cmttotal") End Function '******************* '留言数量缓存 '参数:无 '******************** Public Function GetMsgTotalCache() If IsCache("Msgtotal")=False Then Application.lock Application(sn&"msgtotal")=Conn.Execute("select count(*) as n from Ex_Message")(0) Application.unlock End If GetMsgTotalCache=Application(sn&"Msgtotal") End Function '******************* '访问数量缓存 '参数:无 '******************** Public Function GetVisiteTotalCache() If IsCache("VisiteCount")=False Then GetConfigCache("VisiteCount") Application.lock Application(sn&"VisiteCount")=Application(sn&"VisiteCount") Application.unlock End If GetVisiteTotalCache=Application(sn&"VisiteCount") End Function '******************* '注册用户数量缓存 '参数:无 '******************** Public Function GetUserTotalCache() If IsCache("Usertotal")=False Then Application.lock Application(sn&"Usertotal")=Conn.execute("select count(*) from Ex_user")(0) Application.unlock End If GetUSERTotalCache=Application(sn&"Usertotal") End Function '******************** '清除缓存 '参数:MyCaheName-缓存名称 '******************* Public Sub ClearCache(MyCaheName) Application.Lock Application.Contents.Remove(MyCaheName) Application.unLock End Sub '********************* '取得缓存列表 '参数 PreCacheName-前段匹配 '********************* Public Function GetCacheList(PreCacheName) Dim Cacheobj For Each Cacheobj in Application.Contents If CStr(Left(Cacheobj,Len(PreCacheName)))=CStr(PreCacheName) Then GetCacheList=GetCacheList&Cacheobj&"," End if Next End Function '******************* '不提示,批量清除缓存 '参数 PreCacheName-前段匹配 '****************** Public Sub ClearCaches(PreCacheName) Dim i Dim CacheList CacheList=split(GetCacheList(PreCacheName),",") If UBound(CacheList)>1 Then For i=0 to UBound(CacheList)-1 ClearCache CacheList(i) Next End IF End Sub '******************* '判断缓存是否存在 '参数 CacheName-不带前导的缓存名 '****************** Public Function IsCache(CacheName) If Application(sn&CacheName)="" Or IsEmpty(Application(sn&CacheName)) Or IsNull(Application(sn&CacheName)) Then IsCache=CBool("false") Else IsCache=CBool("true") End if End Function '****************************系统缓存部分结束************************** end class %>