程式透過使用ASP的FSO功能，減少資料庫的讀取。經測試，可以減少90%的伺服器負載。頁面存取速度基本上與靜態頁面相當。複製代碼代碼如下:
<%@LANGUAGE=VBSCRIPT CODEPAGE=65001%>
<% Response.CodePage=65001%>
<% Response.Charset=UTF-8 %>
<%
'該程式透過使用ASP的FSO功能，減少資料庫的讀取。經測試，可以減少90%的伺服器負載。頁面存取速度基本上與靜態頁面相當。
'使用方法：將該文件放在網站裡，然後在需要引用的文件的第一行用include引用即可。
'=======================參數區========================== =====
DirName=cachenew/ '靜態檔案儲存的目錄，結尾要帶/。無須手動建立，程式會自動建立。
TimeDelay=30 '更新的時間間隔，單位為分鐘，如1440分鐘為1天。產生的靜態檔案會在該間隔之後被刪除。
'======================主程式區======================== ====
foxrax=Request(foxrax)
if foxrax= then
FileName=GetStr()&.txt
FileName=DirName&FileName
if tesfold(DirName)=false then'如果不存在資料夾則創建
createfold(Server.MapPath(.)&/&DirName)
end if
if ReportFileStatus(Server.MapPath(.)&/&FileName)=true then'如果存在產生的靜態檔案,則直接讀取文件
Set FSO=CreateObject(Scripting.FileSystemObject)
Dim Files,LatCatch
Set Files=FSO.GetFile(Server.MapPath(FileName)) '定義CatchFile檔案對象
LastCatch=CDate(Files.DateLastModified)
If DateDiff(n,LastCatch,Now())>TimeDelay Then'超過
List=getHTTPPage(GetUrl())
WriteFile(FileName)
Else
List=ReadFile(FileName)
End If
Set FSO = nothing
Response.Write(List)
Response.End()
else
List=getHTTPPage(GetUrl())
WriteFile(FileName)
end if
end if
'========================函數區======================= =====
'獲取當前頁面url
Function GetStr()
'On Error Resume Next
Dim strTemps
strTemps = strTemps & Request.ServerVariables(HTTP_X_REWRITE_URL)
GetStr = Server.URLEncode(strTemps)
End Function
'取得快取頁面url
Function GetUrl()
On Error Resume Next
Dim strTemp
If LCase(Request.ServerVariables(HTTPS)) = off Then
strTemp = http://
Else
strTemp = https://
End If
strTemp = strTemp & Request.ServerVariables(SERVER_NAME)
If Request.ServerVariables(SERVER_PORT) <> 80 Then
strTemp = strTemp & : & Request.ServerVariables(SERVER_PORT)
end if
strTemp = strTemp & Request.ServerVariables(URL)
If Trim(Request.QueryString) <> Then
strTemp = strTemp & ? & Trim(Request.QueryString) & &foxrax=foxrax
else
strTemp = strTemp & ? & foxrax=foxrax
end if
GetUrl = strTemp
End Function
'抓取頁面
Function getHTTPPage(url)
Set Mail1 = Server.CreateObject(CDO.Message)
Mail1.CreateMHTMLBody URL,31
AA=Mail1.HTMLBody
Set Mail1 = Nothing
getHTTPPage=AA
'Set Retrieval = Server.CreateObject(Microsoft.Xmlhttp)
'Retrieval.Open GET,url,false,,
'Retrieval.Send
'getHTTPPage = Retrieval.ResponseBody
'Set Retrieval = Nothing
End Function
Sub WriteFile(filePath)
dim stm
set stm=Server.CreateObject(adodb.stream)
stm.Type=2 'adTypeText，文字數據
stm.Mode=3 'adModeReadWrite,讀取寫入，此參數用2則報錯
stm.Charset=utf-8
stm.Open
stm.WriteText list
stm.SaveToFile Server.MapPath(filePath),2 'adSaveCreateOverWrite，檔案存在則覆蓋
stm.Flush
stm.Close
set stm=nothing
End Sub
Function ReadFile(filePath)
dim stm
set stm=Server.CreateObject(adodb.stream)
stm.Type=1 'adTypeBinary，以二進位資料讀入
stm.Mode=3 'adModeReadWrite ,這裡只能用3用其他會出錯
stm.Open
stm.LoadFromFile Server.MapPath(filePath)
stm.Position=0 '把指針移回起點
stm.Type=2 '文字數據
stm.Charset=utf-8
ReadFile = stm.ReadText
stm.Close
set stm=nothing
End Function
'檢測文件是否存在
Function ReportFileStatus(FileName)
set fso = server.createobject(scripting.filesystemobject)
if fso.fileexists(FileName) = true then
ReportFileStatus=true
else
ReportFileStatus=false
end if
set fso=nothing
end function
'檢測目錄是否存在
function tesfold(foname)
set fs=createobject(scripting.filesystemobject)
filepathjm=server.mappath(foname)
if fs.folderexists(filepathjm) then
tesfold=True
else
tesfold= False
end if
set fs=nothing
end function
'建立目錄
sub createfold(foname)
set fs=createobject(scripting.filesystemobject)
fs.createfolder(foname)
set fs=nothing
end sub
'刪除文件
function del_file(path) 'path，檔案路徑包含檔名
set objfso = server.createobject(scripting.FileSystemObject)
'path=Server.MapPath(path)
if objfso.FileExists(path) then '若存在則刪除
objfso.DeleteFile(path) '刪除文件
else
'response.write <script language='Javascript'>alert('檔案不存在')</script>
end if
set objfso = nothing
end function
%>