Access bloats with ADODB xml processing (1 Viewer)

dexcelle

Registered User.
Local time
Today, 16:29
Joined
Jan 10, 2013
Messages
14
Hi AWF,

I've read and tried to understand various topics regarding Access bloating on AWF and via Google, yet fail to come to grips on how to deal with it in my particular problem.

Let me explain: a 3rd party programmer has provided a lengthy code to process (even lengthier) xml messages into various Access tables. Each segment can end up in a different table. These messages contain large numbers of records and segments. An average XML has about 3000 records and is sized approx 10mb.
After processing one XML file, the Access database has increased approx....400mb! (imagine trying to process 5xmls)
Certainly there's the option of autocompacting but I want to avoid the bloat rather than fixing it afterwards.

If read about using different recordsets (ie DAO instead of ADODB) but haven't got any real confirmation if this is the real solution.

Therefore my question: what should be coded differently to avoid the bloating??


This is the code (sorry for the length, I've already shortened it by removing simialer code-pieces for similar xml segments):

Code:
Public Function OnixImport()
    Dim mn As MSXML2.DOMDocument60, xmlist As MSXML2.IXMLDOMNodeList
    Dim Node2 As MSXML2.IXMLDOMNode
    Dim Node1 As MSXML2.IXMLDOMNode
    Dim varRecordReference, varCollectionType, varColTitleType, varFeatureType, varTextType, varTitleID, varPriceID, varIDRelatedProducts, varIDPartOfCollection, varIDSupportingResource, varTitleType, varRFType, VarUpdated
    Dim xDoc As MSXML2.DOMDocument60
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rstMeasure As New ADODB.Recordset
    Dim rstTitle As New ADODB.Recordset
    Dim rstTitleElement As New ADODB.Recordset
    Dim rstPartOfCollection As New ADODB.Recordset
    Dim rstTitleDetail As New ADODB.Recordset
    Dim rstContributor As New ADODB.Recordset
    Dim rstTextContent As New ADODB.Recordset
    Dim rstSupportingResource As New ADODB.Recordset
    Dim rstXMLMessageHeaders As New ADODB.Recordset
    Dim rstProductPart As New ADODB.Recordset
    Dim rstEpubTechnicalProtection As New ADODB.Recordset
    Dim rstProductClassification  As New ADODB.Recordset
    Dim rstSubject  As New ADODB.Recordset
    Dim rstImprint  As New ADODB.Recordset
    Dim rstPrice  As New ADODB.Recordset
    Dim rstSalesRestriction As New ADODB.Recordset
    Dim rstProductAvailability As New ADODB.Recordset
    Dim rstSupplyDetail As New ADODB.Recordset
    Dim rstRelatedProducts As New ADODB.Recordset
    Dim rstProductIdentifier As New ADODB.Recordset
    Dim rstCitedContent As New ADODB.Recordset
    Dim rstLanguage As New ADODB.Recordset
    Dim rstResourcesFeature As New ADODB.Recordset
    Dim rstTax As New ADODB.Recordset
 
    Set cnn = CurrentProject.Connection
 
    rst.Open "SELECT * FROM tblProducts", cnn, adOpenDynamic, adLockOptimistic
    rstMeasure.Open "SELECT * FROM tblMeasure", cnn, adOpenDynamic, adLockOptimistic
    rstTitle.Open "SELECT * FROM tblTitle", cnn, adOpenDynamic, adLockOptimistic
    rstTitleElement.Open "SELECT * FROM tblTitleElement", cnn, adOpenDynamic, adLockOptimistic
    rstPartOfCollection.Open "SELECT * FROM tblPartOfCollection", cnn, adOpenDynamic, adLockOptimistic
    rstTitleDetail.Open "SELECT * FROM tblTitleDetail", cnn, adOpenDynamic, adLockOptimistic
    rstContributor.Open "SELECT * FROM tblContributor", cnn, adOpenDynamic, adLockOptimistic
    rstTextContent.Open "SELECT * FROM tblTextContent", cnn, adOpenDynamic, adLockOptimistic
    rstSupportingResource.Open "SELECT * FROM tblSupportingResource", cnn, adOpenDynamic, adLockOptimistic
    rstXMLMessageHeaders.Open "SELECT * FROM tblXMLMessageHeaders", cnn, adOpenDynamic, adLockOptimistic
    rstProductPart.Open "SELECT * FROM tblProductPart", cnn, adOpenDynamic, adLockOptimistic
    rstEpubTechnicalProtection.Open "SELECT * FROM tblEpubTechnicalProtection", cnn, adOpenDynamic, adLockOptimistic
    rstProductClassification.Open "SELECT * FROM tblProductClassification", cnn, adOpenDynamic, adLockOptimistic
    rstSubject.Open "SELECT * FROM tblSubject", cnn, adOpenDynamic, adLockOptimistic
    rstImprint.Open "SELECT * FROM tblImprint", cnn, adOpenDynamic, adLockOptimistic
    rstPrice.Open "SELECT * FROM tblPrice", cnn, adOpenDynamic, adLockOptimistic
    rstSalesRestriction.Open "SELECT * FROM tblSalesRestriction", cnn, adOpenDynamic, adLockOptimistic
    rstProductAvailability.Open "SELECT * FROM tblProductAvailability", cnn, adOpenDynamic, adLockOptimistic
    rstSupplyDetail.Open "SELECT * FROM tblSupplyDetail", cnn, adOpenDynamic, adLockOptimistic
    rstRelatedProducts.Open "SELECT * FROM tblRelatedProducts", cnn, adOpenDynamic, adLockOptimistic
    rstProductIdentifier.Open "SELECT * FROM tblProductIdentifier", cnn, adOpenDynamic, adLockOptimistic
    rstCitedContent.Open "SELECT * FROM tblCitedContent", cnn, adOpenDynamic, adLockOptimistic
    rstLanguage.Open "SELECT * FROM tblLanguage", cnn, adOpenDynamic, adLockOptimistic
    rstResourcesFeature.Open "SELECT * FROM tblResourcesFeature", cnn, adOpenDynamic, adLockOptimistic
    rstTax.Open "SELECT * FROM tblTax", cnn, adOpenDynamic, adLockOptimistic
 
 
    Set xDoc = New MSXML2.DOMDocument60
    xDoc.Load ("C:\TRIPS\Home\OnixImport\Processing\OnixImport.xml")
 
   Set xmlist = xDoc.getElementsByTagName("*")
   For Each Node1 In xmlist
        For Each Node2 In Node1.childNodes
            If Node2.nodeType = NODE_TEXT Then
                'rstXMLMessageHeaders
                If Node1.nodeName = "SenderIDType" And Node1.parentNode.nodeName = "SenderIdentifier" Then
                    rstXMLMessageHeaders.AddNew
                    rstXMLMessageHeaders!SenderIDType = Node1.Text
                End If
 
                If Node1.nodeName = "IDValue" And Node1.parentNode.nodeName = "SenderIdentifier" Then rstXMLMessageHeaders!IDValue = Node1.Text
                If Node1.nodeName = "SenderName" And Node1.parentNode.nodeName = "Sender" Then rstXMLMessageHeaders!SenderName = Node1.Text
                If Node1.nodeName = "ContactName" And Node1.parentNode.nodeName = "Sender" Then rstXMLMessageHeaders!ContactName = Node1.Text
                If Node1.nodeName = "EmailAddress" And Node1.parentNode.nodeName = "Sender" Then rstXMLMessageHeaders!EmailAddress = Node1.Text
                If Node1.nodeName = "MessageNumber" And Node1.parentNode.nodeName = "Header" Then rstXMLMessageHeaders!MessageNumber = Node1.Text
                If Node1.nodeName = "SentDateTime" And Node1.parentNode.nodeName = "Header" Then rstXMLMessageHeaders!SentDateTime = Node1.Text
                '/rstXMLMessageHeaders
 
                'Block 0
                If Node1.nodeName = "RecordReference" And Node1.parentNode.nodeName = "Product" Then
                    rst.AddNew
                    rst!Product_RecordReference = Node1.Text
                    varRecordReference = Node1.Text
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
 
                If Node1.nodeName = "NotificationType" And Node1.parentNode.nodeName = "Product" Then rst!Product_NotificationType = Node1.Text
                If Node1.nodeName = "ProductIDType" And Node1.parentNode.nodeName = "ProductIdentifier" Then rst!ProductIdentifier_ProductIDType = Node1.Text
                If Node1.nodeName = "IDValue" And Node1.parentNode.nodeName = "ProductIdentifier" Then rst!ProductIdentifier_IDValue = Node1.Text
                '/Block 0
 
                    'ProductForm
                If Node1.nodeName = "ProductComposition" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_ProductComposition = Node1.Text
                If Node1.nodeName = "ProductForm" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_ProductForm = Node1.Text
                If Node1.nodeName = "ProductFormDetail" Then rst!ProductFormDetail = Node1.Text
                If Node1.nodeName = "ProductFormdescription" Then rst!ProductFormdescription = Node1.Text
                If Node1.nodeName = "EpubtechnicalProtection" Then rst!EpubtechnicalProtection = Node1.Text
 
 
                ''ProductPart
                If Node1.nodeName = "ProductIDType" And Node1.parentNode.nodeName = "ProductIdentifier" Then
                    rstProductPart.AddNew
                    rstProductPart!ProductIdentifier_ProductIDType = Node1.Text
                    rstProductPart!Product_RecordReference = varRecordReference
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
 
                If Node1.nodeName = "IDValue" And Node1.parentNode.nodeName = "ProductIdentifier" Then rstProductPart!ProductIdentifier_IDValue = Node1.Text
                If Node1.nodeName = "ProductForm" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rstProductPart!DescriptiveDetail_ProductForm = Node1.Text
                If Node1.nodeName = "ProductFormDetail" Then rstProductPart!ProductFormDetail = Node1.Text
                If Node1.nodeName = "NumberOfItemsOfThisForm" Then rstProductPart!NumberOfItemsOfThisForm = Node1.Text
                ''/ProductPart
                '/ProductForm
 
 
                ''SupportingResource
                If Node1.nodeName = "ResourceContentType" And Node1.parentNode.nodeName = "SupportingResource" Then
                    rstSupportingResource.AddNew
                    rstSupportingResource!SupportingResource_ResourceContentType = Node1.Text
                    varRFType = rstSupportingResource!SupportingResource_ResourceContentType
                    rstSupportingResource!Product_RecordReference = varRecordReference
                    rstSupportingResource.Update
                    varIDSupportingResource = rstSupportingResource!IDSupportingResource
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "ContentAudience" And Node1.parentNode.nodeName = "SupportingResource" Then _
                    rstSupportingResource!SupportingResource_ContentAudience = Node1.Text
                If Node1.nodeName = "ResourceMode" And Node1.parentNode.nodeName = "SupportingResource" Then _
                    rstSupportingResource!SupportingResource_ResourceMode = Node1.Text
                If Node1.nodeName = "ResourceForm" And Node1.parentNode.nodeName = "ResourceVersion" Then _
                    rstSupportingResource!ResourceVersion_ResourceForm = Node1.Text
 
 
                'Measure
                If Node1.nodeName = "MeasureType" And Node1.parentNode.nodeName = "Measure" Then
                    rstMeasure.AddNew
                    rstMeasure!Measure_MeasureType = Node1.Text
                    rstMeasure!Product_RecordReference = varRecordReference
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "Measurement" And Node1.parentNode.nodeName = "Measure" Then rstMeasure!Measure_Measurement = Node1.Text
                If Node1.nodeName = "MeasureUnitCode" And Node1.parentNode.nodeName = "Measure" Then rstMeasure!Measure_MeasureUnitCode = Node1.Text
                '/Measure
 
                'Edition
                If Node1.nodeName = "EditionNumber" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_EditionNumber = Node1.Text
                If Node1.nodeName = "EditionVersionNumber" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_EditionVersionNumber = Node1.Text
                If Node1.nodeName = "EditionStatement" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_EditionStatement = Node1.Text
                '/Edition
 
                'Language
                If Node1.nodeName = "LanguageRole" And Node1.parentNode.nodeName = "Language" Then
                    rstLanguage.AddNew
                    rstLanguage!Product_RecordReference = varRecordReference
                    rstLanguage!Language_LanguageRole = Node1.Text
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "LanguageCode" And Node1.parentNode.nodeName = "Language" Then rstLanguage!Language_LanguageCode = Node1.Text
                '/Language
 
                'Extent
                If Node1.nodeName = "ExtentType" And Node1.parentNode.nodeName = "Extent" Then rst!Extent_ExtentType = Node1.Text
                If Node1.nodeName = "ExtentValue" And Node1.parentNode.nodeName = "Extent" Then rst!Extent_ExtentValue = Node1.Text
                If Node1.nodeName = "ExtentValueRoman" And Node1.parentNode.nodeName = "Extent" Then rst!Extent_ExtentValueRoman = Node1.Text
                If Node1.nodeName = "ExtentUnit" And Node1.parentNode.nodeName = "Extent" Then rst!Extent_ExtentUnit = Node1.Text
                If Node1.nodeName = "Illustrated" And Node1.parentNode.nodeName = "DescriptiveDetail" Then rst!DescriptiveDetail_Illustrated = Node1.Text
                '/Extent
 
 
                'RelatedProducts
                If Node1.nodeName = "ProductRelationCode" And Node1.parentNode.nodeName = "RelatedProduct" Then
                    rstRelatedProducts.AddNew
                    rstRelatedProducts!Product_RecordReference = varIDRelatedProducts
                    rstRelatedProducts!ProductRelationCode = Node1.Text
                    rstRelatedProducts.Update
                    varIDRelatedProducts = rstRelatedProducts!IDRelatedProducts
                    rstRelatedProducts!Product_RecordReference2 = varRecordReference
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                '/RelatedProducts
 
                'ProductIdentifier
                If Node1.nodeName = "ProductIDType" And Node1.parentNode.nodeName = "ProductIdentifier" Then
                    rstProductIdentifier.AddNew
                    rstProductIdentifier!IDRelatedProducts = varIDRelatedProducts
                    rstProductIdentifier!ProductIdentifier_ProductIDType = Node1.Text
                    rstProductIdentifier!Product_RecordReference = varRecordReference
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "IDValue" And Node1.parentNode.nodeName = "ProductIdentifier" Then rstProductIdentifier!ProductIdentifier_IDValue = Node1.Text
                '/ProductIdentifier
 
                'ProductAvailability
                If Node1.nodeName = "SupplyDateRole" And Node1.parentNode.nodeName = "SupplyDate" Then
                    rstProductAvailability.AddNew
                    rstProductAvailability!Product_RecordReference = varRecordReference
                    rstProductAvailability!SupplyDate_SupplyDateRole = Node1.Text
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "Date" And Node1.parentNode.nodeName = "SupplyDate" Then rstProductAvailability!SupplyDate_Date = Node1.Text
                If Node1.nodeName = "OrderTime" And Node1.parentNode.nodeName = "SupplyDetail" Then rstProductAvailability!SupplyDetail_OrderTime = Node1.Text
                '/ProductAvailability
 
                'SalesRestriction
                If Node1.nodeName = "SalesRestrictionType" And Node1.parentNode.nodeName = "SalesRestriction" Then
                    rstSalesRestriction.AddNew
                    rstSalesRestriction!Product_RecordReference = varRecordReference
                    rstSalesRestriction!SalesRestrictionType = Node1.Text
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                '/SalesRestriction
 
                'Price
                If Node1.nodeName = "PriceType" And Node1.parentNode.nodeName = "Price" Then
                    rstPrice.AddNew
                    rstPrice!Product_RecordReference = varRecordReference
                    rstPrice!Price_PriceType = Node1.Text
                    rstPrice.Update
                    varPriceID = rstPrice!IDPrice
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
 
                If Node1.nodeName = "UnpricedItemType" Then rstPrice!UnpricedItemType = Node1.Text
                If Node1.nodeName = "PriceQualifier" And Node1.parentNode.nodeName = "Price" Then rstPrice!Price_PriceQualifier = Node1.Text
                If Node1.nodeName = "PriceTypeDescription" And Node1.parentNode.nodeName = "Price" Then rstPrice!Price_PriceTypeDescription = Node1.Text
 
                If Node1.nodeName = "DiscountCodeType" And Node1.parentNode.nodeName = "DiscountCoded" Then rstPrice!DiscountCoded_DiscountCodeType = Node1.Text
                If Node1.nodeName = "DiscountCode" And Node1.parentNode.nodeName = "DiscountCoded" Then rstPrice!DiscountCoded_DiscountCode = Node1.Text
                If Node1.nodeName = "PriceAmount" And Node1.parentNode.nodeName = "Price" Then rstPrice!Price_PriceAmount = Node1.Text
                If Node1.nodeName = "CurrencyCode" And Node1.parentNode.nodeName = "Price" Then rstPrice!Price_CurrencyCode = Node1.Text
                If Node1.nodeName = "PriceDateRole" And Node1.parentNode.nodeName = "PriceDate" Then rstPrice!PriceDate_PriceDateRole = Node1.Text
                If Node1.nodeName = "Date" And Node1.parentNode.nodeName = "PriceDate" Then rstPrice!PriceDate_Date = Node1.Text
                '/Price
 
                'Tax
                If Node1.nodeName = "TaxRateCode" And Node1.parentNode.nodeName = "Tax" Then
                    rstTax.AddNew
                    rstTax!IDPrice = varPriceID
                    rstTax!Tax_TaxRateCode = Node1.Text
                    rstTax!Product_RecordReference = varRecordReference
                    VarUpdated = Format(Now(), "YYYYMMDD")
                End If
                If Node1.nodeName = "TaxableAmount" And Node1.parentNode.nodeName = "Tax" Then rstTax!Tax_TaxableAmount = Node1.Text
                If Node1.nodeName = "TaxType" And Node1.parentNode.nodeName = "Tax" Then rstTax!Tax_TaxType = Node1.Text
 
                '/Tax
                'Product - update date bijwerken met VarUpdated
                'rst!UpdateDate = VarUpdated
            End If
        Next Node2
 
      If Not rst.EOF Then rst.Update
      If Not rstMeasure.EOF Then rstMeasure.Update
      If Not rstTitle.EOF Then rstTitle.Update
      If Not rstTitleElement.EOF Then rstTitleElement.Update
      If Not rstPartOfCollection.EOF Then rstPartOfCollection.Update
      If Not rstTitleDetail.EOF Then rstTitleDetail.Update
      If Not rstContributor.EOF Then rstContributor.Update
      If Not rstTextContent.EOF Then rstTextContent.Update
      If Not rstSupportingResource.EOF Then rstSupportingResource.Update
      If Not rstXMLMessageHeaders.EOF Then rstXMLMessageHeaders.Update
      If Not rstProductPart.EOF Then rstProductPart.Update
      If Not rstEpubTechnicalProtection.EOF Then rstEpubTechnicalProtection.Update
      If Not rstSubject.EOF Then rstSubject.Update
      If Not rstImprint.EOF Then rstImprint.Update
      If Not rstPrice.EOF Then rstPrice.Update
      If Not rstSalesRestriction.EOF Then rstSalesRestriction.Update
      If Not rstProductAvailability.EOF Then rstProductAvailability.Update
      If Not rstSupplyDetail.EOF Then rstSupplyDetail.Update
      If Not rstRelatedProducts.EOF Then rstRelatedProducts.Update
      If Not rstProductIdentifier.EOF Then rstProductIdentifier.Update
      If Not rstCitedContent.EOF Then rstCitedContent.Update
      If Not rstLanguage.EOF Then rstLanguage.Update
      If Not rstResourcesFeature.EOF Then rstResourcesFeature.Update
      If Not rstTax.EOF Then rstTax.Update
 
   Next Node1
 
   rst.Close
   rstMeasure.Close
   rstTitle.Close
   rstTitleElement.Close
   rstPartOfCollection.Close
   rstTitleDetail.Close
   rstContributor.Close
   rstTextContent.Close
   rstSupportingResource.Close
   rstXMLMessageHeaders.Close
   rstProductPart.Close
   rstEpubTechnicalProtection.Close
   rstSubject.Close
   rstImprint.Close
   rstPrice.Close
   rstSalesRestriction.Close
   rstProductAvailability.Close
   rstSupplyDetail.Close
   rstRelatedProducts.Close
   rstProductIdentifier.Close
   rstCitedContent.Close
   rstLanguage.Close
   rstResourcesFeature.Close
   rstTax.Close
 
   Set rst = Nothing
   Set rstMeasure = Nothing
   Set rstTitle = Nothing
   Set rstTitleElement = Nothing
   Set rstPartOfCollection = Nothing
   Set rstTitleDetail = Nothing
   Set rstContributor = Nothing
   Set rstTextContent = Nothing
   Set rstSupportingResource = Nothing
   Set rstXMLMessageHeaders = Nothing
   Set rstProductPart = Nothing
   Set rstEpubTechnicalProtection = Nothing
   Set rstSubject = Nothing
   Set rstImprint = Nothing
   Set rstPrice = Nothing
   Set rstSalesRestriction = Nothing
   Set rstProductAvailability = Nothing
   Set rstSupplyDetail = Nothing
   Set rstRelatedProducts = Nothing
   Set rstProductIdentifier = Nothing
   Set rstCitedContent = Nothing
   Set rstLanguage = Nothing
   Set rstResourcesFeature = Nothing
   Set rstTax = Nothing
 
End Function
 
Last edited:

mdlueck

Sr. Application Developer
Local time
Today, 19:29
Joined
Jun 23, 2011
Messages
2,631
'tis just the nature of the Access beast to bloat FE DB filesize.

I have an FE application which cleaned up and decompiled is around 15MB currently.

NT Command Script and Documented Steps to Decompile / Compact / Compile an Access DB
http://www.access-programmers.co.uk/forums/showthread.php?t=219948

I have seen it bloat to between 120MB and 150MB with normal daily use by EOD, at which point I do the above cleanup process after having empties all FE temp tables, and I run another process to cleanup unnecessary objects out of the FE DB.

VBA to Cleanup A2007 DB Extra Objects
http://www.access-programmers.co.uk/forums/showthread.php?t=226466

My code creates all DAO.QueryDef objects on-the-fly, and so on... so in my case that suggested cleanup of extra objects is safe. YMMV, so best try on a BACKUP COPY of your DB the first time.
 

DJkarl

Registered User.
Local time
Today, 18:29
Joined
Mar 16, 2007
Messages
1,028
mdlueck is correct, no way around the bloating beast that is Access. You could use the CreateDatabase command to create a temporary work database, import your data in there, append the final results into the backend, then delete the whole database upon completion.
 

Maineac

New member
Local time
Today, 16:29
Joined
Jan 10, 2013
Messages
5
dexcelle,

I noticed in looking at the code that you are populating many tables an once. I am in the middle of similar project. The xml files I am importing are 19 Mbyte and 30 Mbyte. I just imported the 19 MBtye (24,000 records) using the code listed below and it incrased the database by 5 MByte. You will note that I do a straight import to a single table and then run queries on that table to distribute the records where I want them.

There are also a few functions I wrote to support the particular xml file I am importing.

The point is, while Access is a little sloppy in dealing with deleted objects, it shouldn't bloat up the way you descirbed above.

Code:
Public Sub ImportXML(FileName As String, TableName As String)
  Dim xmlDoc As MSXML2.DOMDocument60
  Dim xmlRoot As MSXML2.IXMLDOMNode
  Dim xmlList As MSXML2.IXMLDOMNodeList
  Dim xmlNode As MSXML2.IXMLDOMNode
  Dim xmlSubNode As MSXML2.IXMLDOMNode
  Dim adoConn As ADODB.Connection
  Dim adoComm As ADODB.Command
  Dim colFlds As Collection
  Dim SQL As String
  Dim sFldName As clsFldInfo
  Dim nodeTxt As String
  Dim iCnt As Integer
  Dim iNode As Long
 
  On Error GoTo ERR_ROUTINE
 
  Set xmlDoc = New MSXML2.DOMDocument60
  xmlDoc.Load (FileName)
 
  If (xmlDoc.childNodes.length > 0) Then
    Set xmlRoot = xmlDoc.childNodes(1)
  Else
    Err.Raise -103, "ImportXML", "Unable to find " & FileName
    Exit Sub
  End If
 
  'Connect to the database
  Set adoConn = CurrentProject.Connection
  Set adoComm = New Command
  adoComm.ActiveConnection = adoConn
  Set colFlds = New Collection
 
  'Create the new table in the database
  SQL = "CREATE TABLE " & TableName & " ("
 
  Set xmlList = xmlDoc.getElementsByTagName(TableName)
  Set xmlNode = xmlList(0)
 
  For Each xmlSubNode In xmlNode.childNodes
    Set sFldName = New clsFldInfo
    sFldName.NodeName = xmlSubNode.NodeName
    sFldName.FieldName = ConvertHTTP(xmlSubNode.NodeName)
    sFldName.FieldType = GetDataType(xmlSubNode.Text)
    colFlds.Add sFldName, sFldName.FieldName
    SQL = SQL & "'" & sFldName.FieldName & "' " & sFldName.FieldType & ", "
    Set sFldName = Nothing
  Next
  SQL = Left(SQL, Len(SQL) - 2) & ")"
 
  adoComm.CommandText = SQL
  adoComm.Execute
 
  'Insert records into table
  iCnt = 0
  adoConn.BeginTrans
  For Each xmlNode In xmlList
    SQL = "INSERT INTO " & TableName & " VALUES ("
 
    For Each sFldName In colFlds
      iNode = 0
      Set xmlSubNode = xmlNode.childNodes(iNode)
 
      Do While (xmlSubNode.NodeName <> sFldName.NodeName)
        Set xmlSubNode = xmlNode.childNodes(iNode)
        If (xmlSubNode Is Nothing) Then
          Exit Do
          Err.Raise -102, "ImportXML", "Bad XML Record"
        End If
        iNode = iNode + 1
      Loop
 
      If (xmlSubNode Is Nothing) Then
        If (sFldName.FieldType = "Text") Then
          nodeTxt = "''"
        ElseIf (sFldName.FieldType = "Double") Then
          nodeTxt = "0.0"
        ElseIf (sFldName.FieldType = "Long") Then
          nodeTxt = "0"
        ElseIf (sFldName.FieldType = "Date/Time") Then
          nodeTxt = "'1/1/2000'"
        Else
          nodeTxt = "''"
        End If
      Else
        If (sFldName.FieldType = "Text") Then
          nodeTxt = "'" & xmlSubNode.Text & "'"
        ElseIf (sFldName.FieldType = "Double") Then
          nodeTxt = xmlSubNode.Text
        ElseIf (sFldName.FieldType = "Long") Then
          nodeTxt = xmlSubNode.Text
        ElseIf (sFldName.FieldType = "Date/Time") Then
          nodeTxt = "'" & xmlSubNode.Text & "'"
        Else
          nodeTxt = "'" & xmlSubNode.Text & "'"
        End If
      End If
 
      SQL = SQL & nodeTxt & ", "
    Next
 
    SQL = Left(SQL, Len(SQL) - 2) & ")"
    adoComm.CommandText = SQL
    adoComm.Execute
 
    iCnt = iCnt + 1
    If (iCnt > 100) Then
      adoConn.CommitTrans
      iCnt = 0
      adoConn.BeginTrans
    End If
  Next
  adoConn.CommitTrans
 
  Set xmlDoc = Nothing
  Set xmlRoot = Nothing
  Set xmlList = Nothing
  Set xmlNode = Nothing
  Set xmlSubNode = Nothing
  Set adoComm = Nothing
  Set adoConn = Nothing
  Set colFlds = Nothing
 
  Exit Sub
ERR_ROUTINE:
  Debug.Print Err.Description
  Stop
  Resume Next
 
End Sub
 

Users who are viewing this thread

Top Bottom