ASP缓存类收集

木鸟写的 
'********************************************** 
' vbs Cache类 
' 
' 属性valid，是否可用，取值前判断 
' 属性name，cache名，新建对象后赋值 
' 方法add(值,到期时间)，设置cache内容 
' 属性value，返回cache内容 
' 属性blempty，是否未设置值 
' 方法makeEmpty，释放内存，测试用 
' 方法equal(变量1)，判断cache值是否和变量1相同 
' 方法expires(time)，修改过期时间为time 
' 木鸟 2002.12.24 
' http://www.aspsky.net/ 
'********************************************** 
class Cache 
private obj 'cache内容 
private expireTime '过期时间 
private expireTimeName '过期时间application名 
private cacheName 'cache内容application名 
private path 'uri 

private sub class_initialize() 
path=request.servervariables("url") 
path=left(path,instrRev(path,"/")) 
end sub 

private sub class_terminate() 
end sub 

public property get blEmpty 
'是否为空 
if isempty(obj) then 
blEmpty=true 
else 
blEmpty=false 
end if 
end property 

public property get valid 
'是否可用(过期) 
if isempty(obj) or not isDate(expireTime) then 
valid=false 
elseif CDate(expireTime)<now then 
valid=false 
else 
valid=true 
end if 
end property 

public property let name(str) 
'设置cache名 
cacheName=str & path 
obj=application(cacheName) 
expireTimeName=str & "expires" & path 
expireTime=application(expireTimeName) 
end property 

public property let expires(tm) 
'重设置过期时间 
expireTime=tm 
application.lock 
application(expireTimeName)=expireTime 
application.unlock 
end property 

public sub add(var,expire) 
'赋值 
if isempty(var) or not isDate(expire) then 
exit sub 
end if 
obj=var 
expireTime=expire 
application.lock 
application(cacheName)=obj 
application(expireTimeName)=expireTime 
application.unlock 
end sub 

public property get value 
'取值 
if isempty(obj) or not isDate(expireTime) then 
value=null 
elseif CDate(expireTime)<now then 
value=null 
else 
value=obj 
end if 
end property 

public sub makeEmpty() 
'释放application 
application.lock 
application(cacheName)=empty 
application(expireTimeName)=empty 
application.unlock 
obj=empty 
expireTime=empty 
end sub 

public function equal(var2) 
'比较 
if typename(obj)<>typename(var2) then 
equal=false 
elseif typename(obj)="Object" then 
if obj is var2 then 
equal=true 
else 
equal=false 
end if 
elseif typename(obj)="Variant()" then 
if join(obj,"^")=join(var2,"^") then 
equal=true 
else 
equal=false 
end if 
else 
if obj=var2 then 
equal=true 
else 
equal=false 
end if 
end if 
end function 
end class 


木鸟　类例子 vbs Cache类 



' 
' 属性valid，是否可用，取值前判断 
' 属性name，cache名，新建对象后赋值 
' 方法add(值,到期时间)，设置cache内容 
' 属性value，返回cache内容 
' 属性blempty，是否未设置值 
' 方法makeEmpty，释放内存， 
' 方法DelCahe ,删除内存 
' 方法equal(变量1)，判断cache值是否和变量1相同 
' 方法expires(time)，修改过期时间为time 
' 用法 

set myCache=New Cache 
myCache.name="BoardJumpList" '定义缓存名 
if myCache.valid then　'判断是否可用(包括过期，与是否为空值) 
response.write myCache.value　'输出 
else 
................ 
BoardJumpList=xxx 
myCache.add BoardJumpList,dateadd("n",60,now)　'写入缓存 xxx.add 内容,过期时间 
response.write BoardJumpList '输出 
end if 
myCache.makeEmpty() 释放内存 
mycache.DelCahe()　删除缓存 

==========================================================================


迷城浪子写的 Class Cls_Cache 



Rem ==================使用说明==================== 
Rem = 本类模块是动网先锋原创，作者：迷城浪子。如采用本类模块，请不要去掉这个说明。这段注释不会影响执行的速度。 
Rem = 作用：缓存和缓存管理类 
Rem = 公有变量：Reloadtime 过期时间（单位为分钟）缺省值为14400 
Rem = MaxCount 缓存对象的最大值，超过则自动删除使用次数少的对象。缺省值为300 
Rem = CacheName 缓存组的总名称，缺省值为"Dvbbs",如果一个站点中有超过一个缓存组，则需要外部改变这个值。 
Rem = 属性:Name 定义缓存对象名称，只写属性。 
Rem = 属性:value 读取和写入缓存数据。 
Rem = 函数：ObjIsEmpty()判断当前缓存是否过期。 
Rem = 方法：DelCahe(MyCaheName)手工删除一个缓存对象，参数是缓存对象的名称。 
Rem ======================== 
Public Reloadtime,MaxCount,CacheName 
Private LocalCacheName,CacheData,DelCount 
Private Sub Class_Initialize() 
Reloadtime=14400 
CacheName="Dvbbs" 
End Sub 
Private Sub SetCache(SetName,NewValue) 
Application.Lock 
Application(SetName) = NewValue 
Application.unLock 
End Sub 
Private Sub makeEmpty(SetName) 
Application.Lock 
Application(SetName) = Empty 
Application.unLock 
End Sub 
Public Property Let Name(ByVal vNewValue) 
LocalCacheName=LCase(vNewValue) 
End Property 
Public Property Let Value(ByVal vNewValue) 
If LocalCacheName<>"" Then 
CacheData=Application(CacheName&"_"&LocalCacheName) 
If IsArray(CacheData) Then 
CacheData(0)=vNewValue 
CacheData(1)=Now() 
Else 
ReDim CacheData(2) 
CacheData(0)=vNewValue 
CacheData(1)=Now() 
End If 
SetCache CacheName&"_"&LocalCacheName,CacheData 
Else 
Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName." 
End If 
End Property 
Public Property Get Value() 
If LocalCacheName<>"" Then 
CacheData=Application(CacheName&"_"&LocalCacheName) 
If IsArray(CacheData) Then 
Value=CacheData(0) 
Else 
Err.Raise vbObjectError + 1, "DvbbsCacheServer", " The CacheData Is Empty." 
End If 
Else 
Err.Raise vbObjectError + 1, "DvbbsCacheServer", " please change the CacheName." 
End If 
End Property 
Public Function ObjIsEmpty() 
ObjIsEmpty=True 
CacheData=Application(CacheName&"_"&LocalCacheName) 
If Not IsArray(CacheData) Then Exit Function 
If Not IsDate(CacheData(1)) Then Exit Function 
If DateDiff("s",CDate(CacheData(1)),Now()) < 60*Reloadtime Then 
ObjIsEmpty=False 
End If 
End Function 
Public Sub DelCahe(MyCaheName) 
makeEmpty(CacheName&"_"&MyCaheName) 
End Sub 
End Class 

迷城浪子　类例子 



Set WydCache=New Cls_Cache 
WydCache.Reloadtime=0.5 '定义过期时间 (以分钟为单会) 
WydCache.CacheName="pages"　'定义缓存名 
IF WydCache.ObjIsEmpty() Then ''判断是否可用(包括过期，与是否为空值) 
Response.write WydCache.Value 
Else 
.................. 
BoardJumpList=xxx 
WydCache.Value=BoardJumpList '写入内容 
Response.write BoardJumpList 
End if 

mycache.DelCahe("缓存名")　删除缓存 


==========================================================================

slightboy 写的 



'======================== 
'clsCache.asp 
'======================== 
'== begin : 2004-6-26 21:51:47 
'== copyright : slightboy (C)1998-2004 
'== email : slightboy@msn.com 
'======================== 
'======================== 
' Dim Application(2) 
' Application(0) Counter 计数器 
' Application(1) dateTime 放置时间 
' Application(2) Content 缓存内容 

Public PREFIX 
Public PREFIX_LENGTH 

Private Sub Class_Initialize() 
PREFIX = "Cached:" 
PREFIX_LENGTH = 7 
End Sub 
Private Sub Class_Terminate 
End Sub 
' 设置变量 
Public Property Let Cache(ByRef Key, ByRef Content) 
Dim Item(2) 
Item(0) = 0 
Item(1) = Now() 
IF (IsObject(Content)) Then 
Set Item(2) = Content 
Else 
Item(2) = Content 
End IF 
Application.Unlock 
Application(PREFIX & Key) = Item 
Application.Lock 
End Property 
' 取出变量 计数器++ 
Public Property Get Cache(ByRef Key) 
Dim Item 
Item = Application(PREFIX & Key) 
IF (IsArray(Item)) Then 
IF (IsObject(Item)) Then 
Set Cache = Item(2) 
Else 
Cache = Item(2) 
End IF 
Application(PREFIX & Key)(0) = Application(PREFIX & Key)(0) + 1 
Else 
Cache = Empty 
End IF 
End Property 
' 检查缓存对象是否存在 
Public Property Get Exists(ByRef Key) 
Dim Item 
Item = Application(PREFIX & Key) 
IF (IsArray(Item)) Then 
Exists = True 
Else 
Exists = False 
End IF 
End Property 
' 得到计数器数值 
Public Property Get Counter(ByRef Key) 
Dim Item 
Item = Application(PREFIX & Key) 
IF (IsArray(Item)) Then 
Counter = Item(0) 
End IF 
End Property 

' 设置计数器时间 
Public Property Let dateTime(ByRef Key, ByRef SetdateTime) 
Dim Item 
Item = Application(PREFIX & Key) 
IF (IsArray(Item)) Then 
Item(1) = SetdateTime 
End IF 
End Property 
' 得到计数器时间 
Public Property Get dateTime(ByRef Key) 
Dim Item 
Item = Application(PREFIX & Key) 
IF (IsArray(Item)) Then 
dateTime = Item(1) 
End IF 
End Property 

' 重置计数器 
Public Sub ResetCounter() 
Dim Key 
Dim Item 
Application.Unlock 
For Each Key in Application.Contents 
IF (Left(Key, PREFIX_LENGTH) = PREFIX) Then 
Item = Application(Key) 
Item(0) = 0 
Application(Key) = Item 
End IF 
Next 
Application.Lock 
End Sub 
' 删除某以缓存 
Public Sub Clear(ByRef Key) 
Application.Contents.Remove(PREFIX & Key) 
End Sub 
' 清空没有使用的缓存 
Public Sub ClearUnused() 
Dim Key, Keys, KeyLength, KeyIndex 
For Each Key in Application.Contents 
IF (Left(Key, PREFIX_LENGTH) = PREFIX) Then 
IF (Application(Key)(0) = 0) Then 
Keys = Keys & VBNewLine & Key 
End IF 
End IF 
Next 
Keys = Split(Keys, VBNewLine) 
KeyLength = UBound(Keys) 
Application.Unlock 
For KeyIndex = 1 To KeyLength 
Application.Contents.Remove(Keys(KeyIndex)) 
Next 
Application.Lock 
End Sub 
' 清空所有缓存 
Public Sub ClearAll() 
Dim Key, Keys, KeyLength, KeyIndex 
For Each Key in Application.Contents 
IF (Left(Key, PREFIX_LENGTH) = PREFIX) Then 
Keys = Keys & VBNewLine & Key 
End IF 
Next 
Keys = Split(Keys, VBNewLine) 
KeyLength = UBound(Keys) 
Application.Unlock 
For KeyIndex = 1 To KeyLength 
Application.Contents.Remove(Keys(KeyIndex)) 
Next 
Application.Lock 
End Sub 

End Class 

slightboyn 类例子 

Set Wyd=New JayCache 
Wyd.dateTime("Page")=时 间 
If Wyd.Exists("Page") Then 
Response.write Wyd.Cache("Page") '输出 
Else 
Wyd.Cache("Page")=xxx　写入 
Responxe.write xxx 
End IF 
Wyd.Clear("page")'删除缓存 

==========================================================================

无惧缓存类 V1.0

Cache_class.asp

<%
' ============================================
' 转发时请保留此声明信息,这段声明不并会影响你的速度!
' 类名:无惧缓存类 V1.0
' 作者:梁无惧
' 网站:http://www.２５ＣＮ.com
' 电子邮件:yjlrb@２５ＣＮ.com
' 版权声明:版权所有,源代码公开,各种用途均可免费使用,但是修改后必须把修改后的文件
' 发送一份给作者.
' ============================================
' 用途:用于常用数据的缓存,以减少执行,加快速度,但是由于使用Application来存贮数据,有可能对服务器造成负担
' 类名 Cache_Class
' 方法 NoCache(函数名,关键字) 测试该缓存是否有效
' 属性 Value 如果缓存无效,使用该属性设置缓存,如果缓存,则使用该属性读取缓存
' 例子
' Dim Cache
' Set Cache = New Cache_Class
' if Cache.NoCache("getname(a)","username") Then Cache.Value=getname(a)
' Response.Write Cache.Value
' 注意:每次使用前都需要用NoCache方法来测试,否则无法保证的取得的值是否为当前设置的函数名
' 技巧:函数名用于识别,当有数据改变时,只需直接调用函数SetCacheKey(关键字)即可以刷新缓存,这样可保存缓存随数据的改变而重新缓存
' 默认建立Cache实例，可以在程序中直接调用而不需要事先创建
' ============================================

Class Cache_Class
Dim Cache_Name, Cache_Key, Version, Cache_Value

Function NoCache(FunName, Key)
Dim NoIn
Cache_Name = FunName
Cache_Key = Key
Cache_Value = Application("Cache_" & Cache_Name)
NoIn = True
If IsArray(Cache_Value) Then If Application("CacheKey_" & Cache_Key) = Cache_Value(0) Then NoIn = False
NoCache = NoIn
End Function

Property Get Value()
Value = Cache_Value(1)
End Property

Property Let Value(Val)
ReDim Cache_Value(1)
Cache_Value(0) = Application("CacheKey_" & Cache_Key)
Cache_Value(1) = Val
Application("Cache_" & Cache_Name) = Cache_Value
End Property

End Class

Function SetCacheKey(Key)
Application("CacheKey_" & Key) = Timer
End Function

Dim Cache
Set Cache = New Cache_Class
%> 

==========================================================================

ASP的XML缓存类,代替了Application

<% 
'========================================= 
' ClassName: RyM_ClsCache 
' Version: 1.0 
' Date: 2006-8-2 
' Author: 网海の求生 
'========================================= 
' 调用说明: 
' Set CC = New RyM_ClsCache '创建对象 
' CC.CreateXmlObj "Temp.xml","/ROYAH_CACHE" 
' CC.Name = "CA" '设置缓存名 
' If CC.IsXmlObj() Then '如果存在缓存则 
' Temp = CC.Value '直接xml中读取值 
' Else 否则 
' Temp = "要缓存的内容，只能是字符串" 
' CC.Value = Temp '把要缓存的值写入xml 
' End If 
' Set CC = Nothing '释放对象 
' 变量Temp就是经过缓存后的字符串值了 
'========================================= 
Class RyM_ClsCache 
Public Reloadtime 
Private XmlDom, XmlDoc, XmlNode, XmlAttr, AttrTime 
Private CacheName, LocalCacheName, XmlPath 
Private Sub Class_Initialize() 
Reloadtime = 14400 
End Sub 
Private Sub Class_Terminate() 
Close() 
End Sub 
'新建文本文件 
Private Function SaveToFile(ByVal strBody,ByVal SavePath) 
Set ObjStream = Server.CreateObject("ADODB.Stream") 
ObjStream.Open 
ObjStream.Type = 2 
ObjStream.Charset = "GB2312" 
ObjStream.WriteText strBody 
ObjStream.SaveToFile SavePath,2 
ObjStream.Close 
Set ObjStream = Nothing 
End Function 
'创建Xml对象 
Public Sub CreateXmlObj(ByVal XmlName, ByVal ChName) 
Set XmlDom = Server.CreateObject("Microsoft.FreeThreadedXMLDOM") 
XmlPath = Server.MapPath(XmlName) 
CacheName = ChName 
If Not XmlDom.Load(XmlPath) Then '如果指定的缓存文件不存在则自动新建 
SaveToFile "<?xml version=""1.0"" encoding=""GB2312""?><ROYAH_CACHE></ROYAH_CACHE>",XmlPath 
XmlDom.Load(XmlPath) 
End If 
End Sub 
'设置返回数据节点名 
Public Property Let Name(ByVal vNewValue) 
LocalCacheName = vNewValue 
If LocalCacheName <> "" Then 
Set XmlDoc = XmlDom.documentElement.selectSingleNode(CacheName & "/" & LocalCacheName) 
End If 
End Property 
'设置当前节点值 
Public Property Let Value(ByVal vNewValue) 
If (XmlDoc Is Nothing) Then 
Set XmlDoc = XmlDom.documentElement.selectSingleNode(CacheName) 
Set XmlNode = XmlDom.createElement(LocalCacheName) 
Set XmlAttr = XmlDom.createAttribute("Time") 
XmlNode.Text = vNewValue 
XmlAttr.Text = Now() 
XmlDoc.AppendChild(XmlNode) 
XmlNode.setAttributeNode XmlAttr 
XmlDom.Save(XmlPath) 
Else 
XmlDoc.Text = vNewValue 
Set AttrTime = XmlDoc.selectSingleNode("./@Time") 
AttrTime.Text = Now() 
XmlDom.Save(XmlPath) 
End If 
End Property 
'返回当前节点值 
Public Property Get Value() 
If Not (XmlDoc Is Nothing) Then 
Value = XmlDoc.Text 
End If 
End Property 
'移除当前节点 
Public Sub Remove() 
If Not (XmlDoc Is Nothing) Then 
XmlDoc.ParentNode.RemoveChild(XmlDoc) 
XmlDom.Save(XmlPath) 
End If 
End Sub 
'检测当前节点是否存在 
Public Function IsXmlObj() 
IsXmlObj = False 
If Not (XmlDoc Is Nothing) Then 
IsXmlObj = True 
Set AttrTime = XmlDoc.selectSingleNode("./@Time") 
If DateDiff("s",CDate(AttrTime.Text),Now()) > (60*Reloadtime) Then IsXmlObj = False 
End If 
End Function 
'释放全部对象 
Public Sub Close() 
If IsObject(XmlDom) Then Set XmlDom = Nothing 
If IsObject(XmlDoc) Then Set XmlDoc = Nothing 
If IsObject(XmlNode) Then Set XmlNode = Nothing 
If IsObject(XmlAttr) Then Set XmlAttr = Nothing 
If IsObject(AttrTime) Then Set XmlAttr = Nothing 
End Sub 
End Class 
%> 

==========================================================================

'/******************************
'类名：XmlCache
'名称：xml缓存类
'日期：2007-12-15
'作者：西楼冷月
'网址：www.xilou.net | www.chinaCMS.org
'描述：缓存名称不区分大小写,也可以是中文,当是字母时会以小写状态存储
'版权：
'******************************
'最后修改：2007-12-15
'修改次数：0
'修改说明：
'目前版本：v1.0
'***************XmlCache属性***************
'Title: xml文档标题
'Creator: xml文档创建人
'DateCreated: xml文档创建时间
'Description: xml文档说明
'Encoding: xml文档编码

'Item: 设置或返回某个缓存的值,可读写
'ItemInfo: 返回数组,某个缓存的所有属性：名称，创建时间，过期时间截，值
' 如果不存在则返回一个空值的数组
'Keys: 返回所有的缓存名称，组成一个数组,只读
'Items: 返回所有缓存的数组,只读

'Count: 缓存个数
'Xml: 返回整份xml文档
'IsAutoUpdate: 当在内存中修改xml时是否自动更新到该xml文件,默认是否False

'***************XmlCache方法***************
'---xml缓存文档的操作
'Load(xmlFile): 加载xml缓存文档
'Create(xmlFile): 创建xml缓存文档
'Save(): 保存一份xml缓存文档
'SaveAs(xmlFile): 将xml缓存文档另存为
'DeleteFile(): 删除xml缓存文档
'---缓存添加:
'Add(key,value): 添加一个缓存,失败返回false(比如：已经存在该key),成功返回true
'AddFull(key,value,s):添加一个缓存，包括名称，值，过期时间截
'---缓存更新:
'Update(key,value): 更新一个缓存值,如果缓存存在并更新成功返回True,否则返回False
'UpdateExpires(key,s):更新一个缓存的过期时间截,如果缓存存在并更新成功返回True,否则返回False
'---缓存删除:
'Remove(key): 删除一个缓存,如果该缓存名称存在而且成功删除则返回True否则返回False
'RemoveAll(): 删除所有缓存,返回True或False
'DeleteAll(): 删除所有过期的缓存,返回True或False(表示没有过期的缓存)
'---缓存读取:
'可以使用Item,ItemInfo,Keys,Items属性操作
'---缓存检查:
'Exists(key): 检查一个缓存是否存在
'CheckExpires(key): 检查一个缓存是否已经过期,是返回True,否返回False
'******************************/


程序代码

<%
'/******************************
'类名：XmlCache
'名称：xml缓存类
'日期：2007-12-15
'作者：西楼冷月
'网址：www.xilou.net | www.chinaCMS.org
'描述：缓存名称不区分大小写,也可以是中文,当是字母时会以小写状态存储
'版权：
'******************************
'最后修改：2007-12-15
'修改次数：0
'修改说明：
'目前版本：v1.0
'***************XmlCache属性***************
'Title: xml文档标题
'Creator: xml文档创建人
'DateCreated: xml文档创建时间
'Description: xml文档说明
'Encoding: xml文档编码

'Item: 设置或返回某个缓存的值,可读写
'ItemInfo: 返回数组,某个缓存的所有属性：名称，创建时间，过期时间截，值
' 如果不存在则返回一个空值的数组
'Keys: 返回所有的缓存名称，组成一个数组,只读
'Items: 返回所有缓存的数组,只读

'Count: 缓存个数
'Xml: 返回整份xml文档
'IsAutoUpdate: 当在内存中修改xml时是否自动更新到该xml文件,默认是否False

'***************XmlCache方法***************
'---xml缓存文档的操作
'Load(xmlFile): 加载xml缓存文档
'Create(xmlFile): 创建xml缓存文档
'Save(): 保存一份xml缓存文档
'SaveAs(xmlFile): 将xml缓存文档另存为
'DeleteFile(): 删除xml缓存文档
'---缓存添加:
'Add(key,value): 添加一个缓存,失败返回false(比如：已经存在该key),成功返回true
'AddFull(key,value,s):添加一个缓存，包括名称，值，过期时间截
'---缓存更新:
'Update(key,value): 更新一个缓存值,如果缓存存在并更新成功返回True,否则返回False
'UpdateExpires(key,s):更新一个缓存的过期时间截,如果缓存存在并更新成功返回True,否则返回False
'---缓存删除:
'Remove(key): 删除一个缓存,如果该缓存名称存在而且成功删除则返回True否则返回False
'RemoveAll(): 删除所有缓存,返回True或False
'DeleteAll(): 删除所有过期的缓存,返回True或False(表示没有过期的缓存)
'---缓存读取:
'可以使用Item,ItemInfo,Keys,Items属性操作
'---缓存检查:
'Exists(key): 检查一个缓存是否存在
'CheckExpires(key): 检查一个缓存是否已经过期,是返回True,否返回False
'******************************/

Class XmlCache

Private xmlDoc'//内部xml对象
Private isLoaded'//是否已经加载xml文档

Private xFile'//加载进来的xml文件(包括路径)
Private xTitle
Private xCreator
Private xDateCreated
Private xLastUpdate
Private xDescription
Private xEncoding

Private itemTemp'//保存item节点的xml摸板

Public IsAutoUpdate'//当在内存中修改xml时是否自动更新到该xml文件,默认是否False

Private Sub Class_Initialize()
Set xmlDoc=getXmlObj()
xTitle=""
xCreator=""
xDateCreated=Now()
xLastUpdate=Now()
xDescription=""
xEncoding="GB2312"
isLoaded=False
IsAutoUpdate=False
'itemTemp=vbcrlf&vbcrlf
itemTemp=itemTemp&" <Item>"&vbcrlf
itemTemp=itemTemp&" <Key>{key}</Key>"&vbcrlf
itemTemp=itemTemp&" <CreatedTime>{createdtime}</CreatedTime>"&vbcrlf
itemTemp=itemTemp&" <Expires>{expires}</Expires>"&vbcrlf
itemTemp=itemTemp&" <Value>"&vbcrlf
itemTemp=itemTemp&" <![CDATA[{value}]]>"&vbcrlf
itemTemp=itemTemp&" </Value>"&vbcrlf
itemTemp=itemTemp&" </Item>"&vbcrlf
End Sub
Private Sub Class_Terminate()
Set xmlDoc=Nothing
End Sub

'返回整个xml文档内容，只读
Public Property Get Xml
Xml=xmlDoc.Xml
End Property

'//Title节点
Public Property Get Title
On Error Resume Next
If isLoaded Then
xTitle=xmlDoc.selectSingleNode("/XmlCache/Title").Text
End If
If Err Then showErr "节点/XmlCache/Title不存在"
Title=xTitle
End Property
Public Property Let Title(v)
xTitle=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/Title").Text=xTitle
End If
If Err Then showErr "节点/XmlCache/Title不存在"
End Property

'//Creator节点
Public Property Get Creator
On Error Resume Next
If isLoaded Then
xCreator=xmlDoc.selectSingleNode("/XmlCache/Creator").Text
End If
If Err Then showErr "节点/XmlCache/Creator不存在"
Creator=xCreator
End Property
Public Property Let Creator(v)
xCreator=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/Creator").Text=xCreator
End If
If Err Then showErr "节点/XmlCache/Creator不存在"
End Property

'//DateCreated节点
Public Property Get DateCreated
On Error Resume Next
If isLoaded Then
xDateCreated=xmlDoc.selectSingleNode("/XmlCache/DateCreated").Text
End If
If Err Then showErr "节点/XmlCache/DateCreated不存在"
DateCreated=xDateCreated
End Property
Public Property Let DateCreated(v)
xDateCreatede=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/DateCreated").Text=xDateCreated
End If
If Err Then showErr "节点/XmlCache/DateCreated不存在"
End Property

'//LastUpdate节点
Public Property Get LastUpdate
On Error Resume Next
If isLoaded Then
xLastUpdate=xmlDoc.selectSingleNode("/XmlCache/LastUpdate").Text
End If
If Err Then showErr "节点/XmlCache/LastUpdate不存在"
LastUpdate=xLastUpdate
End Property
Public Property Let LastUpdate(v)
xLastUpdate=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/LastUpdate").Text=xLastUpdate
End If
If Err Then showErr "节点/XmlCache/LastUpdate不存在"
End Property

'//Description节点
Public Property Get Description
On Error Resume Next
If isLoaded Then
xDescription=xmlDoc.selectSingleNode("/XmlCache/Description").Text
End If
If Err Then showErr "节点/XmlCache/Description不存在"
Description=xDescription
End Property
Public Property Let Description(v)
xDescription=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/Description").Text=xDescription
End If
If Err Then showErr "节点/XmlCache/Description不存在"
End Property

'//Encoding
Public Property Get Encoding
On Error Resume Next
If isLoaded Then
xEncoding=xmlDoc.selectSingleNode("/XmlCache/Encoding").Text
End If
If Err Then showErr "节点/XmlCache/Encoding不存在"
Encoding=xEncoding
End Property
Public Property Let Encoding(v)
xEncoding=v
On Error Resume Next
If isLoaded Then
xmlDoc.selectSingleNode("/XmlCache/Encoding").Text=xEncoding
End If
If Err Then showErr "节点/XmlCache/Encoding不存在"
End Property

'//Item节点,设置或返回该缓存的值,可读写
'//如果该值不存在则返回null值
Public Default Property Get Item(key)
Dim itemObj,k
key=LCase(key)
Set itemObj=xmlDoc.selectSingleNode("/XmlCache/Items/Item")
For Each k In itemObj
If k.childNodes.item(0).text=key Then
Item=k.childNodes.item(3).text'缓存值
Set itemObj=Nothing
Exit Property
End If
Next
Item=Null
Set itemObj=Nothing
End Property
Public Property Let Item(key,v)
Dim itemObj,k
key=LCase(key)
Set itemObj=xmlDoc.selectSingleNode("/XmlCache/Items/Item")
On Error Resume Next
For Each k In itemObj
If k.childNodes.item(0).text=key Then
k.childNodes.item(3).text=v'缓存值
If Err Then
showErr"缓存值不是有效的字符串"
Set itemObj=Nothing
Exit Property
End If
Set itemObj=Nothing
Call Save()
Exit Property
End If
Next
Item=Null
Set itemObj=Nothing
Call Save()
End Property

'//某个缓存的所有属性：名称，创建时间，过期时间截，值
'//如果不存在则返回一个空值的数组
Public Property Get ItemInfo(key)
Dim itemObj,infoArr(3),i
key=LCase(key)
Set itemObj=xmlDoc.getElementsByTagName("Item")
For i=0 To itemObj.length-1
If itemObj.item(i).childNodes.item(0).text=key Then
infoArr(0)=itemObj.item(i).childNodes.item(0).text'缓存名称
infoArr(1)=itemObj.item(i).childNodes.item(1).text'创建时间
infoArr(2)=itemObj.item(i).childNodes.item(2).text'过期时间截
infoArr(3)=itemObj.item(i).childNodes.item(3).text'缓存值
End If
Next
Set itemObj=Nothing
ItemInfo=infoArr
End Property

'//返回所有的缓存名称，组成一个数组,只读
Public Property Get Keys()
Dim keyObj,keyArr,i
Set keyObj=xmlDoc.getElementsByTagName("Key")
keyArr=Array()
Redim keyArr(keyObj.length-1)
For i=0 To keyObj.length-1
keyArr(i)=keyObj.item(i).text
Next
Keys=keyArr
Erase keyArr
Set keyObj=Nothing
End Property

'//返回所有缓存的数组,只读
Public Property Get Items()
Dim itemArr,itemInfoArr,itemObj,i
Set itemObj=xmlDoc.getElementsByTagName("Item")
itemArr=Array()
ReDim itemArr(itemObj.length-1,3)
For i=0 To itemObj.length-1
itemArr(i,0)=itemObj.item(i).childNodes.item(0).text'缓存名称
itemArr(i,1)=itemObj.item(i).childNodes.item(1).text'创建时间
itemArr(i,2)=itemObj.item(i).childNodes.item(2).text'过期时间截
itemArr(i,3)=itemObj.item(i).childNodes.item(3).text'缓存值
Next
Set itemObj=Nothing
Items=itemArr
Erase itemArr
End Property

'//缓存个数,只读
Public Property Get Count
Count=xmlDoc.getElementsByTagName("Item").Length
End Property

'/------------------------------------------------------

'//加载一份xml文档
Public Sub Load(xmlFile)
On Error Resume Next
xmlDoc.Load(xmlFile)
xFile=xmlFile
If Err Then showErr "加载xml文档失败,Load(xmlFile),xmlFile:"&xmlFile
isLoaded=True
End Sub

'//创建一份xml文档
Public Sub Create(xmlFile)
Dim xmlText,newXmlDoc
If xEncoding="" Then xEncoding="GB2312"
xDateCreated=Now()
xLastUpdate=Now()
xmlText="<?xml version=""1.0"" encoding="""&Encoding&"""?>"&vbcrlf
xmlText=xmlText&"<XmlCache>"&vbcrlf
xmlText=xmlText&" <Title>"&Title&"</Title>"&vbcrlf
xmlText=xmlText&" <Creator>"&Creator&"</Creator>"&vbcrlf
xmlText=xmlText&" <DateCreated>"&CreatedTime&"</DateCreated>"&vbcrlf
xmlText=xmlText&" <LastUpdate>"&LastUpdate&"</LastUpdate>"&vbcrlf
xmlText=xmlText&" <Description>"&Description&"</Description>"&vbcrlf
xmlText=xmlText&" <Encoding>"&Encoding&"</Encoding>"&vbcrlf
xmlText=xmlText&" <Items>"&vbcrlf
xmlText=xmlText&" </Items>"&vbcrlf
xmlText=xmlText&"</XmlCache>"&vbcrlf

Set newXmlDoc=getXmlObj()
On Error Resume Next
newXmlDoc.LoadXml(xmlText)
newXmlDoc.Save xmlFile
If Err Then showErr "创建xml文档失败,Create(xmlFile),xmlFile:"&xmlFile
Set newXmlDoc=Nothing
End Sub

'//保存一份xml文档
Public Sub Save()
On Error Resume Next
xmlDoc.Save xFile
If Err Then showErr "保存xml文档失败,Save(),xmlFile:"&xmlFile
End Sub

'//保存一份xml文档，文件名为xmlFile(全路径)
Public Sub SaveAs(xmlFile)
On Error Resume Next
xmlDoc.Save xmlFile
If Err Then showErr "保存xml文档失败,SaveAs(xmlFile),xmlFile:"&xmlFile
End Sub

'//删除xml文档
Public Sub DeleteFile()
End Sub

'//检查缓存xml文档是否存在某个key,返回true或false
'//检查一个缓存是否存在
Public Function Exists(key)
Dim itemObj,k
key=LCase(key)
Set itemObj=xmlDoc.selectNodes("/XmlCache/Items/Item/Key")
For Each k In itemObj
If k.text=key Then Exists=True:Exit Function
Next
Exits=Flase
End Function

'//添加一个缓存,失败返回false(比如：已经存在该key),成功返回true
Public Sub Add(key,value)
If key="" Then showErr"添加缓存失败,Add(key,value),key不能为空":Exit Sub
If Exists(key) Then showErr"添加缓存失败,Add(key,value),该key已经存在":Exit Sub

Dim itemsObj,itemObj,temp
key=LCase(key)
Set itemsObj=xmlDoc.documentElement.getElementsByTagName("Items")
If itemsObj.length>0 Then
temp=itemTemp
temp=Replace(temp,"{key}",key):temp=Replace(temp,"{value}",value)
temp=Replace(temp,"{createdtime}",Now()):temp=Replace(temp,"{expires}",60*20)
Set itemObj=getXmlObj()
itemObj.loadXml(temp)
Set itemObj=itemObj.documentElement.cloneNode(true)'//复制节点
itemsObj.item(0).appendChild itemObj
Call Save()
Set itemObj=Nothing
Else
showErr "添加缓存失败,Add(key,value),/XmlCache/Items节点不存在"
End If
Set ItemObj =Nothing
Set itemsObj=Nothing
End Sub

'//添加一个缓存，包括名称，值，过期时间
Public Sub AddFull(key,value,s)
If key="" Then showErr"添加缓存失败,AddFull(key,value,s),key不能为空":Exit Sub
If Not IsNumeric(s) Then showErr"添加缓存失败,AddFull(key,value,s),过期时间截s只能为数字":Exit Sub
If Exists(key) Then showErr"添加缓存失败,AddFull(key,value,s),该key已经存在":Exit Sub
Dim itemsObj,temp,xmlText,L
key=LCase(key)
Set itemsObj=xmlDoc.documentElement.getElementsByTagName("Items")
If itemsObj.length>0 Then
temp=itemTemp
temp=Replace(temp,"{key}",key):temp=Replace(temp,"{value}",value)
temp=Replace(temp,"{createdtime}",Now()):temp=Replace(temp,"{expires}",s)
Set itemObj=getXmlObj()
itemObj.loadXml(temp)
Set itemObj=itemObj.documentElement.cloneNode(true)'//复制节点
itemsObj.item(0).appendChild itemObj
Call Save()
Set itemObj=Nothing
Else
showErr "添加缓存失败,AddFull(key,value,s),/XmlCache/Items节点不存在"
End If
Set itemsObj=Nothing
End Sub

'//更新一个缓存值,如果缓存存在并更新成功返回True,否则返回False
Public Function Update(key,value)
Dim nodeItems,valueItems,i
key=LCase(key)
Set nodeItems=xmlDoc.getElementsByTagName("Key")
Set valueItems =xmlDoc.getElementsByTagName("Value")
On Error Resume Next
For i = 0 To nodeItems.length - 1
If nodeItems(i).text=key Then
valueItems(i).text=value
If Err Then
showErr "更新缓存失败,Update(key,value),Value节点不存在"
Update=False
Exit Function
End If
Update=True
Call xUpdate()
Exit Function
End If
Next
Set nodeItems=Nothing
Set valueItems=Nothing
Update=False
End Function

'//更新一个缓存的过期时间,如果缓存存在并更新成功返回True,否则返回False
Public Function UpdateExpires(key,s)
If Not IsNumeric(s) Then 
showErr"更新缓存错误,UpdateTimeOut(key,s),过期时间截s只能为数字"
UpdateExpires=False
Exit Function
End If
Dim nodeItems,expiresItems,i
key=LCase(key)
Set nodeItems=xmlDoc.getElementsByTagName("Key")
Set expiresItems=xmlDoc.getElementsByTagName("Expires")
On Error Resume Next
For i = 0 To nodeItems.length - 1
If nodeItems(i).text=key Then
expiresItems(i).text=s
If Err Then 
showErr "更新缓存失败,UpdateTimeOut(key,value),Expires节点不存在"
UpdateExpires=False
Exit Function
End If
UpdateExpires=True
Call xUpdate()
Exit Function
End If
Next
Set nodeItems=Nothing
Set expiresItems=Nothing
UpdateExpires=False
End Function

'//检查一个缓存是否已经过期,是返回True,否返回False
Public Function CheckExpires(key)
Dim keyObj,createdObj,expiresObj,i,s1,s2,s3
Set keyObj=xmlDoc.getElementsByTagName("Key")
Set createdObj=xmlDoc.getElementsByTagName("CreatedTime")
Set expiresObj=xmlDoc.getElementsByTagName("Expires")

For i=0 To keyObj.length-1
s1=keyObj.item(i).text
s2=createdObj.item(i).text
s3=expiresObj.item(i).text
If s1=key And IsDate(s2) And IsNumeric(s3) Then
If DateDiff("s",s1,Now())>CDbl(s2) Then
CheckExpires=True
Set keyObj=Nothing
Set createdObj=Nothing
Set expiresObj=Nothing
Exit Function
End If
End If
Next
Set keyObj=Nothing
Set createdObj=Nothing
Set expiresObj=Nothing
CheckExpires=False
End Function

'//Remove(key)删除一个缓存,如果该缓存名称存在而且成功删除则返回True否则返回False
Public Function Remove(key)
Dim keyObj,k
key=LCase(key)
Set keyObj=xmlDoc.getElementsByTagName("Key")
For Each k In keyObj
If k.text=key Then
k.parentNode.parentNode.removeChild(k.parentNode)
Remove=True
Set keyObj=Nothing
Exit Function
End If
Next
Remove=False
Set keyObj=Nothing
Call xUpdate()'//重新保存到文件
End Function

'//删除所有缓存,返回True或False
Public Function RemoveAll()
Dim itemsObj
Set itemsObj=xmlDoc.getElementsByTagName("Items")
If itemsObj.length=1 Then
itemsObj(0).text=""
RemoveAll=True
Else
RemoveAll=False
End If
Set itemsObj=Nothing
Call xUpdate()'//重新保存到文件
End Function

'//删除所有过期的缓存,返回True或False(表示没有过期的缓存) 
Public Function DeleteAll()
Dim createdObj,expiresObj,isHave,i
isHave=False'//是否有过期的缓存
Set createdObj=xmlDoc.getElementsByTagName("CreatedTime")
Set expiresObj=xmlDoc.getElementsByTagName("Expires")

For i=0 To expiresObj.length-1
If IsDate(createdObj.item(i).text) And IsNumeric(expiresObj.item(i).text) Then
If DateDiff("s",createdObj.item(i).text,Now())>CDbl(expiresObj.item(i).text) Then
createdObj.item(i).parentNode.parentNode.removeChild(createdObj.item(i).parentNode)
isHave=True
End If
End If
Next
Set createdObj=Nothing
Set expiresObj=Nothing
DeleteAll=isHave
Call xUpdate()'//重新保存到文件
End Function

'//显示错误
Private Sub showErr(info)
If Err Then info=info&","&Err.Description
Response.Write info
Err.Clear
Response.End
End Sub

'//取得xml对象
Private Function getXmlObj()
On Error Resume Next
Set getXmlObj=Server.CreateObject("Microsoft.XMLDOM")
If Err Then showErr "创建xml对象失败"
End Function

'//更新一份xml文档
Private Sub xUpdate()
If IsAutoUpdate Then Call Save()
End Sub

'------------------------------------------------------/
End Class

%>
==============================================================================
动网先锋缓存类 提取 8.1 Dv_ClsMain.asp文件提取
经过测试适用。。。。。。
全文如下
<%
Dim dvbbs,txt
Set dvbbs=New Cls_Cache
Class Cls_Cache
Public Reloadtime,MaxCount,CacheName
Private LocalCacheName
Private Sub Class_Initialize()
Reloadtime=14400 ’默认缓存时间分钟
CacheName="dvbbs" ‘缓存总名
'CacheName=LCase(CacheName)
End Sub
Public Property Let Name(ByVal vNewValue)
LocalCacheName = LCase(vNewValue)
End Property
Public Property Let Value(ByVal vNewValue)
If LocalCacheName<>"" Then
Application.Lock
Application(CacheName & "_" & LocalCacheName &"_-time")=Now()
Application(CacheName & "_" & LocalCacheName) = vNewValue
Application.unLock
End If
End Property
Public Property Get Value()
If LocalCacheName<>"" Then 
Value=Application(CacheName & "_" & LocalCacheName)
End If
End Property
Public Function ObjIsEmpty()
ObjIsEmpty=True 
If Not IsDate(Application(CacheName & "_" & LocalCacheName &"_-time")) Then Exit Function
If DateDiff("s",CDate(Application(CacheName & "_" & LocalCacheName &"_-time")),Now()) < (60*Reloadtime) Then ObjIsEmpty=False
End Function
Public Sub DelCahe(MyCaheName)
Application.Lock
Application.Contents.Remove(CacheName&"_"&MyCaheName & "_-time")
Application.Contents.Remove(CacheName&"_"&MyCaheName)
Application.unLock
End Sub
End Class
%>
以上保存为一个文件
如Cache.asp

然后需要缓存数据的页面包含Cache.asp文件不用我说了吧
‘’‘’‘’‘’‘调用开始
’CacheName="dvbbs" ‘设立了缓存总名的可以不要这行 如果修改了这个 所有DVBBS 要修改 如dvbbs.Name就要改成新的对应的总名
dvbbs.Reloadtime=1 ’如果不按默认缓存时间才写 要不可以屏蔽
dvbbs.Name="01" ‘缓存子名必须
If vod.ObjIsEmpty() Then
txt=""
txt=“【这里是你要缓存的数据 可以是执行代码怎么写就看个人了】”
if txt = "" then txt = "暂无数据"&vbCrLf
txt=txt&"<!--上次更新"&now()&"下次更新将在"&dvbbs.Reloadtime&"分钟后-->"&vbCrLf
dvbbs.value=txt
Else
txt=dvbbs.value
End If
Response.Write txt ‘这里是输出显示可以修改适用’
’‘’‘’‘’‘调用结束

==========================================================================
程序代码
<%
'***********************************************
'函数名：getcache
'作 用：将需要缓存的内容，置入缓存中，并读取出来，如果缓存中存在该内容，则直接从缓存读取！
'作 者: 静￠脉(hayden) 
'时 间: 2007-12-21
'参 数：funsname ---- 需要缓存的内容
' isreset ---- 是否更新[值：0(根据时间或判断缓存为空时自动更新)、１(主动更新)]
' isarr ---- 所缓存的内容是否为一个数据[0为字符串，1为数组]
' timeinfo ---- 缓存更新时间，单位为秒,当值为0时，则只在缓存为空时，才更新
'返回值：缓存名为"funsname”的内容
'***********************************************
Function getcache(funsname,isreset,isarr,timeinfo)
dim domain : domain = "myhhe.cn" '缓存域
Dim temp_getconfig
Dim re_getcache : re_getcache = False
Dim temp_isarray_type : temp_isarray_type = False
Dim Appfunsname : Appfunsname = Replace(Replace(Replace(funsname,"(",""),")",""),",",".")
If isarr = 1 Then temp_isarray_type = True
If isreset = 1 Then re_getcache = True
If isreset = 2 Then 
execute("temp_getconfig="&funsname)
getcache = temp_getconfig
Exit Function
End If 
If Application(domain&"_"&Appfunsname&"_time") = "" And timeinfo<>0 Then re_getcache = True 
If Not re_getcache Then 
If temp_isarray_type Then 
If Not IsArray(Application(domain&"_"&Appfunsname)) Then re_getcache = True
Else
If Application(domain&"_"&Appfunsname) = "" Then re_getcache = True
End If
End If 
If Not re_getcache And timeinfo<>0 Then 
If Int(DateDiff("s",Application(domain&"_"&Appfunsname&"_time"),now()))>timeinfo Then re_getcache = True
End If 
If re_getcache Then 
execute("temp_getconfig="&funsname)
Application.Lock
Application(domain&"_"&Appfunsname) = temp_getconfig
Application(domain&"_"&Appfunsname&"_time") = Now()
Application.UnLock
Else
temp_getconfig=Application(domain&"_"&Appfunsname)
End If 
getcache = temp_getconfig
End Function
%>


调用示例：

程序代码
<%
Function out_test1 '返回一个字符串的示例函数
out_test1="这里是一个字符串"
End Function

Function out_test2 '返回一个数组的示例函数
Dim temp_out_test2
temp_out_test2="这里.是.一个.数组"
out_test2=Split(temp_out_test2,".")
End Function

Dim i

'字符串缓存（将函数out_test1从缓存读取并输出）
Dim str2 : str2 = getcache("out_test1",0,0,180) '通过getcache函数读取缓存.刷新时间为180秒，（当out_test1缓存为空，会自动访问函数out_test1输出，并同时置入缓存～）
response.write str2

response.write "<BR><BR><BR>"

'数组缓存（将函数out_test2从缓存读取并输出）
Dim str1 : str1 = getcache("out_test2",0,1,180)　　'同上（字符串缓存说明）
For i = 0 To UBound(str1)
response.write str1(i) & "<BR>"
Next
%>

　　

转载于:https://www.cnblogs.com/uuxanet/p/3282772.html