代碼如下:

<%@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 
%>