Hi, clsXML isn't my class, but I did a modification.
Option Explicit
Public Enum xmlParserError
[xmlExpected] = 42
[xmlMismatchedTag]
End Enum
Public Enum xmlIdentType
[xmlSpace] = 0
[xmlTab]
End Enum
Private m_parent As clsXML
Private m_look As String * 1
Private m_pos As Long
Private m_line As Long
Private m_col As Long
Private m_hasxml As Boolean
Private m_xmlnode As clsXML
Private m_filenum As Integer
Private m_name As String
Private m_child() As clsXML
Private m_attrib() As String
Private m_value() As String
Private m_text As String
Private m_XML As String
'''''' PROPERTY ''''''''''''''''''''''''''''''''''''''''''
Public Property Get ParentNode() As clsXML
Set ParentNode = m_parent
End Property
Public Property Let ParentNode(Node As clsXML)
Set m_parent = Node
End Property
Public Property Get XMLNode() As clsXML
Set XMLNode = m_xmlnode
End Property
Public Property Let XMLNode(Node As clsXML)
Set m_xmlnode = Node
End Property
Public Property Let Name(n As String)
m_name = n
End Property
Public Property Get Name() As String
Name = m_name
End Property
Public Property Let Text(t As String)
m_text = t
End Property
Public Property Get Text() As String
Text = m_text
End Property
Public Property Get AttribCount() As Long
AttribCount = UBound(m_attrib)
End Property
Public Property Get ChildrenCount() As Long
ChildrenCount = UBound(m_child)
End Property
'''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ParseStream(sXML As String)
m_XML = sXML
m_filenum = 0
m_pos = 1
m_line = 1
m_col = 0
Set m_parent = parseParentNode
End Sub
Public Sub Parse(Filename As String)
Call OpenFile(Filename)
Set m_parent = parseParentNode
Call CloseFile
End Sub
Public Sub Save(Filename As String, Optional PrettyPrint As Boolean = False, Optional IdentType As xmlIdentType = xmlTab)
Call OpenFile(Filename)
Call writeXML(PrettyPrint, IdentType)
Call CloseFile
End Sub
'printing functions (used by Save)
Private Sub writeXML(pp As Boolean, it As xmlIdentType)
Dim i As Long
If m_hasxml Then 'print <?xml ... ?>
Call WriteString("<?xml")
For i = 1 To m_xmlnode.AttribCount
Call WriteString(" " & m_xmlnode.AttributeName(i) & "=" & _
Chr$(34) & m_xmlnode.getAttribute(m_xmlnode.AttributeName(i)) _
& Chr$(34))
Next
Call WriteString("?>" & IIf(pp, vbNewLine, vbNullString))
End If
Call printNode(m_parent, pp, 0, it)
End Sub
Private Sub printNode(Node As clsXML, pp As Boolean, ident As Long, it As xmlIdentType)
Dim i As Long
Dim b As String
Dim e As String
b = IIf(pp, String$(ident, IIf(it = xmlSpace, " ", vbTab)), vbNullString)
e = IIf(pp, vbNewLine, vbNullString)
Call WriteString(b & "<")
Call WriteString(Node.Name)
If Node.AttribCount > 0 Then
For i = 1 To Node.AttribCount
Call WriteString(" " & Node.AttributeName(i) & "=")
Call WriteString(Chr$(34) & _
Node.getAttribute(Node.AttributeName(i)) & _
Chr$(34))
Next
End If
If Node.ChildrenCount > 0 Then
Call WriteString(">" & e)
For i = 1 To Node.ChildrenCount
Call printNode(Node.enumChild(i), pp, _
IIf(it = xmlSpace, ident + 4, ident + 1), it)
Next
Call WriteString(b & "</" & Node.Name & ">" & e)
Else
If Node.Text = "" Then
Call WriteString("/>" & e)
Else
Call WriteString(">" & Node.Text & "</" & Node.Name & ">" & e)
End If
End If
End Sub
'parse functions (used by Parse)
Private Sub Abort(errType As xmlParserError, Optional info As String = "")
Dim Description As String
Select Case errType
Case xmlExpected
Description = "Expected: " & info & " at line " & m_line & " [" & m_col & "]"
Case xmlMismatchedTag
Description = "Mismatched tag: '" & info & "' at line " & m_line & " [" & m_col - 2 & "]"
Case Else 'never happens :)
Description = "Unknown"
End Select
'Call Err.Clear
'Call Err.Raise(errType, "XMLParser", Description)
End Sub
Private Sub getChar()
m_look = ReadString
End Sub
Private Sub Match(What As String)
If m_look = What Then
Call getChar
Else
Call Abort(xmlExpected, What)
End If
End Sub
Private Sub skipWhite()
While InStr(1, " " & vbTab & vbCr & vbLf, m_look) > 0
If m_look = vbCr Then
m_line = m_line + 1
m_col = 0
End If
Call getChar
Wend
End Sub
Private Sub skipComment()
If m_look = "<" Then
If ReadString(3) = "!--" Then
Do
Call getChar
If m_look = "-" Then
If ReadString(2) = "->" Then
Call getChar
Call skipWhite
Call skipComment
Exit Do
Else
Call SeekFile(m_pos - 1)
End If
Else
If m_look = vbCr Then
m_line = m_line + 1
m_col = 0
End If
End If
Loop Until IsEOF(m_filenum)
Else
Call SeekFile(m_pos - 2)
End If
End If
Call skipWhite
End Sub
Private Function IsEOF(filenum As Integer) As Boolean
If filenum = 0 Then
IsEOF = CBool(m_pos >= Len(m_XML))
Else
IsEOF = EOF(filenum)
End If
End Function
Private Function isAlpha() As Boolean
isAlpha = InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCase$(m_look)) > 0
End Function
Private Function isDigit() As Boolean
isDigit = IsNumeric(m_look)
End Function
Private Function isValidName() As Boolean
isValidName = isAlpha Or isDigit Or (InStr(1, "`!@#$^_-:", m_look) > 0)
End Function
Private Function getName() As String
Dim n As String
n = vbNullString
While isValidName() And Not IsEOF(m_filenum)
n = n & m_look
Call getChar
Wend
Call skipWhite
getName = n
End Function
Private Function getValue(Terminator As String) As String
Dim v As String
v = vbNullString
While m_look <> Terminator And Not IsEOF(m_filenum)
v = v & m_look
Call getChar
Wend
Call skipWhite
getValue = v
End Function
Private Function parseParentNode() As clsXML
Dim Name As String
Call getChar
Call skipWhite
Call skipComment
Call Match("<")
m_hasxml = False
If m_look = "?" Then '<?xml ... ?>
Call Match("?")
Name = getName
If LCase$(Name) <> "xml" Then
Call Abort(xmlExpected, "xml")
End If
m_hasxml = True
Set m_xmlnode = New clsXML
m_xmlnode.Name = "xml"
Call readAttributes(m_xmlnode)
Call getChar
Call skipWhite
Call skipComment
Call Match("<")
Call SeekFile(m_pos - 2)
Call getChar
End If
Name = getName
Set parseParentNode = parseNode(Name)
End Function
Private Sub readAttributes(ByRef Node As clsXML)
Dim Name As String
Dim Value As String
While m_look <> "/" And m_look <> ">" And Not IsEOF(m_filenum)
Call skipWhite
Name = getName
Call Match("=")
Call Match("""")
Value = getValue("""")
Call Node.setAttribute(Name, Value)
Call Match("""")
Call skipWhite
If m_hasxml And m_look = "?" Then
Call Match("?")
End If
Wend
End Sub
'
Private Function parseNode(NodeName As String) As clsXML
Dim ret As clsXML
Dim Name As String
Dim Child As clsXML
Dim closed As Boolean
Set ret = New clsXML
ret.Name = NodeName
closed = False
Call skipWhite
Call readAttributes(ret)
If m_look = ">" Then
Call Match(">")
Call skipWhite
Call skipComment
If m_look = "<" Then
Do
Call Match("<")
Call SeekFile(m_pos - 2)
Call getChar
Call skipWhite
If m_look = "/" Then
Call Match("/")
Name = getName
If LCase$(Name) = LCase$(NodeName) Then
Call Match(">")
closed = True
Exit Do
Else
Call Abort(xmlMismatchedTag, NodeName)
End If
End If
Name = getName
Set Child = parseNode(Name)
Call ret.addChild(Child)
Call skipWhite
Call skipComment
Loop Until IsEOF(m_filenum)
Else
ret.Text = getValue("<")
End If
If Not closed Then
Call Match("<")
Call Match("/")
Name = getName
If LCase$(Name) = LCase$(NodeName) Then
Call Match(">")
Else
Call Abort(xmlMismatchedTag, NodeName)
End If
End If
Else
Call Match("/")
Call Match(">")
End If
Call skipWhite
Set parseNode = ret
End Function
'file I/O functions (used by print and parse functions)
Private Sub OpenFile(Filename As String)
m_filenum = FreeFile()
m_pos = 0
m_line = 1
m_col = 0
Open Filename For Binary As #m_filenum
End Sub
Private Sub CloseFile()
Close #m_filenum
End Sub
Private Sub SeekFile(pos As Long)
If m_filenum = 0 Then
m_pos = pos
Else
m_pos = pos
Seek #m_filenum, m_pos
End If
End Sub
Private Function ReadString(Optional Length As Long = 1) As String
Dim sBuff As String
If m_filenum = 0 Then
sBuff = Mid$(m_XML, m_pos, Length)
Else
sBuff = Space(Length)
Get #m_filenum, , sBuff
End If
ReadString = RTrim$(sBuff)
m_pos = m_pos + Length
m_col = m_col + Length
End Function
Private Sub WriteString(str As String)
Put #m_filenum, , str
End Sub
Private Sub Class_Initialize()
ReDim m_attrib(0)
ReDim m_value(0)
ReDim m_child(0)
End Sub
Public Function getAttribute(attribName As String, Optional Default As String = vbNullString) As String
Dim i As Long
i = attribLookup(attribName)
If (i > 0) Then
getAttribute = m_value(i)
Else
getAttribute = Default
End If
End Function
Public Sub setAttribute(attribName As String, Value As String)
On Error Resume Next
Dim i As Long
i = attribLookup(attribName)
If (i > 0) Then
m_value(i) = Value
Else
i = UBound(m_attrib) + 1
ReDim Preserve m_attrib(i)
ReDim Preserve m_value(i)
m_attrib(i) = attribName
m_value(i) = Value
End If
End Sub
'
Public Sub addChild(Child As clsXML)
On Error Resume Next
Dim i As Long
i = UBound(m_child) + 1
ReDim Preserve m_child(i)
Set m_child(i) = Child
'Debug.Print "Added Node '" & Child.Name & "' into '" & m_name & "'"
End Sub
Public Function enumChild(ByVal Index As Long) As clsXML
Set enumChild = m_child(Index)
End Function
Public Function AttributeName(Index As Long) As String
AttributeName = m_attrib(Index)
End Function
Private Function attribLookup(attribName As String) As Long
On Error GoTo notFound
Dim i As Long
For i = 1 To UBound(m_attrib)
If (LCase$(m_attrib(i)) = LCase$(attribName)) Then
attribLookup = i
Exit Function
End If
Next
notFound:
Call Err.Clear
attribLookup = 0
End Function
I, don't be sure if it run correctly
cXML.ParseStream(strXML)
