<% 
Rem xml緩存類 
'-------------------------------------------------------------------- 
'轉載的時候請保留版權信息 
'作者:╰⑥月の雨╮ 
'版本:ver1.0 
'本類部分借鑒 walkmanxml數據緩存類，使用更為方便 歡迎各位交流進步 
'-------------------------------------------------------------------- 
Class XmlCacheCls 
Private m_DataConn '數據源,必須已經打開 
Private m_CacheTime '緩存時間，單位秒 默認10分鐘 
Private m_XmlFile 'xml路徑，用絕對地址,不需要加擴展名 
Private m_Sql 'SQL語句 
Private m_SQLArr '(只讀)返回的數據數組 
Private m_ReadOn '(只讀)返回讀取方式 1-數據庫 2-xml 檢測用 

'類的屬性========================================= 

'數據源 
Public Property Set Conn(v) 
Set m_DataConn = v 
End Property 
Public Property Get Conn 
Conn = m_DataConn 
End Property 

'緩存時間 
Public Property Let CacheTime(v) 
m_CacheTime = v 
End Property 
Public Property Get CacheTime 
CacheTime = m_CacheTime 
End Property 

'xml路徑，用絕對地址 
Public Property Let XmlFile(v) 
m_XmlFile = v 
End Property 
Public Property Get XmlFile 
XmlFile = m_XmlFile 
End Property 

'Sql語句 
Public Property Let Sql(v) 
m_Sql = v 
End Property 
Public Property Get Sql 
Sql = m_Sql 
End Property 
'返回記錄數組 
Public Property Get SQLArr 
SQLArr = m_SQLArr 
End Property 

'返回讀取方式 
Public Property Get ReadOn 
ReadOn = m_ReadOn 
End Property 

'類的析構========================================= 

Private Sub Class_Initialize() '初始化類 
m_CacheTime=60*10 '默認緩存時間為10分鐘 
End Sub 

Private Sub Class_Terminate() '釋放類 

End Sub 

'類的公共方法========================================= 

Rem 讀取數據 
Public Function ReadData 
If FSOExistsFile(m_XmlFile) Then '存在xml緩存，直接從xml中讀取 
ReadDataFromXml 
m_ReadOn=2 
Else 
ReadDataFromDB 
m_ReadOn=1 
End If 
End Function 

Rem 寫入XML數據 
Public Function WriteDataToXml 
If FSOExistsFile(m_XmlFile) Then '如果xml未過期則直接退出 
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&"") '創建文件夾 
WriteStringToXMLFile m_XmlFile,xmlcontent 
End Function 

'類的私有方法========================================= 

Rem 從Xml文件讀取數據 
Private Function ReadDataFromXml 
Dim SQLARR() '數組 
Dim XmlDoc 'XmlDoc對象 
Dim objNode '子節點 
Dim ItemsLength '子節點的長度 
Dim AttributesLength '子節點屬性的長度 
Set XmlDoc=Server.CreateObject("Microsoft.XMLDOM") 
XmlDoc.Async=False 
XmlDoc.Load(m_XmlFile) 
Set objNode=XmlDoc.documentElement '獲取根節點 
ItemsLength=objNode.ChildNodes.length '獲取子節點的長度 
For items_i=0 To ItemsLength-1 
AttributesLength=objNode.childNodes(items_i).Attributes.length '獲取子節點屬性的長度 
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 從數據庫讀取數據 
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 fieldi = 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 

'類的輔助私有方法========================================= 

Rem 寫xml文件 
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 判斷xml緩存是否到期 
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 得到文件的最后修改時間 
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 

Rem 文件是否存在 
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轉義字符 
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 創建文件夾 
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 
'設置緩存 
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 
'讀取緩存 
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 
%> 

<!--#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 
%> 

<!--#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 ubound(rsArray,2) 
for j=0 to ubound(rsArray,1) 
response.Write(rsArray(j,i)&"<br><br>") 
next 
next 
end if 
%>