<%
Rem xml cache class
Class XmlCacheCls
Private m_DataConn 'Data source, must be opened
Private m_CacheTime 'CacheTime, default to 10 minutes in seconds
Private m_XmlFile 'xml path, use absolute address, no extension is required
Private m_Sql 'SQL statement
Private m_SQLArr '(read-only) return data array
Private m_ReadOn '(read-only) Returns reading method 1-database 2-xml for detection
'Class attributes==================================================
'Data source
Public Property Set Conn(v)
Set m_DataConn = v
End Property
Public Property Get Conn
Conn = m_DataConn
End Property
'Cache time
Public Property Let CacheTime(v)
m_CacheTime = v
End Property
Public Property Get CacheTime
CacheTime = m_CacheTime
End Property
'xml path, with absolute address
Public Property Let XmlFile(v)
m_XmlFile = v
End Property
Public Property Get XmlFile
XmlFile = m_XmlFile
End Property
'Sql statement
Public Property Let Sql(v)
m_Sql = v
End Property
Public Property Get Sql
Sql = m_Sql
End Property
'Return to the record array
Public Property Get SQLArr
SQLArr = m_SQLArr
End Property
'Return to read method
Public Property Get ReadOn
ReadOn = m_ReadOn
End Property
'Class destruction========================================================
Private Sub Class_Initialize() 'Initialize class
m_CacheTime=60*10 'Default cache time is 10 minutes
End Sub
Private Sub Class_Terminate() 'Release class
End Sub
'Public method of class===========================================================
Rem Read data
Public Function ReadData
If FSOExistsFile(m_XmlFile) Then 'There is an xml cache, read directly from the xml
ReadDataFromXml
m_ReadOn=2
Else
ReadDataFromDB
m_ReadOn=1
End if
End Function
Rem Write XML data
Public Function WriteDataToXml
If FSOExistsFile(m_XmlFile) Then 'If xml has not expired, exit directly
If Not isXmlCacheExpired(m_XmlFile,m_CacheTime) Then Exit Function
End if
Dim rs
Dim xmlcontent
Dim k
xmlcontent =
xmlcontent = xmlcontent & <?xml version=1.0 encoding=gb2312?> & vbnewline
xmlcontent = xmlcontent & <root> & vbnewline
k=0
Set Rs = Server.CreateObject(Adodb.Recordset)
Rs.open m_sql,m_DataConn,1
While Not rs.eof
xmlcontent = xmlcontent & <item
For Each field In rs.Fields
xmlcontent = xmlcontent & field.name & = & XMLStringEnCode(field.value) &
Next
rs.movenext
k=k+1
xmlcontent = xmlcontent &></item> & vbnewline
Wend
rs.close
Set rs = Nothing
xmlcontent = xmlcontent & </root> & vbnewline
Dim folderpath
folderpath = Trim(left(m_XmlFile,InstrRev(m_XmlFile,/)-1))
Call CreateDIR(folderpath&) 'Create folder
WriteStringToXMLFile m_XmlFile,xmlcontent
End Function
'Private method of class========================================================
Rem Read data from Xml file
Private Function ReadDataFromXml
Dim SQLARR() 'array
Dim XmlDoc 'XmlDoc object
Dim objNode 'child node
Dim ItemsLength 'Length of child nodes
Dim AttributesLength 'Length of child node attribute
Set XmlDoc=Server.CreateObject(Microsoft.XMLDOM)
XmlDoc.Async=False
XmlDoc.Load(m_XmlFile)
Set objNode=XmlDoc.documentElement 'Get root node
ItemsLength=objNode.ChildNodes.length 'Get the length of the child node
For items_i=0 To ItemsLength-1
AttributesLength=objNode.childNodes(items_i).Attributes.length 'Get the length of the child node attribute
For Attributes_i=0 To AttributesLength-1
ReDim Preserve SQLARR(AttributesLength-1,items_i)
SQLArr(Attributes_i,items_i) = objNode.childNodes(items_i).Attributes(Attributes_i).Nodevalue
Next
Next
Set XmlDoc = Nothing
m_SQLArr = SQLARR
End Function
Rem Read data from the database
Private Function ReadDataFromDB
Dim rs
Dim SQLARR()
Dim k
k=0
Set Rs = Server.CreateObject(Adodb.Recordset)
Rs.open m_sql,m_DataConn,1
If Not (rs.eof and rs.bof) Then
While Not rs.eof
Dim fieldlegth
fieldlegth = rs.Fields.count
ReDim Preserve SQLARR(fieldlegth,k)
Dim fieldi
For fielddi = 0 To fieldlegth-1
SQLArr(fieldi,k) = rs.Fields(fieldi).value
Next
rs.movenext
k=k+1
Wend
End if
rs.close
Set rs = Nothing
m_SQLArr = SQLArr
End Function
'Auxiliary private method of class=====================================================
Rem writes xml file
Private Sub WriteStringToXMLFile(filename,str)
Dim fs,ts
Set fs= createobject(scripting.filesystemobject)
If Not IsObject(fs) Then Exit Sub
Set ts=fs.OpenTextFile(filename,2,True)
ts.writeline(str)
ts.close
Set ts=Nothing
Set fs=Nothing
End Sub
Rem determines whether the xml cache expires
Private Function isXmlCacheExpired(file,seconds)
Dim filelasttime
filelasttime = FSOGetFileLastModifiedTime(file)
If DateAdd(s,seconds,filelasttime) < Now Then
isXmlCacheExpired = True
Else
isXmlCacheExpired = False
End if
End Function
Rem Get the last modification time of the file
Private Function FSOGetFileLastModifiedTime(file)
Dim fso,f,s
Set fso=CreateObject(Scripting.FileSystemObject)
Set f=fso.GetFile(file)
FSOGetFileLastModifiedTime = f.DateLastModified
Set f = Nothing
Set fso = Nothing
End Function
Does the Rem file exist?
Public Function FSOExistsFile(file)
Dim fso
Set fso = Server.CreateObject(Scripting.FileSystemObject)
If fso.FileExists(file) Then
FSOExistsFile = true
Else
FSOExistsFile = false
End if
Set fso = nothing
End Function
Rem xml escape characters
Private Function XMLStringEnCode(str)
If str& = Then XMLStringEnCode=:Exit Function
str = Replace(str,<,<)
str = Replace(str,>,>)
str = Replace(str,',')
str = Replace(str,,)
str = Replace(str,&,&)
XMLStringEnCode = str
End Function
Rem Create folder
Private function CreateDIR(byval LocalPath)
On Error Resume Next
Dim i,FileObject,patharr,path_level,pathtmp,cpath
LocalPath = Replace(LocalPath,/,/)
Set FileObject = server.createobject(Scripting.FileSystemObject)
patharr = Split(LocalPath,/)
path_level = UBound (patharr)
For i = 0 To path_level
If i=0 Then
pathtmp=patharr(0) & /
Else
pathtmp = pathtmp & patharr(i) & /
End if
cpath = left(pathtmp,len(pathtmp)-1)
If Not FileObject.FolderExists(cpath) Then
'Response.write cpath
FileObject.CreateFolder cpath
End if
Next
Set FileObject = Nothing
If err.number<>0 Then
CreateDIR = False
err.Clear
Else
CreateDIR = True
End if
End Function
End Class
'Set cache
Function SetCache(xmlFilePath,CacheTime,Conn,Sql)
set cache=new XmlCacheCls
Set cache.Conn=Conn
cache.XmlFile=xmlFilePath
cache.Sql=Sql
cache.CacheTime=CacheTime
cache.WriteDataToXml
Set cache = Nothing
End Function
'Read cache
Function ReadCache(xmlFilePath,Conn,Sql,ByRef ReadOn)
set cache=new XmlCacheCls
Set cache.Conn=conn
cache.XmlFile=xmlFilePath
cache.Sql=Sql
cache.ReadData
ReadCache=cache.SQLArr
ReadOn=cache.ReadOn
End Function
%>
How to use:
1 Cache data to xml
Code:
Program code
<!--#include file=Conn.asp-->
<!--#include file=Xml.asp-->
<%
set cache=new XmlCacheCls
Set cache.Conn=conn
cache.XmlFile=Server.Mappath(xmlcache/index/Top.xml)
cache.Sql=select top 15 prod_id,prod_name,prod_uptime from tblProduction
cache.WriteDataToXml
%>
2 Read cached data
Code:
Program code
<!--#include file=Conn.asp-->
<!--#include file=Xml.asp-->
<%
set cache=new XmlCacheCls
Set cache.Conn=conn
cache.XmlFile=Server.Mappath(xmlcache/index/Top.xml)
cache.Sql=select top 15 prod_id,prod_name,prod_uptime from tblProduction order by prod_id asc
cache.ReadData
rsArray=cache.SQLArr
if isArray(rsArray) then
for i=0 to ubund(rsArray,2)
for j=0 to ubund(rsArray,1)
response.Write(rsArray(j,i)&<br><br>)
next
next
end if
%>
The cache time is 10 minutes by default in seconds; you can also set cache.CacheTime=60*30 30 minutes by yourself