VBA编写Ribbon Custom UI编辑器04——解析xml

'属性
Public Type Attri
    Key As String
    value As String
End Type

Public Type Node
    Left As Long '左孩子
    Right As Long '右兄弟
    
    '元素的名称
    XMLItem As String
    HasChild As Boolean
    
    '属性数组
    Attris() As Attri
    '属性的数量
    AttriNum As Long
End Type

Public Type XML
    Nodes() As Node
    'Nodes实际存放的数量
    nNode As Long
End Type

Private Const INIT_NODE_NUM As Long = 100
Private Const INIT_ATTRI_NUM As Long = 20

Private Const Err_XML As String = "CXML：XML读取出错，这可能是Ribbon customUI.xml 不符合规范."

'要解析的XML文本
Private strXML As String
'指向XML文本下一个要读取的位置
Private pNext As Long
'要返回的XML结构
Private tXML As XML

'记录XML.Nodes的下一个位置
Private pNodeNext As Long
'记录当前正在处理的Node在XML.Nodes中的Index
Private pNode As Long
'记录状态
Private state As Long
'Stack中记录的是XML.Nodes的Index，方便处理父子关系
Private s As CStack
'XML文本长度
Private iStrXMLLen As Long

'解析一个XML文本到XML结构
'sXML   XML文本
'ret    返回的XML结构体
'Return 返回出错信息
Function Decode(sXML As String, ByRef ret As XML) As String
    iStrXMLLen = VBA.Len(sXML)
    
    If iStrXMLLen < 10 Then
        Decode = "CXML：XML太短了"
        Exit Function
    End If
    strXML = sXML
    
    '解析XML，直到超过了文本长度
    Do While pNext < iStrXMLLen
        '使用CallByName调用相应状态的函数
        state = VBA.CallByName(Me, "S" & VBA.CStr(state), VbMethod)
        '99作为出错情况
        If state = 99 Then
            Decode = Err_XML
            tXML.nNode = pNodeNext
            ret = tXML
            Exit Function
        End If
    Loop
    
    tXML.nNode = pNodeNext
    ret = tXML
End Function

'读取下一个字符
Private Function NextChar() As String
    NextChar = VBA.Mid$(strXML, pNext, 1)
    pNext = pNext + 1
End Function

Private Function NewNode() As Node
    ReDim NewNode.Attris(INIT_ATTRI_NUM - 1) As Attri
End Function

'防止数组越界
Private Function pNodeNextAdd() As Long
    pNodeNext = pNodeNext + 1
    If pNodeNext > UBound(tXML.Nodes) Then
        ReDim Preserve tXML.Nodes(pNodeNext * 1.2)
    End If
End Function
Private Function AttriNumAdd(pNode As Long) As Long
    tXML.Nodes(pNode).AttriNum = tXML.Nodes(pNode).AttriNum + 1
    If tXML.Nodes(pNode).AttriNum > UBound(tXML.Nodes(pNode).Attris) Then
        ReDim Preserve tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum * 1.2)
    End If
End Function
'记录树形结构信息
Function SetParent(iParent As Long, iChild As Long) As Long
    Dim i As Long
    
    If tXML.Nodes(iParent).Left = 0 Then
        tXML.Nodes(iParent).Left = iChild
    Else
        i = tXML.Nodes(iParent).Left
        Do Until tXML.Nodes(i).Right = 0
            i = tXML.Nodes(i).Right
        Loop
        tXML.Nodes(i).Right = iChild
    End If
End Function

Private Sub Class_Initialize()
    ReDim tXML.Nodes(INIT_NODE_NUM - 1) As Node
    Set s = New CStack
    s.MaxSize = INIT_NODE_NUM
    
    'String类型开始的下标是1
    pNext = 1
    '0作为root
    pNodeNext = 1
    
    s.Push 0
End Sub

Function S0() As Long
    Do Until NextChar() = "<"
        If pNext > iStrXMLLen Then S0 = 99: Exit Function
    Loop
    
    pNode = pNodeNext
    pNodeNextAdd
    tXML.Nodes(pNode) = NewNode()
    '设置父节点的子节点
    SetParent s.Top, pNode
    
    S0 = 1
End Function
Function S1() As Long
    Dim tmp As String
    
    tmp = NextChar()
    Do Until tmp <> " "
        If pNext > iStrXMLLen Then S1 = 99: Exit Function
        tmp = NextChar()
    Loop
    
    tXML.Nodes(pNode).XMLItem = tmp
    If tmp = "/" Then
        S1 = 9
    Else
        S1 = 2
    End If
End Function
Function S2() As Long
    Dim tmp As String
    
    tmp = NextChar()
    Do Until tmp = " "
        If pNext > iStrXMLLen Then S2 = 99: Exit Function
        
        tXML.Nodes(pNode).XMLItem = tXML.Nodes(pNode).XMLItem & tmp
        tmp = NextChar()
        If tmp = ">" Then
            s.Push pNode
            tXML.Nodes(pNode).HasChild = True
            S2 = 0
            Exit Function
        End If
    Loop
    
    S2 = 3
End Function
Function S3() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp <> " "
        If pNext > iStrXMLLen Then S3 = 99: Exit Function
        
        tmp = NextChar()
    Loop
    tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).Key = tmp
    
    S3 = 4
End Function
Function S4() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp = "="
        If pNext > iStrXMLLen Then S4 = 99: Exit Function
        
        tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).Key = tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).Key & tmp
        tmp = NextChar()
    Loop
    
    S4 = 5
End Function
Function S5() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp = """"
        If pNext > iStrXMLLen Then S5 = 99: Exit Function
        
        tmp = NextChar()
    Loop
    
    S5 = 6
End Function
Function S6() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp = """"
        If pNext > iStrXMLLen Then S6 = 99: Exit Function
        
        tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).value = tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).value & tmp
        tmp = NextChar()
    Loop
    tXML.Nodes(pNode).AttriNum = tXML.Nodes(pNode).AttriNum + 1
    
    S6 = 7
End Function
Function S7() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp <> " "
        If pNext > iStrXMLLen Then S7 = 99: Exit Function
        
        tmp = NextChar()
    Loop
    
    If tmp = ">" Then
        S7 = 0
        tXML.Nodes(pNode).HasChild = True
        s.Push pNode
        
    ElseIf tmp = "/" Then
        S7 = 8
    Else
        S7 = 4
        tXML.Nodes(pNode).Attris(tXML.Nodes(pNode).AttriNum).Key = tmp
    End If
End Function
Function S8() As Long
    Do Until NextChar() = ">"
        If pNext > iStrXMLLen Then S8 = 99: Exit Function
    Loop
    
    S8 = 0
End Function
Function S9() As Long
    Dim tmp As String
    
    tmp = NextChar()
    
    Do Until tmp = ">"
        If pNext > iStrXMLLen Then S9 = 99: Exit Function
        
        tXML.Nodes(pNode).XMLItem = tXML.Nodes(pNode).XMLItem & tmp
        tmp = NextChar()
    Loop
    s.Pop
    
    If s.Top = 0 Then
        S9 = 10
    Else
        S9 = 0
    End If
    
End Function
Function S10() As Long
    'end
    pNext = VBA.Len(strXML)
End Function

Function S99() As Long
    '出错了，什么也不用做
End Function