Create XML and XSL files from SQL SELECT statement (1 Viewer)

Status
Not open for further replies.

Bogzla

Registered User.
Local time
Today, 19:03
Joined
May 30, 2006
Messages
55
Yep, I know access has the capability to export XML files, but they use the parser in IE and so cannot be viewed by Firefox.. so I wrote some code to create (basic) xml and xsl files to display data in a table...
It is probably in need of some refinement, as I do not yet know a great deal about styling xml data and am still relatively inexperienced in VB... but it does seem to work. Only limitation will be maximum string length (~2 billion characters, according to MS vba help). code could be modified to use multiple strings and append them sequentially to the saved files if it is necessary to create files larger than this limit...

code is form based, I will start with the sub that starts the whole process and saves the files, then the functions which are called from this sub to create the XML and XSL strings which are then passed back and saved as files. Then I will try and post an example...
Code:
Private Sub cmdXML_Click()
On Error GoTo Err_cmdXML_Click
'18/08/2006 R.Stevens
'Set reference for 'Microsoft Scripting Runtime' in Tools > References
'runs from a form with 3 text boxes named txtFileName for user to choose their own filename for .xml and .xsl documents, txtRoot for user to choose
'the root tagname for XML file and txtChild for user to choose a name for the child elements of the root.
'Also a command button named cmdXML.
'As it stands, both XML file and XSL stylesheet will be placed in the same folder and have the same name, although this could be altered if so desired

Dim strFilename As String
Dim strRoot As String
Dim strChild As String
Dim strSQL As String
Dim strXML As String
Dim strXSL As String
Dim fso As New Scripting.FileSystemObject
Dim ts As Scripting.TextStream

'first grab variables from text boxes on the form and check they are not empty
strFilename = Nz(Forms![YourFormName]!txtFilename, "NoFileName")
strRoot = Nz(Forms![YourFormName]!txtRoot, "NoRootChosen")
strChild = Nz(Forms![YourFormName]!txtChild, "NoChildChosen")
If strFilename = "NoFileName" Then
    MsgBox "Please choose A filename!"
    Me.txtFilename.SetFocus
    GoTo Exit_cmdXML_Click
ElseIf strRoot = "NoRootChosen" Then
	MsgBox "Please choose a name for the root tag!"
	Me.txtRoot.SetFocus
	GoTo Exit_cmdXML_Click
ElseIf strChild = "NoChildChosen" Then
	MsgBox "Please choose a name for the child tags!"
End If

'next obtain SQL statement - in this case the SQL comes from another function bound to the form, but it could be called from a stored query
'or a textbox on the form etc etc...
strSQL = GetSQL()
If strSQL = "" Then
	MsgBox "SQL statement is empty, please check the source"
    GoTo Exit_cmdXML_Click
End If

'Pass SQL statement to functions which build XML and XSL strings, and store the returned strings
strXML = XML(strSQL, strFilename, strRoot, strChild)
strXSL = XSL(strSQL, strRoot, strChild)

'open the file with the name stored in strFilename. In this case I have chosen to store the folder to save to in hardcode, but it
'could easily be altered so that the full pathname must be entered into txtFilename. the 'True' argument means that the named file will be
'created if it does not exist. 'ForWriting' means that the entire file will be overwritten if it does exist
'note that the folder MUST already exist
Set ts = fso.OpenTextFile("C:\test\" & strFilename & ".xml", ForWriting, True)
'with the file open, write the xml text stream to it (note that this will work for any text file, even if it does not have the *.txt extension)
ts.Write strXML

'repeat the above for XSL file
Set ts = fso.OpenTextFile("C:\test\" & strFilename & ".xsl", ForWriting, True)
ts.Write strXSL

'close the text stream object
ts.Close
Set ts = Nothing

Exit_cmdXML_Click:
    Exit Sub
Err_cmdXML_Click:
    MsgBox "cmdXML_Click Error# " & Err.Number & " - " & Err.Description
End Sub

Code to create XML...
Code:
Public Function XML(strSQL As String, strFilename As String, strRoot As String, strChild As String) As String
 On Error GoTo Err_XML
'18/08/2006 R.Stevens
'This function will take an SQL string and convert it to XML data format, with a reference to XSL stylesheet written by XSL Function
'Function uses ADO so set reference to 'Microsoft ActiveX Data Object Library' in Tools > References
 
Dim strXML As String
Dim varItem As Variant
Dim RS As ADODB.Recordset
Dim Connection As ADODB.Connection

Set RS = New ADODB.Recordset
Set Connection = Application.CurrentProject.Connection

'open recordset from SQL statement with the above connection
RS.Open strSQL, Connection, adOpenStatic

'check recordset is not empty
If RS.BOF And RS.EOF Then
MsgBox "There is a problem with your selection - the data you requested is not available"
GoTo Exit_XML
End If

'start building XML code - XML declaration, ref to style sheet location - this coding assumes it will be in the same folder
'and the root element are defined here
strXML = "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbCrLf & _
            "<?xml-stylesheet type='text/xsl' href='" & strFilename & ".xsl'?>" & vbCrLf & _
            "<" & strRoot & ">" & vbCrLf
			
'next we go through each record in the recordset, a child node is created for each record, and within that a child element is created for every field. these elements are named according to the field name.
'note 'Nz(varItem.Value, "-") in the code - null values here can cause problems on occasion...
RS.MoveFirst
While RS.EOF = False
    strXML = strXML & _
            "   <" & strChild & ">" & vbCrLf
                For Each varItem In RS.Fields
                    strXML = strXML & "      <" & varItem.Name & ">" & Nz(varItem.Value, "-") & "</" & varItem.Name & ">" & vbCrLf
                Next varItem
            strXML = strXML & "   </" & strChild & ">" & vbCrLf
    RS.MoveNext
Wend

'next we add the root closing tag
strXML = strXML & "</" & strRoot & ">"

'As Firefox doesn't seem to like the '&' character within element values, and some of my data contains '&', I've added a string replace. comment this out if it is not necessary
strXML = Replace(strXML, "&", "and")
XML = strXML

'close connection and clear object variables
Connection.Close
Set Connection = Nothing
Set RS = Nothing

Exit_XML:
    Exit Function
Err_XML:
    MsgBox "Function XML Error # " & Err.Number & " - " & Err.Description
    Resume Exit_XML
End Function

cont'd.....
 

Bogzla

Registered User.
Local time
Today, 19:03
Joined
May 30, 2006
Messages
55
code to create XSL stylesheet...
Code:
Public Function XSL(strSQL As String, strRoot As String, strChild As String) As String
 On Error GoTo Err_XSL
'18/08/2006 R.Stevens
'This function will take an SQL string and use it to create an XSL stylesheet to go with an XML file created by the XML function using the same SQL string
'Function uses ADO so set reference to 'Microsoft ActiveX Data Object Library' in Tools > References

Dim strXSL As String
Dim varItem As Variant
Dim RS As ADODB.Recordset
Dim Connection As ADODB.Connection

Set RS = New ADODB.Recordset
Set Connection = Application.CurrentProject.Connection

'Open Recordset using SQL statement and connection defined above
RS.Open strSQL, Connection, adOpenStatic

'Build XSL code, using For Each loops to go through recordset fields and grab their names. I have used the <pre> tag to ensure table columns will be the entire width of the longest text.
'This may be ommited if desired, but the table may end up looking somewhat crushed if there are many columns
strXSL = "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbCrLf & _
            "<xsl:stylesheet version='1.0' xmlns:xsl='http://www.w3.org/1999/XSL/Transform'>" & vbCrLf & _
            "<xsl:template match='/'>" & vbCrLf & _
            "   <html>" & vbCrLf & _
            "   <body>" & vbCrLf & _
            "       <table border='1'>" & vbCrLf & _
            "       <tr bgcolor='#777799'>" & vbCrLf
For Each varItem In RS.Fields
    strXSL = strXSL & _
            "           <th align='center'>" & varItem.Name & "</th>" & vbCrLf
Next
strXSL = strXSL & _
            "       </tr>" & vbCrLf & _
            "       <xsl:for-each select='" & strRoot & "/" & strChild & "'>" & vbCrLf & _
            "       <tr>" & vbCrLf
For Each varItem In RS.Fields
    strXSL = strXSL & _
            "           <td align='center'><pre><xsl:value-of select='" & varItem.Name & "' /></pre></td>" & vbCrLf
Next
strXSL = strXSL & _
            "       </tr>" & vbCrLf & _
            "       </xsl:for-each>" & vbCrLf & _
            "       </table>" & vbCrLf & _
            "   </body>" & vbCrLf & _
            "   </html>" & vbCrLf & _
            "</xsl:template>" & vbCrLf & _
            "</xsl:stylesheet>"
            
XSL = strXSL

'close connection and clear object variables
Connection.Close
Set Connection = Nothing
Set RS = Nothing

Exit_XSL:
    Exit Function
Err_XSL:
    MsgBox "XSL Error # " & Err.Number & " - " & Err.Description
    Resume Exit_XSL
End Function

Now for an example - from Quotes.mdb that I will attach...

query:
Code:
SELECT tblQuotes.Quote, tblQuotes.Author, tblQuotes.Lived 
FROM tblQuotes;
File Name: Quotes
Root Tag Name: Quotes
Child Tag Name: Quote
(note that the code will work even if root / child tag names are the same, but this is probably bad practice)

XML output (C:\test\Quotes.xml)
Code:
<?xml version='1.0' encoding='ISO-8859-1'?>
<?xml-stylesheet type='text/xsl' href='Quotes.xsl'?>
<Quotes>
   <Quote>
      <Quote>And if the blind lead the blind, both shall fall into the ditch.</Quote>
      <Author>Bible, Matthew xv. 14.</Author>
      <Lived>-</Lived>
   </Quote>
   <Quote>
      <Quote>Only two things are infinite, the universe and human stupidity, and I'm not sure about the former.</Quote>
      <Author>Albert Einstein</Author>
      <Lived>(1879 - 1955)</Lived>
   </Quote>
   <Quote>
      <Quote>Talk sense to a fool and he calls you foolish.</Quote>
      <Author>Euripides</Author>
      <Lived>(484 BC - 406 BC)</Lived>
   </Quote>
   <Quote>
      <Quote>There is nothing worse than aggressive stupidity.</Quote>
      <Author>Johann Wolfgang von Goethe</Author>
      <Lived>(1749 - 1832)</Lived>
   </Quote>
   <Quote>
      <Quote>Artificial Intelligence is no match for natural stupidity.</Quote>
      <Author>Unknown</Author>
      <Lived>-</Lived>
   </Quote>
</Quotes>

XSL output (C:\test\Quotes.xsl)
Code:
<?xml version='1.0' encoding='ISO-8859-1'?>
<xsl:stylesheet version='1.0' xmlns:xsl='http://www.w3.org/1999/XSL/Transform'>
<xsl:template match='/'>
   <html>
   <body>
       <table border='1'>
       <tr bgcolor='#777799'>
           <th align='center'>Quote</th>
           <th align='center'>Author</th>
           <th align='center'>Lived</th>
       </tr>
       <xsl:for-each select='Quotes/Quote'>
       <tr>
           <td align='center'><pre><xsl:value-of select='Quote' /></pre></td>
           <td align='center'><pre><xsl:value-of select='Author' /></pre></td>
           <td align='center'><pre><xsl:value-of select='Lived' /></pre></td>
       </tr>
       </xsl:for-each>
       </table>
   </body>
   </html>
</xsl:template>
</xsl:stylesheet>

and attached should be a jpeg of how Quotes.xml looks in firefox and the quotes.mdb example db.
Hope that this may be of some use to someone and that it is not too confusing

with thanks to these forums - could never have figured this out without a number of the posts here to guide me in ADO and FSO
 

Attachments

  • quotesTable.JPG
    quotesTable.JPG
    70.9 KB · Views: 1,134
  • quotes.zip
    51.1 KB · Views: 1,243
Status
Not open for further replies.

Users who are viewing this thread

Top Bottom