- <%@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
- %>
复制代码 |