• Home
 · 
• Internet/HTML
 · 
• XMLGenerator

XMLGenerator

Generate XML from ADO recordsets.

Inputs
'Set a ref to MS ADO and MSXML3.0 strParentName=name of top level node (usually the table name) oRS = Recordset

Assumes
Use as follows... Create a procedure to connect to and retreive a recorset from a datasource. Dim a strVariable to hold the returned xml and a boolen to check the ceration process... dim strXML as string Dim bOK as boolean 'Use as follows... bOK=bGenerate_XML("tablename", oRS , strXML)

Returns
strXML = The transformed data bGenerate_XML = Boolean

Side Effects
No error checking.... so there may be some

Rate XMLGenerator

• 1
• 2
• 3
• 4
• 5

(3(3 Vote))

' 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 = ""
Const XML_CLOSE = "" '""

Private Function AddNode(strNodeValue As String, strNodeName As String) As String
Dim strRet     As String
  strRet = "     <" & LCase(ReplaceString(strNodeValue)) & ">"
  strRet = strRet & strNodeName & ""
  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 & "   " & vbCrLf
    Loop
    End With
  strRet = strRet & "" & 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, "&", "&")
  strRet = Replace(strRet, "<", "<")
  strRet = Replace(strRet, ">", ">")
  strRet = Replace(strRet, """", """)
  strRet = Replace(strRet, "'", "'")
  '  -- 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