XML_Generator

' Coded by Deltaoo
'  Mail [email protected]
'-------------------------------
'Use this code to convert a recordset to XML
' Use bGenerate_XML as boolean
Option Explicit
'  -- CONSTANTS --
Const XML_OPEN = "<?xml version=""1.0"" encoding=""UTF-8""?>"
Const XML_CLOSE = "" '"</xml>"

Private Function AddNode(strNodeValue As String, strNodeName As String) As String
Dim strRet     As String
  strRet = "     <" & LCase(ReplaceString(strNodeValue)) & ">"
  strRet = strRet & strNodeName & "</" & LCase(ReplaceString(strNodeValue)) & ">"
  AddNode = strRet
'
End Function
Public Function bGenerate_XML(strParentName As String, oRS As ADODB.Recordset, ByRef strXML As String) As Boolean
Dim strRet     As String
Dim n        As Integer
Dim strRootName   As String
On Error Resume Next ' Must handle the error for NULLS///
  strRootName = Trim(LCase(strParentName)) & "s"
  strParentName = LCase(strParentName)
  strRet = XML_OPEN & vbCrLf
  strRet = strRet & "<" & strRootName & ">" & vbCrLf
    With oRS
    Do Until .EOF
      strRet = strRet & "   <" & strParentName & ">" & vbCrLf
      For n = 0 To .Fields.Count - 1
      strRet = strRet & AddNode(.Fields(n).Name, .Fields(n)) & vbCrLf
      Next n
    .MoveNext
      strRet = strRet & "   </" & strParentName & ">" & vbCrLf
    Loop
    End With
  strRet = strRet & "</" & strRootName & ">" & vbCrLf
  strRet = strRet & XML_CLOSE & vbCrLf
  ' test the XML Before sending it back to the Caller
    bGenerate_XML = b_XML_OK(strRet)
    strXML = strRet
End Function
Private Function ReplaceString(strValue) As String
Dim strRet
  If IsNull(strValue) Then strValue = ""
  strRet = strValue
  strRet = Replace(strRet, "&", "&amp;")
  strRet = Replace(strRet, "<", "&lt;")
  strRet = Replace(strRet, ">", "&gt;")
  strRet = Replace(strRet, """", "&quot;")
  strRet = Replace(strRet, "'", "&apos;")
  '  -- Pass the value back --
  ReplaceString = strRet
End Function
Private Function b_XML_OK(strXMLData As String) As Boolean
Dim oDOM      As MSXML2.DOMDocument
Dim bProcOK     As Boolean
  Set oDOM = CreateObject("MSXML2.DOMDocument")
    bProcOK = oDOM.loadXML(bstrXML:=strXMLData)
    If Not bProcOK Then strXMLData = oDOM.parseError.reason
  Set oDOM = Nothing
    b_XML_OK = bProcOK
End Function