Attribute VB_Name = "Module1"

' Set to 0 for Production Mode
#Const DEMO_MODE = 1

#If DEMO_MODE = 1 Then
Private Const MAX_RECORDS = 5
#End If

Private Const DOUBLE_QUOTE = """"
Private Const CHAR_SMALLER = "<"
Private Const CHAR_GREATER = ">"
Private Const CHAR_OBLIQUE_SMALLER = "</"
Private Const CHAR_OBLIQUE_GREATER = " />"

Private Const DEFAULT_INDENTATION = 2

Private Function strValidXMLTag(strTagCandidate As String) As String
   ' This function only handles occurrences of "xml" and
   ' replaces white space with "_".
   ' The implementation of the remaining rules is left as
   ' an exercise for the reader. ;)

   ' Get rid of occurrences of 'xml'
   strTagCandidate = Replace(strTagCandidate, "xml", "x_m_l")
   ' Get rid of spaces
   strValidXMLTag = Replace(strTagCandidate, " ", "_")
End Function

Private Function strValidXMLContent(strContenCandidate As String) As String
   ' Get rid of occurrences of '<'
   strContenCandidate = Replace(strContenCandidate, "<", "&lt;")
   ' Get rid of occurrences of '>'
   strContenCandidate = Replace(strContenCandidate, ">", "&gt;")
   ' Get rid of occurrences of '&'
   strContenCandidate = Replace(strContenCandidate, "&", "&amp;")
   ' Get rid of occurrences of '"'
   strContenCandidate = Replace(strContenCandidate, """", "&quot;")
   ' Get rid of occurrences of "'"
   strValidXMLContent = Replace(strContenCandidate, "'", "&apos;")
End Function

Public Function strRS2XML(rs As ADODB.Recordset, strName As String, _
                     Optional vntIndentation As Variant) As String
   Static objField        As ADODB.Field
   Static strSpaces       As String
   Static strFieldName    As String
   Static intLevel        As Integer
   Static intIndentation  As Integer

   Dim rsChapter         As ADODB.Recordset
   Dim strXML            As String
   Dim strDocName        As String
   Dim lngRecCount       As Long

   If IsMissing(vntIndentation) Then
      intIndentation = DEFAULT_INDENTATION
   Else
      intIndentation = vntIndentation
      If intIndentation < 0 Then intIndentation = DEFAULT_INDENTATION
   End If

   If intLevel = 0 Then   ' Only on top-level call.
      strXML = "<?xml version=" _
            & DOUBLE_QUOTE & "1.0" & DOUBLE_QUOTE _
            & " ?>" & vbCr
   End If

   strSpaces = Space$(intLevel * intIndentation)

   strName = strValidXMLTag(strName)
   If Right$(strName, 1) = "s" Then
      strDocName = strName
      strName = Left$(strName, Len(strName) - 1)
   Else
      strDocName = strName & "s"
   End If

   ' Start of Document TAG
   strXML = strXML & CHAR_SMALLER & strDocName & CHAR_GREATER & vbCr

   intLevel = intLevel + 1
   strSpaces = Space$(intLevel * intIndentation)

   rs.MoveFirst
   lngRecCount = 1

#If DEMO_MODE = 1 Then
   While Not rs.EOF And lngRecCount < MAX_RECORDS
#Else
   While Not rs.EOF
#End If

      strXML = strXML & strSpaces _
         & CHAR_SMALLER & strName & CHAR_GREATER & vbCr

      For Each objField In rs.Fields

         If objField.Type = adChapter Then

            Set rsChapter = objField.Value
            If Not rsChapter.EOF Then
               intLevel = intLevel + 1
               strXML = strXML & strRS2XML(rsChapter, strName & "." _
                                           & objField.Name, intIndentation)
               intLevel = intLevel - 1
            End If

         Else
            ' Ensure we have a correctly formed tag name
            strFieldName = strValidXMLTag(strName & "." & objField.Name)

            If IsNull(objField.Value) Then
               ' Empty Field tag
               strXML = strXML & strSpaces & Space$(intIndentation) _
                  & CHAR_SMALLER & strFieldName & CHAR_OBLIQUE_GREATER & vbCr
            Else
               ' Start of Field tag
               strXML = strXML & strSpaces & Space$(intIndentation) _
                  & CHAR_SMALLER & strFieldName & CHAR_GREATER
               ' Field tag Content
               strXML = strXML & strValidXMLContent(objField.Value)
               ' End of Field tag
               strXML = strXML & CHAR_OBLIQUE_SMALLER _
                  & strFieldName & CHAR_GREATER & vbCr
            End If
         End If

      Next objField

      strXML = strXML & strSpaces & CHAR_OBLIQUE_SMALLER & strName _
             & CHAR_GREATER & vbCr
      DoEvents

      rs.MoveNext
      lngRecCount = lngRecCount + 1
   Wend

   intLevel = intLevel - 1
   strSpaces = Space$(intLevel * intIndentation)

   strXML = strXML & strSpaces & CHAR_OBLIQUE_SMALLER & strDocName _
          & CHAR_GREATER & vbCr
   strRS2XML = strXML

End Function

Public Function objRS2XML_DOM(rs As ADODB.Recordset, strName As String) _
       As MSXML2.IXMLDOMElement

   Static objField         As ADODB.Field
   Static intLevel         As Integer
   Static objXMLDocument   As MSXML2.DOMDocument
   Static objChild         As MSXML2.IXMLDOMElement

   Dim objRoot          As MSXML2.IXMLDOMElement
   Dim objElement        As MSXML2.IXMLDOMElement
   Dim rsChapter         As ADODB.Recordset
   Dim strDocName        As String
   Dim lngRecCount       As Long

   strName = strValidXMLTag(strName)
   If Right$(strName, 1) = "s" Then
      strDocName = strName
      strName = Left$(strName, Len(strName) - 1)
   Else
      strDocName = strName & "s"
   End If
   If intLevel = 0 Then   ' Only on top-level call
      Set objXMLDocument = New MSXML2.DOMDocument
   End If

   intLevel = intLevel + 1

   ' Start of Document TAG
   Set objRoot = objXMLDocument.createElement(strDocName)

   rs.MoveFirst
   lngRecCount = 1

#If DEMO_MODE = 1 Then
   While Not rs.EOF And lngRecCount < MAX_RECORDS
#Else
   While Not rs.EOF
#End If

      Set objElement = objXMLDocument.createElement(strName)
      objRoot.appendChild objElement

      For Each objField In rs.Fields
         ' Is this a hierarchical recordset?
         If objField.Type = adChapter Then
            Set rsChapter = objField.Value
            If Not rsChapter.EOF Then
               objElement.appendChild objRS2XML_DOM(rsChapter, strName & "." _
                                                    & objField.Name)
            End If
         Else
            Set objChild = objXMLDocument.createElement( _
                        strValidXMLTag(strName & "." & objField.Name))
            If Not IsNull(objField.Value) Then
               objChild.Text = strValidXMLContent(objField.Value)
            End If
            objElement.appendChild objChild
         End If
      Next objField
      DoEvents
      rs.MoveNext
      lngRecCount = lngRecCount + 1
   Wend

   ' The (child) recordset has been processed,
   ' so we decrease the level.
   intLevel = intLevel - 1

   If intLevel = 0 Then   ' Only on top-level call.
      Set objXMLDocument = Nothing
   End If

   ' Finally, return Root element
   Set objRS2XML_DOM = objRoot

End Function

Public Sub Main()
   Dim strPath          As String

   ' Normalize Path
   strPath = App.Path
   If Right$(strPath, 1) <> "/" Then
      strPath = strPath & "/"
   End If

   CreateAuthorsXML strPath & "Authors.xml"
End Sub

Public Sub CreateAuthorsXML(strXMLFile As String)
   Dim intFileNumber   As Integer
   Dim rsAuthors      As ADODB.Recordset
   Dim objRoot          As MSXML2.IXMLDOMElement

   Set rsAuthors = New ADODB.Recordset
   rsAuthors.Source = "SELECT au_id, au_fname, au_lname " _
                    & "FROM Authors"

   rsAuthors.ActiveConnection = "Provider=sqloledb;Data Source=localhost;" _
                              & "Initial Catalog=pubs;User Id=sa;Password="

   ' All set to open recordset...
   rsAuthors.Open

   ' Call objRS2XML_DOM which returns the Root element
   Set objRoot = objRS2XML_DOM(rsAuthors, "Author")

   ' Get unused file number create file
   intFileNumber = FreeFile
   Open strXMLFile For Output As #intFileNumber

   ' Output text
'   Print #intFileNumber, strRS2XML(rsAuthors, "Author")
   Print #intFileNumber, objRoot.xml

   ' Clean Up
   Close #intFileNumber
   rsAuthors.Close
   Set rsAuthors = Nothing

End Sub
