So lately a bunch of people are asking a little more about XML and XML DOM. Sometime ago when I was trying to learn how XML dom worked I threw this vbs class together to assist in reading and writing xml via the DOM. For those of you whom are not aware of the dom its the XML Document Object Model.
Using the DOM you can traverse xml nodes read and manipulate data. Looking at this entirely from a packaging perspective its a great way to store and read package data into a package.
So the attached script emulates the functionality in the NetFX classes, something I was not aware of prior to writing this code. So here is a bunch of vbs function (or methods for the dev's out there). Using these methods you can add / get / set and delete xml data from an XML structure. There is even a simple method to format the white space for readability purposes.
There is a bunch of sample code at the top of the script to aid in how this should be used. If anyone is after some more specific requests in how they can pull data from xml drop a few comments and I will endeavour to answer your questions.
The code is pretty old but its a great starting point for those of you whom are interested in learning xml.
'============================================================================
' LANG: VBScript
' NAME: IpXMLClass.vbs
' AUTHOR: John McFadyen (john.mcfadyen@gmail.com)
' VERSION: 0.1
' DATE: 2006-07-30
' Description: Generate / edit / query an XML file
'
' UPDATES: http://www.installpac.com/scripting
'
' For Options: This script has no options and is expected to be used as a class.
' Feedback: Please send feedback to john.mcfadyen@gmail.com
'
' Notes:
' This has has only been tested with MSXML
' LICENSE:
' Copyright (c) 2004-2006, John McFadyen
' All rights reserved.
'
' Redistribution and use in source and binary forms, with or without
' modification, are permitted provided that the following conditions are met:
'
' * Redistributions of source code must retain the above copyright notice,
' this list of conditions and the following disclaimer.
' * Redistributions in binary form must reproduce the above copyright notice,
' this list of conditions and the following disclaimer in the documentation
' and/or other materials provided with the distribution.
' * Neither the name Installpac or the names of its contributors may be used
' to endorse or promote products derived from this software without
' specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
' IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
' ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
' LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
' CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
' INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
' CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
' ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
' POSSIBILITY OF SUCH DAMAGE.
'==========================================================
'==========================================================
' Example 1 Generating a new xml document
' =======================================
' set xmlDoc = new XMLDom
' xmlDoc.filenameXML = "Johnny.xml"
' call xmldoc.CreateElement("Root")
' call xmldoc.CreateElement("License")
' call xmldoc.CreateElementString("starttime", now())
' call xmldoc.CreateElementString("starttime", now())
' call xmldoc.CreateElementString("starttime", now())
' call xmldoc.CreateElementString("starttime", now())
' call xmldoc.CreateElement("Hello")
' call xmldoc.CreateEndElement
' call xmldoc.CreateElement("Hello1")
' call xmldoc.close
'
' Example 2 Updating a current xml
' ================================
' set xmlDoc = new XMLDom
' xmlDoc.filenameXML = "Y:\Projects\TestApplication_1-0_R01\TestApplication_1-0_R011New.XML"
' xmlDoc.ValidateXML "Y:\Projects\TestApplication_1-0_R01\TestApplication_1-0_R011.XML"
' xmlDoc.XMLLoader "Y:\Projects\TestApplication_1-0_R01\TestApplication_1-0_R011.XML"
' Note: The following line using an external object
' set objNode = xmlDoc.GetNode("//PACKAGESRC")
' xmlDoc.SetNodeValue "Test", objNode, false
' set objNodeLocation = xmlDoc.GetNode("//LOCATION")
' xmlDoc.CreateElementString "NewNode", "test"
' xmlDoc.close
' Example 3 Using an actual stylesheet
' =========
' call xmldoc1.CreateElement("Root")
' call xmldoc1.CreateXmlProcess("stylesheet.xsl")
' call xmldoc1.CreateElement("License")
' call xmldoc1.CreateElementString("starttime", now())
' call xmldoc1.CreateElementString("starttime", now())
' call xmldoc1.CreateElementString("starttime", now())
' call xmldoc1.CreateElementString("starttime", now())
' call xmldoc1.CreateAttribute("test", "value1")
' call xmldoc1.CreateAttribute("test1", "value1")
' call xmldoc1.CreateAttribute("test2", "value1")
' call xmldoc1.CreateEndElement
' call xmldoc1.close
'
'=========================================================================================================
'=========================================================================================================
' Script version
Dim strScriptVersion
strScriptVersion = "0.1"
'=========================================================================================================
class XMLDom
dim xmlfilename 'stores the xml filename
dim xslfilename 'stores the xsl filename
dim xmldom 'stores a DOM Object
dim xmlroot 'stores the Root Node
dim xmlcurrentnode 'stores the Current Node
dim xmlparent 'stores the Parent Node of current node
dim xmlelements
dim intIndentation 'stores the indentspacing (not required with XSL sheet applied)
dim blnWhiteSpace
'=========================================================================================================
private Sub Class_Initialize
dim xmldeclaration
Set xmlDom = CreateObject("Microsoft.XMLDOM")
xmlDom.preserveWhiteSpace = False
xmlDom.loadxml "<?xml version='1.0'?>"
'xmlDom.createProcessingInstruction("<?xml version='1.0'?>")
set xmlcurrentnode = xmlDom
End Sub
private Sub Class_Terminate
'xmldom.LoadXML TransformXML
'if xmlFilename <> nothing then xmldom.save(xmlFilename)
End Sub
'=========================================================================================================
public Property let FilenameXML(strFilename)
xmlFilename = strFilename
End Property
public Property let FilenameXSL(strFilename)
xslFilename = strFilename
End Property
public Property let Indentspacing(intIndentSpacing)
' Not required now we are using stylesheets
End Property
public Property let Whitespace(blnWhiteSpace)
sprpWhiteSpace = blnWhiteSpace
End Property
public Property get Whitespace()
sprpWhiteSpace = prpWhiteSpace
End Property
public Property let EmptyAttribute(blnAllowEmpty)
prpAllowEmpty = blnWhiteSpace
End Property
'=========================================================================================================
public function CreateRootElement(strRootNode)
set xmlroot = xmldom.CreateElement(strRootNode)
xmldom.appendchild xmlroot
set xmlcurrentnode = xmlroot
Set objProcessing = xmlDom.CreateProcessingInstruction("xml","version='1.0'")
xmlDom.insertBefore objProcessing ,xmlroot
'xmlroot.appendChild xmlDom.CreateTextNode(vbcrlf & string(indentLevel, Chr(9)))
end function
sub CreateElement(strElementName)
dim xmlNewNode
set xmlNewNode = xmlDom.createElement(strElementName)
xmlcurrentnode.appendchild xmlNewNode
set xmlcurrentnode = xmlNewNode
'xmldom.save xmlFilename
'xmlcurrentnode.appendChild xmlDom.CreateTextNode(vbcrlf & string(indentLevel, Chr(9)))
end sub
sub CreateElementString(strElementName, strElementValue)
dim xmlNewNode
set xmlNewNode = xmlDom.createElement(strElementName)
if isnull(strElementValue) then strElementValue = ""
xmlNewNode.text = strElementValue
xmlcurrentnode.appendchild(xmlNewNode)
'xmlcurrentnode.appendChild xmlDom.CreateTextNode(vbcrlf & string(indentLevel, Chr(9)))
end sub
sub CreateElementStringNew(strElementName, strElementValue)
dim xmlNewNode
set xmlNewNode = xmlDom.createElement(strElementName)
if isnull(strElementValue) then strElementValue = ""
xmlNewNode.text = strElementValue
xmlcurrentnode.appendchild(xmlNewNode)
'xmlcurrentnode.appendChild xmlDom.CreateTextNode(vbcrlf & string(indentLevel, Chr(9)))
end sub
sub CreateEndElement
set xmlcurrentnode = xmlcurrentnode.parentnode
end sub
sub DeleteEndElement
dim xmlEndNode
set xmlEndNode = xmlcurrentnode
set xmlcurrentnode = xmlcurrentnode.parentnode
xmlcurrentnode.removechild(xmlEndNode)
end sub
Function RemoveElement(strNodename, objNode)
Dim objRemoveElement ' As MSXML2.IXMLDOMNode
If Not objNode Is Nothing Then
Set objRemoveElement = objNode.SelectSingleNode(strNodename)
If Not objRemoveElement Is Nothing Then
objNode.removeChild objRemoveElement
End If
End If
End Function
Public Function RemoveElements(sXPath, objNode)
Dim objNodes ' As MSXML2.IXMLDOMNodeList
Dim intNodeCount ' As Long
Set objRemoveElements = objNode.selectNodes(sXPath)
if not objRemoveElements is nothing then
For intNodeCount = 0 To objRemoveElements.length - 1
objRemoveElements(intNodeCount).parentNode.removeChild objRemoveElements(intNodeCount)
Next
end if
End Function
Public Function GetElements
set xmlElements = xmlDom.DocumentElement
set GetElements = xmlElements
end function
'=========================================================================================================
sub CreateAttribute(strAttrName,strAttrValue)
if isnull(strAttrValue) then strAttrValue = ""
xmlcurrentnode.setAttribute strAttrName, strAttrValue
end sub
Public Function GetAttribute(strAttrName, objNode) ' as string
Dim objAttr ' As MSXML2.IXMLDOMNode
GetAttribute = ""
If Not objNode Is Nothing Then
Set objAttr = objNode.Attributes.getNamedItem(strAttrName)
If Not objAttr Is Nothing Then
GetAttribute = CStr(objAttr.Text)
End If
End If
End Function
Public Function SetAttribute(strAttrName, strAttrValue, objNode)
Dim objAttr ' As MSXML2.IXMLDOMNode
If Not objNode Is Nothing Then
If strAttrValue <> "" or AllowEmptyAttr Then
Set objAttr = objNode.Attributes.getNamedItem(strAttrName)
If objAttr Is Nothing Then
Set objAttr = CreateAttribute(strAttrName, strAttrValue, objNode)
End If
objAttr.Text = strAttrValue
Else
RemoveAttribute strAttrName, objNode
End If
End If
End Function
Function RemoveAttribute(strAttrName, objNode)
If Not objNode Is Nothing Then
objNode.Attributes.removeNamedItem strAttrName
End If
End Function
'=========================================================================================================
Public Function HasChildNodes()
HasChildNodes = False
if xmlCurrentNode.HasChildNodes then HasChildNodes = True
end function
Public Function NodeExists(strNodeName)
Dim objNode
msgbox "node test"
NodeExists = false
' if xmlCurrentNode.HasChildNodes then
For each objNode in xmlCurrentNode.ChildNodes
msgbox objNode.Nodename
if objNode.Nodename = strNodename then
NodeExists = True
exit for
end if
next
' end if
end function
Public Function GetChildNodes()
'On Error Resume Next
Dim arrNodes()
redim preserve arrNodes(1,0)
y = 0
For each objNode in xmlCurrentNode.ChildNodes
if y >= ubound(arrNodes,2) then redim preserve arrNodes(1,y)
arrNodes(0,y) = objNode.Nodename
arrNodes(1,y) = objNode.Text
y = y + 1
Next
GetChildNodes = arrNodes
End Function
Public Function GetNode(sXpath)
on error resume next
'Note: requires GetElements to be run first
' : preffered to get to external object as well.
' : I.E. set objNode = GetNode("//Nodename")
if not xmlelements then
GetElements
end if
set xmlcurrentnode = xmlElements.selectSingleNode(sXPath)
Set GetNode = xmlcurrentnode
end function
Public Function GetNodeValue(objNode, blnCData) ' As String
on error resume next
if not xmlelements then
GetElements
end if
set xmlcurrentnode = xmlElements.selectSingleNode(sXPath)
If Not xmlcurrentnode Is Nothing Then
If blnCData Then
If xmlcurrentnode.childNodes.length > 0 Then
GetNodeValue = CStr(xmlcurrentnode.childNodes(0).nodeTypedValue)
End If
Else
GetNodeValue = CStr(xmlcurrentnode.Text)
End If
End If
End Function
Public Function SetNodeValue(strNodevalue, objNode, blnCData) ' As String
on error resume next
If Not objNode Is Nothing Then
If blnCData Then
If objNode.childNodes.length > 0 Then
objNode.childNodes(0).nodeTypedValue = sValue
Else
objNode.appendChild objNode.ownerDocument.createCDATASection(strNodevalue)
End If
Else
objNode.Text = strNodevalue
End If
End If
End Function
'=========================================================================================================
sub CreateXmlProcess (strProcessInstruction)
dim xmlProcessInstruction
Set xmlProcessInstruction = xmlDom.createProcessingInstruction(strProcessInstruction)
xmlDom.appendChild(xmlProcessInstruction)
end sub
sub CreateXSlProcess (strProcessInstruction)
dim xmlProcessInstruction
Set xmlProcessInstruction = xmlDom.createProcessingInstruction("xml-stylesheet", "type=""text/xsl"" href="""& strProcessInstruction & """")
xmlDom.appendChild(xmlProcessInstruction)
end sub
Public Sub StartInsertAt(objParentNode)
Set xmlcurrentnode = objParentNode
End Sub
function LoadXML(strxml)
xmldom.loadXML(strxml)
end function
public function XMLLoader(strXML)
xmldom.load(strXML)
end function
Public Function validateXML(strXML)
Dim sReturn
xmldom.async = 0
xmldom.resolveExternals = 1
xmldom.validateOnParse = 1
If xmldom.load(strXML) Then
Else
If xmldom.parseError.errorCode <> 0 Then
strReturn = xmldom.parseError.reason & vbcrlf & _
xmldom.parseError.line & vbcrlf & _
xmldom.parseError.linepos & vbcrlf & _
xmldom.parseError.srcText
End If
End IF
ValidateXML = strReturn
End Function
Public Function transformXML1(strXML,strXSL)
Dim xslDoc
Set xslDoc = New MSXML2.DOMDocument40
If xmlDom.parseError.errorCode = 0 Then
xslDom.Load strXSL
If xslDoc.parseError.reason = "" Then
return = xmlDom.transformNode(xslDoc)
Else
return = "Error: Stylesheet.xsl did not load. " & _
xslDoc.parseError.reason
End If
Else
return = "Error: XML did not load. " & _
xmlDoc.parseError.reason
End If
transformXML1 = return
Set xslDoc = Nothing
End Function
function TransformXML
dim objStylesheet
set objStylesheet = CreateObject("Microsoft.XMLDOM")
objStylesheet.async = False
objStylesheet.loadXML ("<?xml version=""1.0"" encoding=""UTF-8""?>" & vbcrlf & _
"<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" & vbcrlf & _
"<xsl:output method=""xml"" indent=""yes"" encoding=""UTF-8"" />" & vbcrlf & _
"<xsl:template match=""@* | node()"">" & vbcrlf & _
" <xsl:copy>" & vbcrlf & _
" <xsl:apply-templates select=""@* | node()"" />" & vbcrlf & _
" </xsl:copy>" & vbcrlf & _
"</xsl:template>" & vbcrlf & _
"</xsl:stylesheet>")
'objStyleSheet.Save "c:\test.xsl"
TransformXML = xmlDOM.transformNode(objStylesheet)
end function
'=========================================================================================================
sub close()
xmldom.LoadXML TransformXML
xmldom.save(xmlfilename)
end sub
end class
Tools 
