<% 
Set MyCatch=new CatchFile 
MyCatch.Overdue=60*5    '修改过期时间设置为5个小时 
if MyCatch.CatchNow(Rev) then 
    response.write MyCatch.CatchData 
    response.end 
end if 
set MyCatch=nothing 
%>

<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<% Response.CodePage=65001%> 
<% Response.Charset="UTF-8" %> 

<%
'该程序通过使用ASP的FSO功能，减少数据库的读取。经测试，可以减少90%的服务器负荷。页面访问速度基本与静态页面相当。
'使用方法：将该文件放在网站里，然后在需要引用的文件的“第一行”用include引用即可。

'=======================参数区=============================

DirName="cachenew\" '静态文件保存的目录，结尾应带"\"。无须手动建立，程序会自动建立。
'TimeDelay=10   '更新的时间间隔，单位为分钟，如1440分钟为1天。生成的静态文件在该间隔之后会被删除。
TimeDelay=300
'======================主程序区============================

foxrax=Request("foxrax")
if foxrax="" then
 FileName=Server.URLEncode(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("URL") 
 If Trim(Request.QueryString) <> "" Then 
 strTemps = strTemps & "?" & Trim(Request.QueryString) 
 else
 strTemps = strTemps 
 end if
 GetStr = 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)
  On Error Resume Next 
    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


'读取文件
'Public Function ReadFile( xVar )
 'xVar = Server.Mappath(xVar)
 'Set Sys = Server.CreateObject("Scripting.FileSystemObject") 
 'If Sys.FileExists( xVar ) Then 
 'Set Txt = Sys.OpenTextFile( xVar, 1,false) 
 'msg = Txt.ReadAll
 'Txt.Close 
 'Response.Write("yes")
 'Else
 'msg = "no"
 'End If 
 'Set Sys = Nothing
 'ReadFile = msg
'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 
%>