mapgis编辑属性结构编辑不了_VBA编写Ribbon Custom UI编辑器05——转换结构体XML

类CXML解析xml文本获取XML结构体之后，需要进一步转换为一个二维数组输出到Excel单元格。

同时还需要一个相反的函数，Excel单元格数据转换为XML结构体。

01 XML结构体转换为二维数组

Public Function XML2Array(tXML As XML) As String()    Dim arr() As String    Dim pcol As Long    '记录属性所在的列    Dim h As CHash    '注意：这里应该先遍历一次，获取所有不重复属性名称的个数的    Set h = NewCHash(200)    h.Add "XMLName", 0    h.Add "HasChild", 1        Dim i As Long, j As Long    '计算列的数量    '第0个是不存在的根节点    For i = 0 + 1 To tXML.nNode - 1        For j = 0 To tXML.Nodes(i).AttriNum - 1            If Not h.Exists(tXML.Nodes(i).Attris(j).Key) Then                h.Add tXML.Nodes(i).Attris(j).Key, h.Count            End If        Next    Next    ReDim arr(tXML.nNode, h.Count - 1) As String    arr(0, 0) = "xmlItem"    arr(0, 1) = "HasChild"        '开始转换    For i = 0 + 1 To tXML.nNode - 1        arr(i, 0) = tXML.Nodes(i).XMLItem        arr(i, 1) = VBA.CStr(tXML.Nodes(i).HasChild)                For j = 0 To tXML.Nodes(i).AttriNum - 1            pcol = VBA.CLng(h.GetItem(tXML.Nodes(i).Attris(j).Key))            arr(0, pcol) = tXML.Nodes(i).Attris(j).Key            arr(i, pcol) = tXML.Nodes(i).Attris(j).value        Next    Next    XML2Array = arr        Set h = NothingEnd Function

02 二维数组转换为XML结构体

'Arr        从Excel单元格读取的数组Public Function Array2XMLString(arr()) As String    Dim rows As Long    Dim cols As Long    Dim result() As String    Dim value As String    Dim tmp() As String        rows = UBound(arr, 1)    cols = UBound(arr, 2)        ReDim result(rows - 1 - 1) As String '第一行是标题    ReDim tmp(cols - 1) As String '记录属性的值，HasChild在B列，是不需要的，多出的一个最后放“>”        Dim i As Long    Dim j As Long    Dim iLevel As Long    Dim bHasChild As Boolean        For i = 2 To rows        tmp(0) = "        '/*这种表示的是一个具有子元素的元素的结束        If VBA.Left$(VBA.CStr(arr(i, 1)), 1) = "/" Then iLevel = iLevel - 1                'HasChild        bHasChild = VBA.CBool(arr(i, 2))        If bHasChild Then            tmp(cols - 1) = ">"        Else            If VBA.Left$(VBA.CStr(arr(i, 1)), 1) = "/" Then                tmp(cols - 1) = ">" & vbNewLine            Else                tmp(cols - 1) = "/>"            End If        End If                For j = 3 To cols            value = VBA.CStr(arr(i, j))            '不为空的时候设置属性值            If VBA.Len(value) Then                tmp(j - 2) = " " & VBA.CStr(arr(1, j)) & "=""" & value & """"            Else                tmp(j - 2) = ""            End If        Next                result(i - 2) = VBA.Space$(iLevel) & VBA.Join(tmp, "")                If bHasChild Then iLevel = iLevel + 1    Next        Array2XMLString = VBA.Join(result, vbNewLine)End Function