ASP动态include

'last update: 2008/6/12

'1/分别解析include的file和virtual属性

'2/删除运行在服务器端的object和script标签

'3/取消了ASPEncode对资源的消耗,直接用Mid来截取html字符串,并用Execute统一执行



'get file string data

Public Function GetFileString(ByVal strPath, ByVal strCharset)

    Dim objFile

    Set objFile = Server.CreateObject("ADODB.Stream")

    objFile.Type = 2'adTypeText

    objFile.Charset = strCharset

    objFile.Open

    objFile.LoadFromFile strPath

    GetFileString = objFile.ReadText(-1)

    objFile.Close

    Set objFile = Nothing

End Function



Public Sub ASPInclude(ByVal strPath, ByVal strCharset)

    Dim strData

    Dim reg, arr, ptr, pos

    Dim tmp, ret, i

    strData = GetFileString(Server.MapPath(strPath), strCharset)

    Set reg = New RegExp

    reg.Global = True

    reg.IgnoreCase = True

    'parse include file

    reg.Pattern = "<!--#include/s+file=""([^""]+)""-->"

    strData = reg.Replace(strData, "<" & "%ASPInclude """ & ASPPath(strPath) & "$1"", """ & strCharset & """%" & ">")

    'parse include virtual

    reg.Pattern = "<!--#include/s+virtual=""([^""]+)""-->"

    strData = reg.Replace(strData, "<" & "%ASPInclude ""$1"", """ & strCharset & """%" & ">")

    'clear object or script tag that runat server

    reg.Pattern = "<(object|script)/s[^>]*?runat=""server""[^>]*>[/s/S]*?<//1>"

    strData = reg.replace(strData, "")

    'parse asp tag

    reg.Pattern = "<" & "%([/s/S]*?)%" & ">"

    Set arr = reg.Execute(strData)

    If arr.Count > 0 Then

        ReDim tmp(arr.Count * 2)

        pos = 1

        i = 0

        For Each ptr In arr

            If ptr.FirstIndex + 1 - pos > 0 Then

                tmp(i) = "Response.Write Mid(strData, " & pos & ", " & ptr.FirstIndex + 1 - pos & ")"

                i = i + 1

            End If

            pos = ptr.FirstIndex + 1 + ptr.Length

            If Left(ptr.SubMatches(0), 1) = "=" Then'</%=*%/>

                tmp(i) = "Response.Write " & Mid(ptr.SubMatches(0), 2)

            Else

                tmp(i) = ptr.SubMatches(0)

            End If

            i = i + 1

        Next

        tmp(i) = "Response.Write Mid(strData, " & pos & ")"

        ReDim Preserve tmp(i)

        ret = Join(tmp, vbCrLf)

    Else

        ret = "Response.Write strData"

    End If

    'Response.Write "<h4>Debug</h4>"

    'Response.Write "<textarea cols=""90"" rows=""10"">" & Server.HTMLEncode(ret) & "</textarea>"

    Execute ret

    Set arr = Nothing

    Set reg = Nothing

End Sub



'Translate Current Path

Private Function ASPPath(ByVal strPath)

    Dim ret, tmp, pos

    tmp = Replace(strPath, "/", "/")

    pos = InStrRev(tmp, "/")

    If pos > 0 Then

        ret = Mid(tmp, 1, pos)

    End If

    ASPPath = ret

End Function



'Usage

ASPInclude "test/test.asp", "GBK"