by Deltaoo (1 Submission)
Category: Internet/HTML
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(3 Votes)
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)
Code Returns
strXML = The transformed data
bGenerate_XML = Boolean
Side Effects
No error checking.... so there may be some
VBcoders' 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
