ASP动态include

'last update: 2008/6/12'1/分别解析include的file和virtual属性'2/删除运行在服务器端的object和script标签'3/取消了ASPEncode对资源的消耗,直接用Mid来截取html字符串,并用Execute统一执行'get file string dataPublic 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 = NothingEnd FunctionPublic 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 = NothingEnd Sub'Translate Current PathPrivate 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 = retEnd Function'UsageASPInclude "test/test.asp", "GBK"