Importing XML into an Excel 97/2000 worksheet

Hi,


Much appreciated.

The example on this site is almost ideal. It is a VB program, and I'm really after a VBA macro.

But this has given me the prompt I needed.

I really appreciate the fact that even though you didn't post any sample code, you didn't just copy of modify these and claim it as your own. That shows integrity !

I'm including the code in this comment so if anyone comes by after the same solution this then they will have the same code - just in case Mr. Tomizono site is removed.

It is released under GNU and so the aim is to help people afterall.

Many thanks again.

Alex

______________________________


Attribute VB_Name = "ConvXml2XL1"
Option Explicit

Dim xmlUrl As String, ErrMes As String

Sub okGo()
' main program
    xmlUrl = "C:\tmp\resume-1.xml"     ' URL of a target XML
    If Not convMain Then MsgBox ErrMes    ' execution
End Sub

'___________________________________________________________
'conv-xml2xl-1 version 1.1, Copyright (C) 2000 Tomizono <tomizono@yahoo.com>
'conv-xml2xl-1 comes with ABSOLUTELY NO WARRANTY. This is free software,
'and you are welcome to redistribute it under certain conditions.
'See http://www.gnu.org/copyleft/gpl.html#SEC3 for details.
'___________________________________________________________
'convert an xml document into an MS Excel Worksheet. (DOM Tree view)
'this is a VBA module source for MS Excel.
'input: well-formed XML document
'output: Microsoft Excel Book
'this version: http://www.geocities.com/tomizono/gpl/2000/conv-xml2xl-1.1.1.bas
'lattest: http://www.geocities.com/tomizono/gpl/conv-xml2xl-1.bas
'
'Further information is available at:
'http://www.geocities.com/tomizono/tools/xml2xl.html
'___________________________________________________________
'conv-xml2xl-1: convert an xml into an MS Excel book.
'Copyright (C) 2000 Tomizono <tomizono@yahoo.com>
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'(at your option) any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'GNU General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'___________________________________________________________

Function LoadXML() As Object
    ' load specified XML, return the object
    Set LoadXML = CreateObject("MSXML.DOMDocument")
    LoadXML.async = False
    LoadXML.Load (xmlUrl)
End Function
   
Function CheckXML(xmlObj As Object) As Boolean
    ' validate XML
    Dim pErr As Object
    Set pErr = xmlObj.parseError
    If (pErr.errorCode <> 0) Then
        ErrMes = "Error: " & pErr.url & " cannot be parsed." & vbCrLf _
            & "Error reason: " & pErr.reason & vbCrLf _
            & "Error position: " & pErr.srctext & " (line " & pErr.Line & ")"
        CheckXML = False
    Else
        CheckXML = True
    End If
End Function

Function convMain() As Boolean
' convert to Excel
    Dim MySheet As Worksheet
    Dim xmlObj As Object
   
    ' before
    convMain = False
    Set xmlObj = LoadXML          ' load XML
    If Not CheckXML(xmlObj) Then  ' check XML
        Set xmlObj = Nothing
        Exit Function
    End If
    Set MySheet = MakeMyBook      ' create a new Book
    MySheet.Activate
    xml2xl1 xmlObj, MySheet.Range("A1")     ' DOM to Range
    ' after
    With MySheet.Cells
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = False
    End With
   
    Set xmlObj = Nothing
    Set MySheet = Nothing
    convMain = True
End Function

Function MakeMyBook() As Worksheet
' create a new Book, return a sheet object of the book
    Set MakeMyBook = Application.Workbooks.Add.Worksheets(1)
End Function

Function xml2xl1(iNode As Object, MyRange As Range) As Boolean
' read DOM and write to Range
    Dim iNode2 As Object
    Dim iAttr As Object
    Dim i As Long
    Const NODE_ELEMENT = 1
    Const NODE_DOCUMENT = 9
   
    If (iNode.nodeType = NODE_ELEMENT) Then
   
    ' Name and Text of myself (element)
        MyRange.Value = iNode.nodeName
        MyRange.Interior.ColorIndex = 40
        If iNode.selectNodes("text()").Length > 0 Then
            Set MyRange = MyRange.Offset(0, 1)
            MyRange.Value = iNode.selectSingleNode("text()").Text
            MyRange.Interior.ColorIndex = 19
            Set MyRange = MyRange.Offset(1, 0)
        Else
            Set MyRange = MyRange.Offset(1, 1)
        End If
    ' Attributes
        Set iAttr = iNode.Attributes
        For i = 0 To iAttr.Length - 1
            MyRange.Value = iAttr(i).Name
            MyRange.Interior.ColorIndex = 35
            Set MyRange = MyRange.Offset(0, 1)
            MyRange.Value = iAttr(i).Text
            MyRange.Interior.ColorIndex = 19
            Set MyRange = MyRange.Offset(1, -1)
        Next i
        Set iAttr = Nothing
   
    ElseIf (iNode.nodeType = NODE_DOCUMENT) Then
        MyRange.Value = xmlUrl
        Set MyRange = MyRange.Offset(1, 1)
    End If
   
    ' child Elements
    Set iNode2 = iNode.selectNodes("*")
    For i = 0 To iNode2.Length - 1
        xml2xl1 iNode2(i), MyRange
    Next i
    Set MyRange = MyRange.Offset(0, -1)
    Set iNode2 = Nothing
   
    xml2xl1 = True
End Function

why the C?

Sorry, should have been a B.


My mistake.

Alex

Corrected per your request in Community Support.
Moondancer - EE Moderator

gosh, didn't even think to long about it, was only a first reaction ;)

But thanks anyway