ASP 高级模板引擎实现类


            复制代码 代码如下:Class template     Private c_Char, c_Path, c_FileName, c_Content, c_PageUrl, c_CurrentPage, c_PageStr, ReplacePageStr     Private TagName     ' ***************************************     '    设置编码     ' ***************************************     Public Property Let Char(ByVal Str)         c_Char = Str     End Property     Public Property Get Char         Char = c_Char     End Property     ' ***************************************     '    设置模板文件夹路径     ' ***************************************     Public Property Let Path(ByVal Str)         c_Path = Str     End Property     Public Property Get Path         Path = c_Path     End Property     ' ***************************************     '    设置模板文件名     ' ***************************************     Public Property Let FileName(ByVal Str)         c_FileName = Str     End Property     Public Property Get FileName         FileName = c_FileName     End Property     ' ***************************************     '    获得模板文件具体路径     ' ***************************************     Public Property Get FilePath         If Len(Path) > 0 Then Path = Replace(Path, "\", "/")         If Right(Path, 1) <> "/" Then Path = Path & "/"         FilePath = Path & FileName     End Property     ' ***************************************     '    设置分页URL     ' ***************************************     Public Property Let PageUrl(ByVal Str)         c_PageUrl = Str     End Property     Public Property Get PageUrl         PageUrl = c_PageUrl     End Property     ' ***************************************     '    设置分页 当前页     ' ***************************************     Public Property Let CurrentPage(ByVal Str)         c_CurrentPage = Str     End Property     Public Property Get CurrentPage         CurrentPage = c_CurrentPage     End Property     ' ***************************************     '    输出内容     ' ***************************************     Public Property Get Flush         Response.Write(c_Content)     End Property     ' ***************************************     '    类初始化     ' ***************************************     Private Sub Class_Initialize         TagName = "pjblog"         c_Char = "UTF-8"         ReplacePageStr = Array("", "")     End Sub     ' ***************************************     '    过滤冲突字符     ' ***************************************     Private Function doQuote(ByVal Str)         doQuote = Replace(Str, Chr(34), """)     End Function     ' ***************************************     '    类终结     ' ***************************************     Private Sub Class_Terminate     End Sub     ' ***************************************     '    加载文件方法     ' ***************************************     Private Function LoadFromFile(ByVal cPath)         Dim obj         Set obj = Server.CreateObject("ADODB.Stream")             With obj              .Type = 2                 .Mode = 3                 .Open                 .Charset = Char                 .Position = .Size                 .LoadFromFile Server.MapPath(cPath)                 LoadFromFile = .ReadText                 .close             End With         Set obj = Nothing     End Function     ' ***********************************************     '    获取正则匹配对象     ' ***********************************************     Public Function GetMatch(ByVal Str, ByVal Rex)         Dim Reg, Mag         Set Reg = New RegExp         With Reg             .IgnoreCase = True             .Global = True             .Pattern = Rex             Set Mag = .Execute(Str)             If Mag.Count > 0 Then                 Set GetMatch = Mag             Else                 Set GetMatch = Server.CreateObject("Scripting.Dictionary")             End If         End With         Set Reg = nothing     End Function     ' ***************************************     '    打开文档     ' ***************************************     Public Sub open         c_Content = LoadFromFile(FilePath)     End Sub     ' ***************************************     '    缓冲执行     ' ***************************************     Public Sub Buffer         c_Content = GridView(c_Content)         Call ExecuteFunction     End Sub     ' ***************************************     '    GridView     ' ***************************************     Private Function GridView(ByVal o_Content)         Dim Matches, SubMatches, SubText         Dim Attribute, Content         Set Matches = GetMatch(o_Content, "\<" & TagName & "\:(\d+?)(.+?)\>([\s\S]+?)<\/" & TagName & "\:\1\>")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 Attribute = SubMatches.SubMatches(1)     ' kocms                 Content = SubMatches.SubMatches(2)     ' <Columns>...</Columns>                 SubText = Process(Attribute, Content)     ' 返回所有过程执行后的结果                 o_Content = Replace(o_Content, SubMatches.value, "<" & SubText(2) & SubText(0) & ">" & SubText(1) & "</" & SubText(2) & ">", 1, -1, 1)                                            ' 替换标签变量             Next         End If         Set Matches = Nothing         If Len(ReplacePageStr(0)) > 0 Then                ' 判断是否标签变量有值,如果有就替换掉.             o_Content = Replace(o_Content, ReplacePageStr(0), ReplacePageStr(1), 1, -1, 1)             ReplacePageStr = Array("", "")                ' 替换后清空该数组变量         End If         GridView = o_Content     End Function     ' ***************************************     '    确定属性     ' ***************************************     Private Function Process(ByVal Attribute, ByVal Content)         Dim Matches, SubMatches, Text         Dim MatchTag, MatchContent         Dim datasource, Name, Element, page, id         datasource = "" : Name = "" : Element = "" : page = 0 : id = ""         Set Matches = GetMatch(Attribute, "\s(.+?)\=\""(.+?)\""")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 MatchTag = SubMatches.SubMatches(0)                                ' 取得属性名                 MatchContent = SubMatches.SubMatches(1)                            ' 取得属性值                 If Lcase(MatchTag) = "name" Then Name = MatchContent            ' 取得name属性值                 If Lcase(MatchTag) = "datasource" Then datasource = MatchContent' 取得datasource属性值                 If Lcase(MatchTag) = "element" Then Element = MatchContent        ' 取得element属性值                 If Lcase(MatchTag) = "page" Then page = MatchContent            ' 取得page属性值                 If Lcase(MatchTag) = "id" Then id = MatchContent                ' 取得id属性值             Next             If Len(Name) > 0 And Len(MatchContent) > 0 Then                 Text = Analysis(datasource, Name, Content, page, id)            ' 执行解析属性                 If Len(datasource) > 0 Then Attribute = Replace(Attribute, "datasource=""" & datasource & """", "")                 If page > 0 Then Attribute = Replace(Attribute, "page=""" & page & """", "")                 Attribute = Replace(Attribute, "name=""" & Name & """", "", 1, -1, 1)                 Attribute = Replace(Attribute, "element=""" & Element & """", "", 1, -1, 1)                 Process = Array(Attribute, Text, Element)             Else                 Process = Array(Attribute, "", "div")             End If         Else             Process = Array(Attribute, "", "div")         End If         Set Matches = Nothing     End Function     ' ***************************************     '    解析     ' ***************************************     Private Function Analysis(ByVal id, ByVal Name, ByVal Content, ByVal page, ByVal PageID)         Dim Data         Select Case Lcase(Name)                                                    ' 选择数据源             Case "loop" Data = DataBind(id, Content, page, PageID)             Case "for" Data = DataFor(id, Content, page, PageID)         End Select         Analysis = Data     End Function     ' ***************************************     '    绑定数据源     ' ***************************************     Private Function DataBind(ByVal id, ByVal Content, ByVal page, ByVal PageID)         Dim Text, Matches, SubMatches, SubText         Execute "Text = " & id & "(1)"                                            ' 加载数据源         Set Matches = GetMatch(Content, "\<Columns\>([\s\S]+)\<\/Columns\>")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 SubText = ItemTemplate(SubMatches.SubMatches(0), Text, page, PageID)' 执行模块替换                 Content = Replace(Content, SubMatches.value, SubText, 1, -1, 1)             Next             DataBind = Content         Else             DataBind = ""         End If         Set Matches = Nothing     End Function     ' ***************************************     '    匹配模板实例     ' ***************************************     Private Function ItemTemplate(ByVal TextTag, ByVal Text, ByVal page, ByVal PageID)         Dim Matches, SubMatches, SubMatchText         Dim SecMatch, SecSubMatch         Dim i, TempText         Dim TextLen, TextLeft, TextRight         Set Matches = GetMatch(TextTag, "\<ItemTemplate\>([\s\S]+)\<\/ItemTemplate\>")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 SubMatchText = SubMatches.SubMatches(0)                 ' ---------------------------------------------                 '    循环嵌套开始                 ' ---------------------------------------------                 SubMatchText = GridView(SubMatchText)                 ' ---------------------------------------------                 '    循环嵌套结束                 ' ---------------------------------------------                 If UBound(Text, 1) = 0 Then                     TempText = ""                 Else                     TempText = ""                     ' -----------------------------------------------                     '    开始分页                     ' -----------------------------------------------                     If Len(page) > 0 And page > 0 Then                         If Len(CurrentPage) = 0 Or CurrentPage = 0 Then CurrentPage = 1                         TextLen = UBound(Text, 2)                         TextLeft = (CurrentPage - 1) * page                         TextRight = CurrentPage * page - 1                         If TextLeft < 0 Then TextLeft = 0                         If TextRight > TextLen Then TextRight = TextLen                         c_PageStr = MultiPage(TextLen + 1, page, CurrentPage, PageUrl, "float:right", "", False)                         If Int(Len(c_PageStr)) > 0 Then                             ReplacePageStr = Array("<page:" & Trim(PageID) & "/>", c_PageStr)                         Else                             ReplacePageStr = Array("<page:" & Trim(PageID) & "/>", "")                         End If                     Else                         TextLeft = 0                         TextRight = UBound(Text, 2)                     End If                     For i = TextLeft To TextRight                         TempText = TempText & ItemReSec(i, SubMatchText, Text)        ' 加载模板内容                     Next                 End If             Next             ItemTemplate = TempText         Else             ItemTemplate = ""         End If         Set Matches = Nothing     End Function     ' ***************************************     '    替换模板字符串     ' ***************************************     Private Function ItemReSec(ByVal i, ByVal Text, ByVal Arrays)         Dim Matches, SubMatches         Set Matches = GetMatch(Text, "\$(\d+?)")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 Text = Replace(Text, SubMatches.value, doQuote(Arrays(SubMatches.SubMatches(0), i)), 1, -1, 1) '执行替换             Next             ItemReSec = Text         Else             ItemReSec = ""         End If         Set Matches = Nothing     End Function     ' ***************************************     '    全局变量函数     ' ***************************************     Private Sub ExecuteFunction         Dim Matches, SubMatches, Text, ExeText         Set Matches = GetMatch(c_Content, "\<function\:([0-9a-zA-Z_\.]*?)\((.*?)\""(.+?)\""(.*?)\)\/\>")         If Matches.Count > 0 Then             For Each SubMatches In Matches                 Text = SubMatches.SubMatches(0) & "(" & SubMatches.SubMatches(1) & """" & SubMatches.SubMatches(2) & """" & SubMatches.SubMatches(3) & ")"                 Execute "ExeText=" & Text                 c_Content = Replace(c_Content, SubMatches.value, ExeText, 1, -1, 1)             Next         End If         Set Matches = Nothing     End Sub     ' ***************************************     '    普通替换全局标签     ' ***************************************     Public Property Let Sets(ByVal t, ByVal s)         Dim SetMatch, Bstr, SetSubMatch         Set SetMatch = GetMatch(c_Content, "(\<Set\:([0-9a-zA-Z_\.]*?)\(((.*?)" & t & "(.*?))?\)\/\>)")         If SetMatch.Count > 0 Then             For Each SetSubMatch In SetMatch                 Execute "Bstr = " & SetSubMatch.SubMatches(1) & "(" & SetSubMatch.SubMatches(3) & """" & s & """" & SetSubMatch.SubMatches(4) & ")"                 c_Content = Replace(c_Content, SetSubMatch.Value, Bstr, 1, -1, 1)             Next         End If         Set SetMatch = Nothing         Set SetMatch = GetMatch(c_Content, "(\<Set\:" & t & "\/\>)")         If SetMatch.Count > 0 Then             For Each SetSubMatch In SetMatch                 c_Content = Replace(c_Content, SetSubMatch.Value, s, 1, -1, 1)             Next         End If         Set SetMatch = Nothing     End Property End Class