VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Convert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private XMLDoc As IXMLDOMDocument 'The document itself
Private SQLString As String 'The SQL Statement
Private connString As String 'The connection string for SQL Server
Private Response As Response 'Our Response ASP Object
Private blnError As Boolean
Private strErrMessage As String
Private strErrNum As String
Private strErrSource As String
Dim arrXMLElementName(4) As Variant
    'arrXMLElementName id used with the recursive function to assign
    'the tag names.  must be global. Because this is global,
    'we can call it from anywhere by using a numeric reference

Private Sub Class_Terminate()
    Set Response = Nothing
End Sub

Public Function Convert() As Variant
Dim oConn As ADODB.Connection 'Connection object
Dim objRS As ADODB.Recordset 'Parent recordset
Dim XMLRoot As IXMLDOMElement 'The Root Node of the XML Document
Dim XMLParent As IXMLDOMElement 'The AreaNode
Dim XMLInstruct As IXMLDOMProcessingInstruction
'To create the processing tags
  
'------------------------------------------------------------
'Here are are assigning the Element names we will be using,
'although not all will be used.  Note this is global
'------------------------------------------------------------
arrXMLElementName(0) = "Order_Detail"
arrXMLElementName(1) = "Product_Detail"
arrXMLElementName(3) = "Supplier"

'------------------------------------------------------------
'Get the object context, then assign to response object
'------------------------------------------------------------
Set Response = GetObjectContext("Response")

'------------------------------------------------------------
'now are going to create the XML document, initialize it
'------------------------------------------------------------
Set XMLDoc = New MSXML.DOMDocument
With XMLDoc
    .async = False 'We do not want asynchronous downloads
    .validateOnParse = False 'don't want to validate
    .preserveWhiteSpace = False 'do not preserve white space
    .resolveExternals = False 'do not resolve external DTDs, etc
End With

'------------------------------------------------------------
'First we have to set the processing instructions.  First the
'xml tag <?xml version="1.0"?> will be created, then we will
'tell the document where the stylesheet is located.  To do this
'we use the same xml object, but assign it twice.  Then after
'this has been completed, it is no longer needed, so we
'destroy it.
'------------------------------------------------------------
Set XMLInstruct = XMLDoc.createProcessingInstruction("xml", " version=""1.0""")
XMLDoc.appendChild XMLInstruct
Set XMLInstruct = Nothing
Set XMLInstruct = XMLDoc.createProcessingInstruction("xml:stylesheet", " type=""text/xsl"" href=""style.xsl""")
XMLDoc.appendChild XMLInstruct
Set XMLInstruct = Nothing


'------------------------------------------------------------
'Creates the root of the document, then creates the parent
'element. The parent element will be the root of all
'data/elements taken from the recordset.  Other parent
'elements can exist; they would be different areas of the xml doc
'------------------------------------------------------------
'Root element
Set XMLRoot = XMLDoc.createElement("Root") 'Set the value
XMLDoc.appendChild XMLRoot 'And then attach it to the document.
XMLRoot.setAttribute "Name", "Northwind Order Sheet" 'The name of the tag, then the value
XMLRoot.setAttribute "xmlns", "x-schema:schema.xml"

'------------------------------------------------------------
'Initialize the database objects
'------------------------------------------------------------
Set oConn = New ADODB.Connection
Set objRS = New ADODB.Recordset

'------------------------------------------------------------
'Open the connection using a datashaping provider and OLEDB,
'then open the recordset, using a SQL string built in the asp
'page.
'------------------------------------------------------------
oConn.Open connString
objRS.CacheSize = 10
objRS.Open SQLString, oConn, adOpenForwardOnly, _
    adLockReadOnly, adCmdText

'------------------------------------------------------------
'Here we call the function and pass the appopriate data
'--objRS is the recordset
'--XMLParent is the node on the xml document that subsequent
'   elements will be attached to
'--Integer-->arrXMLElementName is an array that holds the various
'   values we want to assign to elements that hold child data.
'   these are Area,Topic,SubTopic. The integer is the place
'   value corresponding to the Array
'------------------------------------------------------------
Call Create_XMLNode(objRS, XMLRoot, 0)

'------------------------------------------------------------
'saves the document to a file on the computer if you wish
'------------------------------------------------------------
'XMLDoc.Save YourPath & "\cxml.xml"
'Response.Write ("<p><a href='testxml.xml'>")
'Response.Write ("To check the XML file click here</a></p>")

'------------------------------------------------------------
'Pass the xml back to the asp page
'------------------------------------------------------------
Convert = XMLDoc.xml


'------------------------------------------------------------
'Release the objects back into the pool
'------------------------------------------------------------
'objCtx.SetComplete
Set XMLRoot = Nothing
Set XMLDoc = Nothing
'for some reason we don't need to close the original RS.
'my guess is that it somehow gets closed in the convert()
'If objRS.State <> adStateClosed Then objRS.Close
Set objRS = Nothing
oConn.Close
Set oConn = Nothing
'blnError = False

RoutineExit:
    Exit Function

'------------------------------------------------------------
'Error handler.  releases objects back into the pool, then
'gets the error information to pass back to the ASP page
'------------------------------------------------------------
ErrorHandler:
    Response.Write ("ERROR OCCURED")
    blnError = True
    strErrMessage = Err.Description
    strErrSource = Err.Source
    strErrNum = Err.Number
    Set XMLRoot = Nothing
    Set XMLDoc = Nothing
    objRS.Close
    Set objRS = Nothing
    oConn.Close
    Set oConn = Nothing
    
    Resume RoutineExit

End Function


Private Function Create_XMLNode(objRSet As ADODB.Recordset _
            , XMLCurrentElement As IXMLDOMElement, _
            ElementName As Integer)
'=================================================================
'This is a recursive function to create the xml file.  it runs
'a DO...LOOP & a FOR...NEXT loop to run through the recordset.
'When an adChapter type is found on one of the fields, that means
'it represents a child recordset.  When this happens, a base element
'is assigned, then the function is called again which creates the
'child elements.
'=================================================================
Dim count1 As Integer
Dim x As Integer

count1 = objRSet.Fields.Count 'count the fields
Dim XMLChild As IXMLDOMElement
Do Until objRSet.EOF
    x = 0
    For x = 0 To count1 - 1
        If objRSet(x).Type = adChapter Then
            '------------------------------------------------------------
            'now we need to assign a tag for the topic, so that the
            'child elements are nested correctly. This way we have the
            'title as a topic, but the contents of the child recordset
            'are the subtopic. NOTE: there is no text for this tag
            '------------------------------------------------------------
            Set XMLChild = XMLDoc.createElement(arrXMLElementName(ElementName)) 'Create base element
'           XMLChild.Text = CStr(objRS(x).Value)
            Dim objChild As ADODB.Recordset
            Set objChild = objRSet(x).Value 'Assign the child recordset
            XMLCurrentElement.appendChild XMLChild
            XMLChild.setAttribute "Name", objRSet(x).Name
            Call Create_XMLNode(objChild, XMLChild, ElementName + 1) 'Call function
        Else
            Set XMLChild = XMLDoc.createElement(arrXMLElementName(ElementName))
            If Not IsNull(objRSet(x).Value) Then XMLChild.Text = CStr(objRSet(x).Value)
            XMLCurrentElement.appendChild XMLChild
            XMLChild.setAttribute "Name", objRSet(x).Name
        End If
    Next
    objRSet.MoveNext
Loop
objRSet.Close
Set objRSet = Nothing
Set XMLChild = Nothing
Set XMLCurrentElement = Nothing



RoutineExit:
    Exit Function

ErrorHandler:
    blnError = True
    Set objRSet = Nothing
    Set XMLCurrentElement = Nothing
    Set XMLChild = Nothing
    strErrMessage = Err.Description
    strErrSource = Err.Source
    strErrNum = Err.Number
    
    Resume RoutineExit
    
End Function

Public Property Let SQL_String(ByVal vData As String)
    SQLString = vData
End Property
Public Property Let Connection(ByVal vData As String)
    connString = vData
End Property
Public Property Get ErrorExists() As Boolean
    ErrorExists = blnError
End Property
Public Property Get ErrorMessage() As String
    ErrorMessage = "Error Number & Source: " & strErrNum & _
    " --> " & strErrSource & "<br>"
    ErrorMessage = ErrorMessage & "Error Message: " & strErrMessage
End Property