Summary Tag element position parsing class.

Additional information

' TagParser -- discover 1st pair of opening and closing tags. ' By DonEMitchell, Sequim, WA USA ' ' This class is presented as an exemplary technique for parsing XML tags with only ' VB string functions. ' Please report any bugs to me. Any suggestions that would improve performance ' would be appreciated. ' Setting a value to the XMLString property clears all properties, and re-parses the string. ' Text in the XMLString past the first tag is available as the TrailingString property. ' The TrailingString may contain others tags, which can be eached parsed by passing the ' TrailingString back to this parser until the TagFound property is false. ' An XML Document may be parsed, in which only the outer XML tag is discovered. ' Pass the discovered Contents property back to the parser to discover each contained ' tag element. Only the first tag is discovered at a time. The remaining tags will be ' available from the TrailingString method. Continue parsing child tags from the ' TrailingString until the TagFound property is false. ' ' To get attributes loop on AttributeItem(index) from 1 to AttributeCount Option Explicit Private mintAttributeCount As Integer 'Private mstrAttributesString As String 'construct attributes externally to enliven AttributeChange events Private mlngContentLength As Long Private mlngContentStart As Long Private mstrParseError As String Private mlngTagClosingEnd As Long Private mlngTagClosingStart As Long Private mstrTagName As String Private mstrTagOpeningInnerContents As String Private mlngTagOpeningEnd As Long Private mlngTagOpeningStart As Long Private mvntAttributeArray() As Variant Private mlngTrailingStringEnd As Long Private mlngTrailingStringStart As Long Private mstrXMLString As String Private mbooInValidTag As Boolean Private mbooTagFound As Boolean Public Property Get AttributeItem(ByVal Index As Integer) As String 'one based index On Error Resume Next AttributeItem = mvntAttributeArray(Index - 1) 'zero based array End Property Public Property Get AttributeCount() As Integer AttributeCount = mintAttributeCount End Property Public Property Get InValidTag() As Boolean InValidTag = mbooInValidTag End Property Public Property Let InValidTag(ByVal vData As Boolean) mbooInValidTag = vData End Property Public Property Get ParseError() As String ParseError = mstrParseError End Property Public Function TagOpening(ByRef strXML As String) As String TagOpening = Mid$(strXML, start:=mlngTagOpeningStart, Length:=mlngTagOpeningEnd - mlngTagOpeningStart) End Function Public Property Get TagOpeningStart() As Long TagOpeningStart = mlngTagOpeningStart End Property Public Property Get TagOpeningEnd() As Long TagOpeningEnd = mlngTagOpeningEnd End Property Public Function TagClosing(ByRef strXML As String) As String TagClosing = Mid$(strXML, start:=mlngTagClosingStart, Length:=mlngTagClosingEnd - mlngTagClosingStart) End Function Public Property Get TagClosingStart() As Long TagClosingStart = mlngTagClosingStart End Property Public Property Get TagClosingEnd() As Long TagClosingEnd = mlngTagClosingEnd End Property Public Function Content(ByVal strXML As String) As String If mlngContentStart = -1 Then Exit Function If mlngContentLength = -1 Then Exit Function Content = Mid$(strXML, mlngContentStart, mlngContentLength) End Function Public Property Get ContentStart() As Long ContentStart = mlngContentStart End Property Public Property Get ContentLength() As Long ContentLength = mlngContentLength End Property Public Property Get TagFound() As Boolean TagFound = mbooTagFound End Property Public Property Let TagFound(ByVal vData As Boolean) mbooTagFound = vData End Property Public Property Get TagName() As String TagName = mstrTagName End Property Public Function TrailingString(ByVal strXML As String) As String On Error Resume Next If mlngTrailingStringStart = -1 Then Exit Function If mlngTrailingStringEnd = -1 Then Exit Function TrailingString = Mid$(strXML, start:=mlngTrailingStringStart, Length:=mlngTrailingStringEnd - mlngTrailingStringStart + 1) End Function Public Property Get TrailingStringStart() As Long TrailingStringStart = mlngTrailingStringStart End Property Public Property Get TrailingStringEnd() As Long TrailingStringEnd = mlngTrailingStringEnd End Property ' 'Public Property Get XMLString() As String ' XMLString = mstrXMLString 'End Property Public Property Let XMLString(ByRef XML As String) 'The vData argument references (ByRef) the source XML. 'This prevents making a copy of the source. 'The root document size limit is set by memory available. 'Only positions Dim ndxOpening As Long Dim ndxClosing As Long Dim ndxCDATA As Long Dim strClosingTag As String Dim strTagOpeningInnerContents As String Dim vntTagWordsArray As Variant Dim ndxWords, ndxAtt, firstTagWord, lastTagWord As Integer On Error GoTo Trap 'Initialize object state. . . mintAttributeCount = -1 mlngContentStart = -1 mlngContentLength = -1 mstrParseError = "" mlngTagClosingStart = -1 mlngTagClosingEnd = -1 mstrTagName = "" mlngTagOpeningStart = -1 mlngTagOpeningEnd = -1 Set vntTagWordsArray = Nothing mlngTrailingStringStart = -1 mlngTrailingStringEnd = -1 mbooInValidTag = False 'until parsed with errors, see bottom mbooTagFound = False 'until parsed without errors, see bottom If Len(XML) = 0 Then mstrParseError = "No XML string provided" mbooInValidTag = True Exit Property End If 'Find opening tag metrics (excluding document elements)... ndxOpening = 0 Do ndxOpening = ndxOpening + 1 ndxOpening = InStr(ndxOpening, XML, "<") Loop Until InStr(1, "?!", Mid$(XML, ndxOpening + 1, 1)) = 0 'Ensure character following "<" is not a "?" or "!", which denotes 'other XML prolog elements, as in <?XML='1.0'...> or <!DOCTYPE...>, etc. 'Test for ndxOpening validity. . . Select Case True Case ndxOpening = 0 'no tags found mstrParseError = "No opening angle-bracket found ('<')" mbooInValidTag = False 'as no one says there has to be any tags in contents Exit Property Case Else 'no invalid conditions mlngTagOpeningStart = ndxOpening End Select 'Find end of opening tag... ndxOpening = InStr(mlngTagOpeningStart, XML, ">") If ndxOpening > 0 Then mlngTagOpeningEnd = ndxOpening Else 'non-wellformedness discovered mstrParseError = "Expected closing bracket ('>') of opening XML tag after opening bracket ('<') at position " & CStr(mlngTagOpeningStart) mbooInValidTag = True Exit Property End If 'Store opening tag inner contents excluding angle-brackets... mstrTagOpeningInnerContents = Mid$(XML, mlngTagOpeningStart + 1, mlngTagOpeningEnd - mlngTagOpeningStart - 1) 'Condition all white space (cr, lf, tab) to a single space character for splitting to an array at space delimiters. . . '(which enables pretty formatting of XML for humans with line breaks as whitespace between long attributes) mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, vbCr, Space(1)) 'return mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, vbLf, Space(1)) 'line-feed mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, vbTab, Space(1)) 'tab 'Reduce all double-spaces to single. . . Do mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, Space(2), Space(1)) 'tab Loop Until InStr(1, Space(2), mstrTagOpeningInnerContents) = 0 'no doubled-spaces remain 'Remove any superfluous spaces in attributes. . . (attribute spaces around "=") mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, " =", "=") 'space equal mstrTagOpeningInnerContents = Replace(mstrTagOpeningInnerContents, "= ", "=") 'equal space 'Clean the ends... mstrTagOpeningInnerContents = Trim(mstrTagOpeningInnerContents) 'Parse elements of tag inner contents into an array... vntTagWordsArray = Split(mstrTagOpeningInnerContents, " ") 'Name the tag element from 1st array member... mstrTagName = vntTagWordsArray(0) 'Tag name is 1st word 'Check that it's not an attribute with an '='. . . If InStr(1, mstrTagName, "=") Then 'oops -- 1st word is an attribute, missing the Name mstrParseError = "An XML tag name is missing following an opening bracket ('<') at position " & CStr(mlngTagOpeningStart) mbooInValidTag = True Exit Property End If 'Name the tag element from 1st array member... mstrTagName = vntTagWordsArray(0) 'Tag name is 1st word lastTagWord = UBound(vntTagWordsArray) ndxAtt = -1 'flag for no attributes found 'Are there any attributes?... If lastTagWord >= 1 Then 'zero based index, where tag name is vntTagWordsArray(0) firstTagWord = 1 ndxAtt = 0 'zero based index mvntAttributeArray(0) = vntTagWordsArray(1) '1 skips tag name 'Loop though word array, and concatenate any 'words that are not containing an equal sign 'into the class attribute array item. . . If lastTagWord >= 2 Then 'only more than one needs possible concatenation For ndxWords = firstTagWord + 1 To lastTagWord If InStr(1, vntTagWordsArray(ndxWords), "=") > 0 Then 'Another attribute is found ndxAtt = ndxAtt + 1 mvntAttributeArray(ndxAtt) = vntTagWordsArray(ndxWords) Else 'No equal sign found in word, add it to the preceding attribute... mvntAttributeArray(ndxAtt) = mvntAttributeArray(ndxAtt) & " " & vntTagWordsArray(ndxWords) 'This converts any original whitespace found in attribute values to a space character. End If Next End If 'lastTagWord >= 2 Then End If 'Set count of Attribute words... mintAttributeCount = ndxAtt + 1 'adjust to one based ordinal count If mintAttributeCount > 0 Then 'Check that it's not a second name without an '=', no space allowed in names, which will cause this. . . If InStr(1, vntTagWordsArray(1), "=") = 0 Then 'oops -2nd word is another name mstrParseError = "A space was found in a tag name, or an equal sign is missing in the first attribute's Name/Value pair." mbooInValidTag = True Exit Property End If End If 'Build closing tag name... strClosingTag = "</" & mstrTagName & ">" ndxClosing = mlngTagOpeningEnd + 1 Do 'Find closing tag position... ndxClosing = InStr(ndxClosing, XML, strClosingTag, vbBinaryCompare) 'case sensitive per XML 1.0 If ndxClosing > 0 Then 'something was found 'Check for an open CDATA section along the string 'spanned between opening tag and the candidate closing tag. . . ndxCDATA = InStr(1, Mid$(XML, mlngTagOpeningEnd + 1, ndxClosing - mlngTagOpeningEnd), "<![CDATA[") If ndxCDATA > 0 Then 'CDATA found 'Advance ndx to the end of the CDATA section... ndxCDATA = InStr(ndxCDATA + 9, XML, "~~>") ' 9 to start past <![CDATA[ token of 9 characters in length If ndxCDATA = 0 Then 'not Well Formed, un-closed CDATA section mstrParseError = "A CDATA section is not closed. Expected '~~', therefore element closing tag cannot be found following the CDATA opening ('<![CDATA[') at postion " & CStr(ndxCDATA) mbooInValidTag = True Exit Property Else 'ndx found ~~> ndxClosing = ndxCDATA + 3 'advance past ~~> and loop again for next attempt to find closing tag past the CDATA section End If 'ndxCDATA = 0 Else 'CDATA not found, use current ndx (which flags loop completion)... mlngTagClosingStart = ndxClosing 'satisfies loop End If 'ndxCDATA > 0 Else 'ndx <= 0 Then 'no closing tag was found mstrParseError = "Expected closing-tag '" & strClosingTag & "' after end of opening tag at ('>') at position " & CStr(mlngTagOpeningEnd) mbooInValidTag = True Exit Property End If 'If ndx > 0 Then 'something was found Loop Until (mlngTagClosingStart = ndxClosing) 'Set tag end... mlngTagClosingEnd = mlngTagClosingStart + Len(strClosingTag) - 1 'Flag well-formed tag... mbooInValidTag = False mbooTagFound = True 'parsing errors forces an exit prior to here 'Set Content metrics. . . mlngContentStart = mlngTagOpeningEnd + 1 mlngContentLength = mlngTagClosingStart - mlngTagOpeningEnd - 1 'Set metrics for any trailing characters in XML string past end of closing tag. . . If Len(XML) > mlngTagClosingEnd Then mlngTrailingStringStart = mlngTagClosingEnd + 1 mlngTrailingStringEnd = Len(XML) End If ExitPoint: Exit Property Trap: Select Case Err.Number Case 9 'Subscript out of range ReDim Preserve mvntAttributeArray(ndxAtt + 1) Resume Case Else Resume Next End Select End Property Sub dump() Debug.Print "mstrTagName: " & mstrTagName Debug.Print "mlngTagOpeningStart: " & CStr(mlngTagOpeningStart) Debug.Print "mlngTagOpeningEnd: " & CStr(mlngTagOpeningEnd) Debug.Print "mintAttributeCount: " & CStr(mintAttributeCount) Debug.Print "mlngTagClosingStart: " & CStr(mlngTagClosingStart) Debug.Print "mlngTagClosingEnd: " & CStr(mlngTagClosingEnd) Debug.Print "mlngContentStart: " & CStr(mlngContentStart) Debug.Print "mlngContentLength: " & CStr(mlngContentLength) Debug.Print "mlngTrailingStringStart: " & CStr(mlngTrailingStringStart) Debug.Print "mlngTrailingStringEnd: " & CStr(mlngTrailingStringEnd) End Sub