CodeItBetter Programming Another VB Programming Blog

'XML Handling - Create XML With XSL StyleSheet information
Sub Create_XML_With_XSL_StyleSheet(oXMLfile As String, oXSLfile As String)
'This procedure is used to create XML document
' <Family>
'    <Member Relationship="Father">
'       <Name>Some Guy</Name>
'    </Member>
' </Family>
' Requires msxml.dll (Go to Project --> References and and choose Microsoft XML version 2.0, or
'whatever the current version you have installed)
    Dim objDom As DOMDocument
    Dim objRootElem As IXMLDOMElement
    Dim objSubRootElem As IXMLDOMElement
    Dim objMemberElem As IXMLDOMElement
 
    Set objDom = New DOMDocument
 
    ' Creates root element
    Set objRootElem = objDom.createElement("ErrorLog")
    objDom.appendChild objRootElem
 
    ' Creates sub root element
    Set objSubRootElem = objDom.createElement("Error")
    objRootElem.appendChild objSubRootElem
 
    ' Creates Error Date & Time element
    Set objMemberElem = objDom.createElement("ErrorDateTime")
    objSubRootElem.appendChild objMemberElem
    objMemberElem.Text = Format(Now, "DD-MMM-YYYY hh:mm:ss")
 
    ' Creates Error Number element
    Set objMemberElem = objDom.createElement("ErrNo")
    objSubRootElem.appendChild objMemberElem
    objMemberElem.Text = "0"
 
    ' Creates Error Description element
    Set objMemberElem = objDom.createElement("ErrDesc")
    objSubRootElem.appendChild objMemberElem
    objMemberElem.Text = "Test Error. Access Denied. Please retry after sometime."
 
    ' Saves XML data to disk.
    objDom.save oXMLfile
 
    'Add header to xml file and include xsl details
    Dim strText As String
    strText = "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbCrLf & "<?xml-stylesheet type='text/xsl' href='" _
        & oXSLfile & "'?>" & vbCrLf
 
    'open the file to add headers
    Open oXMLfile For Input As #1
    strText = strText & Input$(LOF(1), #1)
    Close #1
 
    'open the file to save added headers after indenting the code
    Open oXMLfile For Output As #1
    Print #1, strText
    Close #1
 
ExitHere:
    Err.Clear
    Set objDom = Nothing
End Sub