Also from StackOverflow an interesting tip arose concerning the ability to populate an ADO recordset with the Xml persisted contents of a block of cells. The sample code however did not work in that the recordset did not understand the column names, what was required was some manipulation of the Xml schema in between. Here is some code
Option Explicit
Option Private Module
Const mlDATASHEET As Long = 1
Private Sub SetUpTestData_RunOnce()
Dim vTestData As Variant
vTestData = [{"FirstName","FamilyName","Role";"John","Snow","President";"Ygritte","Wild","Vice-President"}]
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(mlDATASHEET).Cells(1, 1).Resize(UBound(vTestData, 1), UBound(vTestData, 2))
rng.Value = vTestData
End Sub
Private Sub Test_RunMany()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(mlDATASHEET).Cells(1, 1).CurrentRegion
Dim sDataAsXml As String
sDataAsXml = rng.Value(xlRangeValueMSPersistXML)
'*DEBUG VBA.CreateObject("Scripting.FileSystemObject").CreateTextFile("c:\temp\xl_persist.xml").Write sDataAsXml
'Tools->References:Microsoft ActiveX Data Object 6.1 Library
Dim rs As ADODB.Recordset
'Tools->References:Microsoft Xml, v6.0
Dim domXlPersist As MSXML2.DOMDocument60
Set domXlPersist = New MSXML2.DOMDocument60
domXlPersist.setProperty "SelectionLanguage", "XPath"
domXlPersist.setProperty "SelectionNamespaces", "xmlns:x='urn:schemas-microsoft-com:office:excel'" & _
" xmlns:dt='uuid:C2F41010-65B3-11d1-A29F-00AA00C14882' " & _
" xmlns:s='uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882' " & _
" xmlns:rs='urn:schemas-microsoft-com:rowset' xmlns:z='#RowsetSchema'"
domXlPersist.LoadXML sDataAsXml
Dim attrTypeLoop As MSXML2.IXMLDOMNodeList
Set attrTypeLoop = domXlPersist.SelectNodes("xml/x:PivotCache/s:Schema/s:AttributeType")
Dim xmlFirstDataRow As MSXML2.IXMLDOMElement
Set xmlFirstDataRow = domXlPersist.SelectSingleNode("xml/x:PivotCache/rs:data/z:row[1]")
Dim attrColLoop As MSXML2.IXMLDOMAttribute, lLoop As Long
For Each attrColLoop In xmlFirstDataRow.Attributes
Dim attrType As MSXML2.IXMLDOMElement
Set attrType = attrTypeLoop.Item(lLoop)
Call attrType.setAttribute("rs:name", attrColLoop.Value)
lLoop = lLoop + 1
Next attrColLoop
xmlFirstDataRow.ParentNode.RemoveChild xmlFirstDataRow
Set xmlFirstDataRow = Nothing
'*DEBUG VBA.CreateObject("Scripting.FileSystemObject").CreateTextFile("c:\temp\xl_persist_2.xml").Write domXlPersist.XML
'STOP
Set rs = New ADODB.Recordset
rs.Open domXlPersist
'Stop
Debug.Assert rs.Fields.Count = 3
Debug.Assert rs.Fields.Item(0).Name = "FirstName"
Debug.Assert rs.Fields.Item(1).Name = "FamilyName"
Debug.Assert rs.Fields.Item(2).Name = "Role"
Debug.Assert rs.RecordCount = 2
rs.Filter = "FirstName='John'"
Debug.Assert rs.RecordCount = 1
Stop
End Sub
If you uncomment the debug line then you'll write an interim xml file, if you're interested in the contents here they are
<xml xmlns:x="urn:schemas-microsoft-com:office:excel"
xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882"
xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882"
xmlns:rs="urn:schemas-microsoft-com:rowset"
xmlns:z="#RowsetSchema">
<x:PivotCache>
<x:CacheIndex>1</x:CacheIndex>
<s:Schema id="RowsetSchema">
<s:ElementType name="row" content="eltOnly">
<s:attribute type="Col1"/>
<s:attribute type="Col2"/>
<s:attribute type="Col3"/>
<s:extends type="rs:rowbase"/>
</s:ElementType>
<s:AttributeType name="Col1" rs:name="FirstName">
<s:datatype dt:maxLength="255"/>
</s:AttributeType>
<s:AttributeType name="Col2" rs:name="FamilyName">
<s:datatype dt:maxLength="255"/>
</s:AttributeType>
<s:AttributeType name="Col3" rs:name="Role">
<s:datatype dt:maxLength="255"/>
</s:AttributeType>
</s:Schema>
<rs:data>
<z:row Col1="John" Col2="Snow" Col3="President"/>
<z:row Col1="Ygritte" Col2="Wild" Col3="Vice-President"/>
</rs:data>
</x:PivotCache>
</xml>
So actually this is some useful code for rustling up a sample recordset.
No comments:
Post a Comment