This program reduces database reads by using ASP's FSO functionality. After testing, it can reduce server load by 90%. The page access speed is basically the same as that of static pages. Copy the code code as follows:
<%@LANGUAGE=VBSCRIPT CODEPAGE=65001%>
<% Response.CodePage=65001%>
<% Response.Charset=UTF-8 %>
<%
'This program reduces database reads by using ASP's FSO functionality. After testing, it can reduce server load by 90%. The page access speed is basically the same as that of static pages.
'How to use: Place the file on the website, and then use include to reference it in the first line of the file that needs to be referenced.
'=======================Parameter area======================== =====
DirName=cachenew/ 'The directory where static files are saved should have / at the end. No need to create it manually, the program will create it automatically.
TimeDelay=30 'Update time interval, unit is minutes, for example, 1440 minutes is 1 day. Generated static files are deleted after this interval.
'======================Main program area======================== ====
foxrax=Request(foxrax)
if foxrax= then
FileName=GetStr()&.txt
FileName=DirName&FileName
if tesfold(DirName)=false then'Create the folder if it does not exist
createfold(Server.MapPath(.)&/&DirName)
end if
if ReportFileStatus(Server.MapPath(.)&/&FileName)=true then'If there is a generated static file, read the file directly
Set FSO=CreateObject(Scripting.FileSystemObject)
Dim Files,LatCatch
Set Files=FSO.GetFile(Server.MapPath(FileName)) 'Define CatchFile file object
LastCatch=CDate(Files.DateLastModified)
If DateDiff(n,LastCatch,Now())>TimeDelay Then' exceeds
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
'========================Function area======================== =====
'Get the current page url
Function GetStr()
'On Error Resume Next
Dim strTemps
strTemps = strTemps & Request.ServerVariables(HTTP_X_REWRITE_URL)
GetStr = Server.URLEncode(strTemps)
End Function
'Get the cached page 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
'Catch the page
Function getHTTPPage(url)
Set Mail1 = Server.CreateObject(CDO.Message)
Mail1.CreateMHTMLBody URL,31
AA=Mail1.HTMLBody
Set Mail1 = Nothing
getHTTPage=AA
'Set Retrieval = Server.CreateObject(Microsoft.Xmlhttp)
'Retrieval.Open GET,url,false,,
'Retrieval.Send
'getHTTPPage = Retrieval.ResponseBody
'Set Retrieval = Nothing
End Function
SubWriteFile(filePath)
dim stm
set stm=Server.CreateObject(adodb.stream)
stm.Type=2 'adTypeText, text data
stm.Mode=3 'adModeReadWrite, read and write, if this parameter is 2, an error will be reported
stm.Charset=utf-8
stm.Open
stm.WriteText list
stm.SaveToFile Server.MapPath(filePath),2 'adSaveCreateOverWrite, overwrite if the file exists
stm.Flush
stm.Close
set stm=nothing
End Sub
Function ReadFile(filePath)
dim stm
set stm=Server.CreateObject(adodb.stream)
stm.Type=1 'adTypeBinary, read in binary data
stm.Mode=3 'adModeReadWrite, only 3 can be used here, others will cause errors
stm.Open
stm.LoadFromFile Server.MapPath(filePath)
stm.Position=0 'Move the pointer back to the starting point
stm.Type=2 'Text data
stm.Charset=utf-8
ReadFile = stm.ReadText
stm.Close
set stm=nothing
End Function
'Check if the file exists
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
'Check whether the directory exists
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
'Create directory
subcreatefold(foname)
set fs=createobject(scripting.filesystemobject)
fs.createfolder(foname)
set fs=nothing
end sub
'Delete files
function del_file(path) 'path, the file path contains the file name
set objfso = server.createobject(scripting.FileSystemObject)
'path=Server.MapPath(path)
if objfso.FileExists(path) then 'If it exists, delete it
objfso.DeleteFile(path) 'Delete file
else
'response.write <script language='Javascript'>alert('File does not exist')</script>
end if
set objfso = nothing
end function
%>