Attribute VB_Name = "SOAPDSTORS"
Option Explicit

Public Function XMLDataSettoRecordset( _
   ByVal XMLDOM_DOC As DOMDocument40, _
   ByVal vsTableName As String) As ADODB.Recordset
   
   'Object to help parse XML Doc
   Dim XML_TableNode As IXMLDOMNode
   Dim XML_RecordNode As IXMLDOMNode
   Dim XML_FieldsNode As IXMLDOMNode
   Dim XML_DataList As IXMLDOMNodeList
   
   'Recordset object to build
   Dim RSFromDS As ADODB.Recordset
   
   'Control Variable
   Dim strXPath As String
   Dim dataLength As Long

   'Create record set object
   Set RSFromDS = New ADODB.Recordset
   
   '----------------------------------------------
   'First build the Column Names
   '----------------------------------------------

   'Set the Xpath parse string
   strXPath = "//xs:element[@name=""" & vsTableName & """]/xs:complexType/xs:sequence"
   
   'Get XML Table Node
   Set XML_TableNode = XMLDOM_DOC.selectSingleNode(strXPath)
      
   'Get all fields in Node
   For Each XML_FieldsNode In XML_TableNode.childNodes

      'Procces only those with attributes
      If Not XML_FieldsNode.Attributes Is Nothing Then
         'Initialize Maximum Length
         dataLength = 0
         
         'We only need to specifiy a length for string or char data
         'Note Second atrribute (1) specify Data type
         If XML_FieldsNode.Attributes(1).Text = "xs:string" Then
            'Find all records of current field
          
            'Use first attribute (0), which should be Name of field
            strXPath = "//" & vsTableName & "/" & _
              XML_FieldsNode.Attributes(0).Text
            
            'Get data from DOM object
            Set XML_DataList = XMLDOM_DOC.selectNodes(strXPath)
          
            'Go through all records to find maximum length
            For Each XML_RecordNode In XML_DataList
               If Len(XML_RecordNode.Text) > dataLength Then
                  dataLength = Len(XML_RecordNode.Text)
               End If
            Next
         End If

         
         On Error Resume Next
         
         'Add field, including data type and field name
         Call RSFromDS.Fields.Append( _
           XML_FieldsNode.Attributes(0).Text, _
           GetDataType(XML_FieldsNode.Attributes(1).Text), _
           dataLength)
         
      End If
   Next


   '----------------------------------------------
   'Now populate RecordSet
   '----------------------------------------------
   
   'Add the data to the empty Recordset
   strXPath = "//" & vsTableName
   Set XML_DataList = XMLDOM_DOC.selectNodes(strXPath)
   
   Call RSFromDS.Open

   'Go through all records
   For Each XML_RecordNode In XML_DataList

      'Add Record
      Call RSFromDS.AddNew
      
      'MsgBox XML_RecordNode.xml
     
      'Go through all fields of current record
      For Each XML_FieldsNode In XML_RecordNode.childNodes
         If Len(XML_FieldsNode.baseName) > 0 Then
            'Set value
            'MsgBox XML_FieldsNode.baseName & ":" & XML_FieldsNode.Text
            RSFromDS.Fields(XML_FieldsNode.baseName) = XML_FieldsNode.Text
         End If
      Next
   Next

   'Set the position to first row
   If Not (RSFromDS.BOF And RSFromDS.EOF) Then Call RSFromDS.MoveFirst
   
   'Return the Recordset
   Set XMLDataSettoRecordset = RSFromDS
   
   
End Function

Private Function GetDataType(ByVal vsType As String) As ADODB.DataTypeEnum
   'Maps the XSD datatype to a ADO datatype
   Select Case vsType
      Case "xs:string"
         GetDataType = adVarChar
      Case "xs:int"
         GetDataType = adInteger
      Case "xs:dateTime"
         GetDataType = adDate
      Case "xs:decimal"
         GetDataType = adDouble
      Case "xs:short"
         GetDataType = adBoolean
      Case "0"
         GetDataType = adVarChar
        
    'Any thing we do not know we keep as string
      Case Else
         GetDataType = adVarChar
    End Select
End Function
