Option Explicit
' Référence à cocher : Microsoft XML,v6.x
Private Sub BrowseChildNodes(root_node As IXMLDOMNode)
Dim i As Long
Dim c As Long
Dim rng As Range
For i = 0 To root_node.childNodes.Length - 1
If root_node.childNodes.Item(i).nodeType <> 3 Then
If ShDatas.UsedRange.Cells.Count = 1 Then
Set rng = ShDatas.Cells(1)
Else
Set rng = ShDatas.Cells(ShDatas.UsedRange.Rows.Count + 1, 1)
End If
With rng
.Value = root_node.childNodes.Item(i).baseName
.Offset(0, 1).Value = root_node.childNodes.Item(i).nodeTypeString
.Offset(0, 2).Value = root_node.childNodes.Item(i).nodeValue
.Offset(0, 3).Value = root_node.childNodes.Item(i).Text
For c = 0 To root_node.childNodes.Item(i).Attributes.Length - 1
.Offset(0, c + 4).Value = root_node.childNodes.Item(i).Attributes.Item(c).baseName
.Offset(0, c + 5).Value = root_node.childNodes.Item(i).Attributes.Item(c).nodeValue
Next c
End With
End If
BrowseChildNodes root_node.childNodes(i)
Next i
End Sub
Private Sub BrowseXMLDocument(ByVal filename As String)
Dim xmlDoc As DOMDocument, root As IXMLDOMElement
Dim i As Long
Dim c As Long
Dim rng As Range
Set xmlDoc = New DOMDocument
xmlDoc.async = False
xmlDoc.Load filename
Set root = xmlDoc.documentElement
If Not root Is Nothing Then
If ShDatas.UsedRange.Cells.Count = 1 Then
Set rng = ShDatas.Cells(1)
Else
Set rng = ShDatas.Cells(ShDatas.UsedRange.Rows.Count + 1, 1)
End If
With rng
.Value = root.baseName
.Offset(0, 1).Value = root.nodeTypeString
.Offset(0, 2).Value = root.nodeValue
.Offset(0, 3).Value = root.Text
For c = 0 To root.Attributes.Length - 1
.Offset(0, c + 4).Value = root.Attributes.Item(c).baseName
.Offset(0, c + 5).Value = root.Attributes.Item(c).nodeValue
Next c
End With
BrowseChildNodes root
End If
ShDatas.Cells(1).EntireRow.Insert xlShiftDown
With ShDatas.Cells(1)
.Value = "baseName"
.Offset(0, 1).Value = "nodeTypeString"
.Offset(0, 2).Value = "nodeValue"
.Offset(0, 3).Value = "text"
c = 1
For i = 4 To ShDatas.UsedRange.Columns.Count - 1 Step 2
.Offset(0, i).Value = "attribute" & c
.Offset(0, i + 1).Value = "Value" & c
c = c + 1
Next i
End With
ShDatas.Rows(1).Font.Bold = True
End Sub
Sub LireFichierXML()
Dim Fichier As Variant
ChDir ThisWorkbook.Path
Fichier = Application.GetOpenFilename("Fichier XML (*.xml), *.xml" )
If Fichier = False Then Exit Sub
Application.ScreenUpdating = False
ShDatas.Cells.Clear
BrowseXMLDocument Fichier
Application.ScreenUpdating = True
End Sub |