how to use access VBA to store SQL output as XML - ms-access

Question

My apologies for the description, I have no idea how to name it properly
I have a few stored procedures (running on SQL2000) that provide me XML data as output. This all works fine and as expected, and I am using a VB module within my DTS to export and store the data. The reduced version of this file is as follows
set objStream = CreateObject( "ADODB.Stream" )
set objXML = CreateObject( "MSXML2.DOMDocument" )
set objConn = CreateObject( "ADODB.Connection" )
objConn.ConnectionTimeout = 3600
objConn.CommandTimeOut = 0
ObjConn.open(DTSGlobalVariables("ConnStringConso").Value)
set objComm = CreateObject( "ADODB.Command" )
objComm.ActiveConnection = objConn
objComm.CommandType = adCmdStoredProc
'Create the Stream object
set objStream = CreateObject( "ADODB.Stream" )
objStream.Open
objComm.Properties( "Output Stream" ) = objStream
' Execute the command
objComm.CommandText = "my_stored_procedure"
objComm.CommandTimeout = 3600
objComm.Execute ,, adExecuteStream
' Read the info returned adding the header and footer info
objStream.Position = 0
objXML.LoadXML("<?xml version='1.0'?>" & objStream.ReadText)
' Create the output XML file
xmlfile = filePath & "myfile.xml"
objXML.save( xmlfile )
So basically what this does is call the procedure, store the output in a stream and save the file, fairly straightforward and up till here no issue.
However, I would also need to be able to do this from my access front end, with VBA. So calling the procedure, wrapping the content and saving it as an XML file. Unfortunately my VBA knowledge is a bit rusty...
This is what I currently have :
Dim cnn As ADODB.Connection
Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.ConnectionString = "DRIVER=SQL Server;SERVER=myserver;DATABASE=myDatabase;uid=myID;pwd=myPW;Trusted_Connection=Yes"
cnn.Open cnn.ConnectionString
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandType = adCmdStoredProc
.CommandText = "my_stored_procedure"
End With
rs.CursorType = adOpenStatic
rs.CursorLocation = adUseClient
rs.LockType = adLockOptimistic
rs.Open cmd
Debug.Print rs(0)
so far so good, I can open the procedure, I get data returned, but that's where my luck ends. The returned data seems to be limited to a certain number of characters (around 2000) and I'm struggling to save it as I want.
I tried below for quick and dirty test, but it appears to screw up my XML (all my attributes are suddenly double-double quoted) and as stated only a part of the content is exported, so any advice on how to do it properly would be highly appreciated
Dim myFile As String
myFile = "d:\output.xml"
Open myFile For Output As #1
Write #1, rs(0)
Close #1

Answer 1

Never mind, I found it myself in the meantime. I had 2 issues, the VBA ADODB works different as the VB variant, and as I was using FOR XML on my SQL Query the output apperantly was chopped in different rows. Hence why I only had partial output. Fiddling a bit with the streaming part in VBA and going through all records made it work. Not too sure this is the most optimal way so if there are ways to improve I'd be interested to know.
Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
cnn.ConnectionString = "DRIVER=SQL Server;SERVER=myServer;DATABASE=myDB;uid=myID;pwd=myPW;Trusted_Connection=Yes"
cnn.Open cnn.ConnectionString
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandType = adCmdStoredProc
.CommandText = myProc
End With
rs.CursorType = adOpenStatic
rs.CursorLocation = adUseClient
rs.LockType = adLockOptimistic
rs.Open cmd
Dim myXML As Variant
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
myXML = myXML & rs.Fields(0)
rs.MoveNext
Loop
End If
'Create the Stream object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2 'Text
.Charset = "utf-8"
.Open
.WriteText myXML
.SaveToFile (filePath & myXMLFile)
.Close
End With