Re: ADO GetRows array to XML?

rgutter_at_bctf.ca
Date: 02/22/05 

Date: 21 Feb 2005 18:01:13 -0800

Sure. This sub accepts the original Recordset, extracts the required
number of records and creates the XML file. The sub is meant to be
called iteratively, with varBookmark set to Null for the inital call.

Private Sub CreateXMLForPage(Rs As Recordset, _
    intCurrentPage As Integer, _
    intRecordsPerPage As Integer, _
    varBookmark As Variant, _
    strTargetXML As String)

    Dim varRecord As Variant
    Dim RsForXML As ADODB.Recordset
    Dim strName As String
    Dim intCols As Integer
    Dim intRows As Integer
    Dim i As Integer
    Dim j As Integer

    On Error Goto 0 'replace w/ error handler

    If Rs.RecordCount = 0 Or Rs.EOF Then Exit Sub

    If IsNull(varBookmark) Then Rs.MoveFirst 'first pass

    On Error Resume Next 'to catch eof for final page if not full
    varRecord = Rs.GetRows(intRecordsPerPage)
    Err.Clear
    On Error Goto 0 'replace w/ error handler

    intCols = UBound(varRecord, 1) + 1
    intRows = UBound(varRecord, 2) + 1

    'Set the bookmark for the next pass
    'not sure if Rs.Bookmark is valid at EOF, so do it explicitly:
    If Rs.EOF Then varBookmark = Rs.EOF Else varBookmark = Rs.Bookmark

    'Now construct the new recordset
    Set RsForXML = New ADODB.Recordset

    For j = 0 To intCols - 1 'create ecah column
        'For some reason, copying Attributes isn't working,
        'so just set it as updatable:
        RsForXML.Fields.Append Rs.Fields(j).Name, Rs.Fields(j).Type, _
                      Rs.Fields(j).DefinedSize, adFldUpdatable
        'Remember to set scale & precision for numeric fields!
        If RsForXML.Fields(j).Type = adNumeric Then
            RsForXML.Fields(j).NumericScale = Rs.Fields(j).NumericScale
            RsForXML.Fields(j).Precision = Rs.Fields(j).Precision
        End If
        'Again, because just copying the attributes isn't working,
        'explicitly set the nullable attribute
        If (Rs.Fields(j).Attributes And adFldIsNullable) = _
            adFldIsNullable Then
               RsForXML.Fields(j).Attributes = _
                  RsForXML.Fields(j).Attributes Or adFldIsNullable
        End If
        If (Rs.Fields(j).Attributes And adFldMayBeNull) = _
            adFldMayBeNull Then
               RsForXML.Fields(j).Attributes = _
                  RsForXML.Fields(j).Attributes Or adFldMayBeNull
        End If
    Next j

    'Now fill the recordset from the array
    'Two catches here:
    '(1) We should be able to fill 2 arrays and just do a
    'single RsForXML.AddNew but it's failing
    '(maybe related to the 2nd catch), so we build it field by field
    '(2) For some reason, as soon as we open the Recordset the fields'
    'Attributes are reset! This means we can't assign null values.
    'Still researching...

    RsForXML.Open
    For i = 0 To intRows - 1
        'since we cannot get AddNew via array to work:
        RsForXML.AddNew
        For j = 0 To intCols - 1
            RsForXML.Fields(j) = varRecord(j, i)
        Next j
    Next i

    RsForXML.UpdateBatch 'not really needed?

    'Now create the XML file
    On Error Resume Next
    Kill strTargetXML
    Err.Clear
    On Error Goto 0 'replace w/ error handler

    RsForXML.Save strTargetXML, adPersistXML

    RsForXML.Close
    Set RsForXML = Nothing

    On Error GoTo 0
    Exit Sub

Relevant Pages