欢迎访问上海市某某有限公司
上海市某某有限公司专注网站制作10年!为企业打造专业的互联网营销解决方案
全国咨询热线: 18123456789
联系我们

上海市某某有限公司

地址:某某市某某区某某公路666弄66号

手机:18123456789

电话:021-6666666

邮箱:313801120@qq.com

当前位置:首页 > 新闻资讯 > 编程语言 > asp >

ASP网站加上缓冲程序

时间:2022/11/1 13:13:54 作者: 点击:50次

ASP网站加上缓冲程序

<%
dim c,url,filePath
url=getThisUrl()
url=replace(url,"/1.asp","/index.asp")
filePath="/html/index/"&md5(url) & ".html"
dim pubTimer : pubTimer = now()
if checkFile(filePath) then
	c=readFile(filePath,"UTF-8")
	response.write(c)
	' response.write(" true:" & vbRunTimer( pubTimer) )

	response.end()
else 
	c=gethttpurl("http://test2/?pageid=2","gb2312") 
	call writeToFile(filePath,c,"UTF-8")  '保存'
	response.write(c)
	' response.write( " false: " & vbRunTimer(pubTimer) )

	response.end()
end if

response.write(url & " > " & filePath):response.end()


'获得请求url状态
function getHttpUrlState(httpurl)
    getHttpUrlState = handleGetHttpPage(httpurl, "")(1) 
end function 
'获得请求url的服务器名称
function getHttpUrlServerName(httpurl)
    getHttpUrlServerName = ""                                                       '配置php里用的
end function 

'获得采集内容 
function getHttpPage(byVal httpurl, byVal sCharSet)
    getHttpPage = handleGetHttpPage(httpurl, sCharSet)(0)   
end function


'获得采集内容 (辅助)
function getURLContent(httpurl, sCharSet)
    getURLContent = getHttpPage(httpurl, sCharSet) 
end function 
'获得采集内容 (辅助)
function getHttpUrl(httpurl, sCharSet)
    getHttpUrl = getHttpPage(httpurl, sCharSet) 
end function 
function bytesToBstr(byteArr, cset)
    dim objStream 
    if isNul(byteArr) then exit function                                               '为空则退出
    set objStream = createObject("ADODB.Stream")
        objStream.type = 1 
        objStream.mode = 3 
        objStream.open 
        call objStream.write(byteArr) 
        objStream.position = 0 
        objStream.type = 2 
        objStream.charset = cset 
        bytesToBstr = objStream.readText 
        objStream.close 
    set objStream = nothing 
end function 
'处理获得采集内容 
function handleGetHttpPage(byVal httpurl, byVal sCharSet)
    ' on error resume next 
    dim startTime, nStatus, nTime, content, sSplType, webFileSize 
    startTime = now() 
    sSplType = "|-*ypia=|" 
    sCharSet = handleStrCharSet(sCharSet) 
    if isNull(httpurl) = true or len(httpurl) < 7 or httpurl = "$False$" then
        handleGetHttpPage = split("" & sSplType & - 1 & sSplType & nTime & sSplType & webFileSize, sSplType) 
        exit function 
    end if 
 
    dim http 
    set http = createObject("MSXML2.XMLHTTP")
        call http.open("GET", httpurl, false) 
        http.send 
        if http.readyState <> 4 then
            set http = nothing 
            handleGetHttpPage = split("" & sSplType & http.readyState & sSplType & nTime & sSplType & webFileSize, sSplType) 
            exit function 
        end if 

        content = bytesToBstr(http.responseBody, sCharSet) 
        nStatus = http.status 
        nTime = dateDiff("s", startTime, now()) 
        webFileSize = strLength(content) 

        handleGetHttpPage = split(content & sSplType & nStatus & sSplType & nTime & sSplType & webFileSize, sSplType) 

    set http = nothing 
end function 


'处理字符编码 20150723
function handleStrCharSet(sSetChar)
    if sSetChar = "1" or uCase(sSetChar) = "GB2312" or sSetChar = "" then
        sSetChar = "GB2312" 
    elseIf sSetChar = "0" or uCase(sSetChar) = "UTF-8" then
        sSetChar = "UTF-8" 
    elseIf sSetChar = "2" or uCase(sSetChar) = "UNICODE" then
        sSetChar = "UNICODE" 
    end if 
    handleStrCharSet = sSetChar 
end function 
'判断是否为空
function isNul(byVal s)
    on error resume next : if err.number <> 0 then err.clear 
    isNul = false 
    select case varType(s)
        case vbEmpty, vbNull
            isNul = true : exit function 
        case vbString
            if s = "" then isNul = true : exit function 
        case vbObject
            select case typeName(s)
                case "Nothing", "Empty"
                    isNul = true : exit function 
                case "Recordset"
                    if s.state = 0 then isNul = true : exit function 
                    if s.BOF and s.EOF then isNul = true : exit function 
                case "Dictionary"
                    if s.count = 0 then isNul = true : exit function 
            end select
    case vbArray, 8194, 8204, 8209
        if uBound(s) = -1 then isNul = true : exit function 
    end select 
    on error goto 0 
end function 

'Response.Write(StrLength("中国121aa"))
'正则表达式获得字符长度 中文二个字符
function strLength(str)
    dim rep, lens, i 
    lens = 0 
    set rep = createObject("VBscript.RegExp")
        rep.global = true 
        rep.ignoreCase = true 
        rep.pattern = "[\u4E00-\u9FA5\uF900-\uFA2D]" 
        for each i in rep.execute(str)
            lens = lens + 1 
        next 
    set rep = nothing 
    lens = lens + len(str) 
    strLength = lens 
end function 

'获得当前带参数网址
function getThisUrl()
    dim url 
    'vbdel start
    url = request.serverVariables("server_name") 
    'PHP版上面直接获得端口
    if inStr(url, ":") = 0 then
        url = url & getPort() 
    end if 
    url = url & request.serverVariables("script_name") 
    if request.serverVariables("QUERY_STRING") <> "" then url = url & "?" & request.serverVariables("QUERY_STRING") 
    'vbdel end
    if CStr(request.serverVariables("SERVER_PORT"))  ="443" then
        getThisUrl = "https://" & url 
    else
        getThisUrl = "http://" & url 
    end if
end function 
'获得主机端口号
function getPort()
    dim port 
    port = CStr(request.serverVariables("SERVER_PORT")) 
    if port <> "80" and port <> "8080" and port <> "443" and port<>"" then
        port = ":" & port 
    else
        port = "" 
    end if 
    getPort = port 
end function 
'检查文件
function checkFile(byVal filePath)
    on error resume next 
    dim fso 
    call handlePath(filePath)                                                       '获得完整路径
    set fso = createObject("Scripting.FileSystemObject")
        checkFile = fso.fileExists(filePath) 
    set fso = nothing 
    if err then call doError(err.description, "checkFile 检查文件 函数出错,filePath=" & filePath) 
end function 

'处理成完成路径 (2013,9,27
function handlePath(fFPath)                                                     'Path前面不加ByVal 重定义,这样是为了让前面函数里可以使用这个路径完整调用
    fFPath = replace(fFPath, "/", "\") 
    fFPath = replace(fFPath, "\\", "\") 
    fFPath = replace(fFPath, "\\", "\") 
    dim isDir                                                                       '为目录
    isDir = false 
    if right(fFPath, 1) = "\" then
        isDir = true 
    end if 
    if inStr(fFPath, ":") = 0 then
        if left(fFPath, 1) = "\" then
            fFPath = server.mapPath("\") & "\" & fFPath 
        else
            fFPath = server.mapPath(".\") & "\" & fFPath 
        end if 
    end if 
    fFPath = replace(fFPath, "/", "\") 
    fFPath = replace(fFPath, "\\", "\") 
    fFPath = replace(fFPath, "\\", "\") 
    fFPath = fullPath(fFPath) 
    if isDir = true then
        fFPath = fFPath & "\" 
    end if 
    handlePath = fFPath 
end function 
'完整路径
function fullPath(byVal fFPath)
    dim splStr, s, c 
    c = "" 
    fFPath = replace(fFPath, "/", "\") 
    splStr = split(fFPath, "\") 
    for each s in splStr
        s = trim(s) 
        if s <> "" and s <> "." then
            if inStr(c, "\") > 0 and s = ".." then
                c = mid(c, 1, inStrRev(c, "\") - 1) 
            else
                if c <> "" and right(c, 1) <> "\" then c = c & "\" 
                c = c & s 
            end if 
        end if 
    next 
    fullPath = c 
end function 
'真正的路径  PHP里函数 为假返回空
function realPath(byVal fFPath)
    realPath = "" 
    if checkFile(fFPath) then
        realPath = fFPath 
        exit function 
    end if 
    if checkFolder(fFPath) then
        realPath = fFPath 
        exit function 
    end if 
end function 
'处理成相对路径(20150906)  如 a=handleRelativePath("",a)
function handleRelativePath(rootPath, byVal filePath)
    if rootPath = "" then rootPath = "\" 
    rootPath = handlePath(rootPath) 
    filePath = replace(filePath, rootPath, "\") 
    handleRelativePath = filePath 
end function 
'写入内容
function writeToFile(byVal fileName, byVal content, byVal char_Set)
    on error resume next 
    if char_Set = "1" or uCase(char_Set) = "GB2312" then
        char_Set = "GB2312" 
    elseIf char_Set = "0" or uCase(char_Set) = "UTF-8" then
        char_Set = "UTF-8" 
    elseIf char_Set = "2" or uCase(char_Set) = "UNICODE" then
        char_Set = "UNICODE" 
    else
        char_Set = checkCode(fileName) 	 
        if char_Set = "" then exit function 
    end if 
    'Call Echo("Char_Set",Char_Set)
    dim stm 
    call handlePath(fileName)                                                       '获得完整路径
    set stm = createObject("ADODB.Stream")
        stm.type = 2                                                                    '以本模式读取
        stm.mode = 3 
        stm.charset = char_Set 
        stm.open 
        call stm.writeText(content) 
        call stm.saveToFile(fileName, 2) 
        stm.flush 
        stm.close 
        writeToFile = fileName & "写入成功" 
    set stm = nothing 
    if err then call doError(Err.description, "WriteToFile,数据流写入内容 函数出错,FileName=" & fileName & ",Content字符" & len(content)) 
end function 

'数据流读出内容
function readFile(byVal fileName, byVal char_Set)
    'on error resume next
	char_Set=char_Set & ""
    if char_Set = "1" or uCase(char_Set) = "GB2312" then
        char_Set = "GB2312" 
    elseIf char_Set = "0" or uCase(char_Set) = "UTF-8" then
        char_Set = "UTF-8" 
    elseIf char_Set = "2" or uCase(char_Set) = "UNICODE" then
        char_Set = "UNICODE" 
    elseIf char_Set = "3" or uCase(char_Set) = "UNICODE BIG ENDIAN" then
        char_Set = "UNICODE" 
    else
        char_Set = checkCode(fileName) 	 
        if char_Set = "" then exit function 
    end if 
    dim str, stm, f, fso 
    call handlePath(fileName)                                                       '获得完整路径
    if checkFile(fileName) = false then
        readFile = "" 
        exit function 
    end if 
    set stm = createObject("ADODB.Stream")
        stm.type = 2                                                                    '以本模式读取
        stm.mode = 3 
        stm.charset = char_Set 
        stm.open 
        set fso = createObject("Scripting.FileSystemObject")
            set f = fso.getFile(fileName)
                if f.size > 0 then
                    call stm.loadFromFile(fileName) 
                end if 
                str = stm.readText 
                stm.close 
            set stm = nothing 
            readFile = str 
            if err then call doError(Err.description, "ReadFile,数据流读出内容 函数出错,FileName=" & fileName) 
        set fso = nothing 
    set stm = nothing 
end function 
'获得时间第四种
function vbRunTimer(startTime)
    VBRunTimer = "run time: " & calculationTimer(startTime, now()) & " miao "
end function
'计算时间  
function calculationTimer(startTime,endTime)
    dim n 
    'n = formatNumber((timer() - pubTimer) * 1000, 2, - 1) / 1000 
    'calculationTimer = toNumber(n, 3)   
	calculationTimer=dateDiff("s", startTime,endTime)
end function  
%>