复制代码 代码如下:
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+？）（.+？）>（[sS]+？）</" & 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>（[sS]+）</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>（[sS]+）</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
易网时代-编程资源站