vba - XML解析循环期间访问表更新缓慢 - VBA

Question

在尝试了几件事后，我在这里放弃了一个问题，但不幸的是，如果我在 VBA 循环中调用更新查询，我无法理解为什么 Access 很慢。

我正在制作一个解析器来读取巨大的 XML 文件 - 超过 500MB，但出于测试原因，我创建了 19MB 文件。总记录刚刚超过 16K。我必须经过几个循环（节点/子节点）才能获得 3 个值（托管对象、p_name、p_value）。一旦我有了这些值，我就会更新一个名为“1_RETU_R”的表。不幸的是，访问需要很长时间才能更新表。如果我加载巨大的 xml 文件，我相信它会死。我也尝试过 rs.Field(i) 但速度没有重大改进。

我不认为我在逻辑上做错了什么，但我需要知道是否有更有效的更新记录的方法可以减少时间。如果我从我的代码中完全删除更新功能，那么在 VBA 中会非常快速地读取 XML 文件。, 几乎瞬间

有人可以告诉这里可能是什么问题，有没有更好的方法将记录传输到访问数据表？

Function RETU_R_Update_All(strSQL As String, sDN As String)
    Dim SQLString As String, sWhere As String
    sWhere = " WHERE [DN_Name] = """ & sDN & """;"
    SQLString = "Update 1_RETU_R SET " & strSQL & sWhere
    CurrentDb.Execute SQLString, dbFailOnError
    'DoCmd.RunSQL SQLString
End Function

Sub XMLRead(path As String)
    
    Dim firstNameField As MSXML2.IXMLDOMNodeList
    Dim lists As MSXML2.IXMLDOMNodeList
    Dim raml As MSXML2.IXMLDOMElement
    Dim RETU_R_Fields As Variant
    Dim RETU_R_Values As Variant
    Dim countF As Integer
    Dim Fieldname As String
    Dim MRBTS_arr As Variant
    Dim MRBTS As String
    
    'Creating Database Objects & Opening Connection
    Dim rs As DAO.Recordset
    Dim db As DAO.Database
    Set db = CurrentDb()
    Dim sSql As String
    
    RETU_R_Fields = Get_Fieldnames("RETU_R")
    countF = ArrayLen(RETU_R_Fields)
    Fieldname = RETU_R_Fields(0)
    
    Dim i, j, k As Integer
    'path = "C:\Audit_DB\Input Files\Test_RC2.xml"
    
    
    'Delete all records from Table RETU_R
    DoCmd.RunSQL "Delete * from 1_RETU_R"

    

    Dim ObjXMLDoc As MSXML2.DOMDocument60
    Set ObjXMLDoc = New MSXML2.DOMDocument60

    ObjXMLDoc.async = False
    ObjXMLDoc.SetProperty "SelectionLanguage", "XPath"
    ObjXMLDoc.SetProperty "ProhibitDTD", False
    ObjXMLDoc.resolveExternals = False
    ObjXMLDoc.validateOnParse = False
    ObjXMLDoc.SetProperty "SelectionNamespaces", "xmlns:r='raml20.xsd'"
    ObjXMLDoc.Load (path)
    
    If ObjXMLDoc.parseError.errorCode <> 0 Then
        'MsgBox "ERROR when loading " + strFileName + ": " + ObjXMLDoc.parseError.reason
    Else
        'MsgBox "Loaded Successfully"
    End If
        

    Dim TitleNodes As MSXML2.IXMLDOMNodeList
    Set TitleNodes = ObjXMLDoc.selectNodes("//r:managedObject")
    Dim NodeElement As MSXML2.IXMLDOMElement
    Dim nodeChild As IXMLDOMElement
    Dim mo As String
    Dim DN_Name As String
    Dim p_name As String
    Dim p_value As String
    Dim l_name As String
    Dim node As Variant
    Dim par As Variant
    Dim list As Variant
    Dim itemp As Variant
    


    For Each node In TitleNodes
        sSql = ""
        Form_Audit_DB.Refresh
        mo = node.getAttribute("class")
        If mo = "RETU_R" Then
            Set rs = db.OpenRecordset("1_RETU_R")
            rs.AddNew
            DN_Name = node.getAttribute("distName")
            rs.Fields("DN_Name").Value = DN_Name
            MRBTS_arr = Split(DN_Name, "/")
            MRBTS = MRBTS_arr(1)
            rs.Fields("MRBTS").Value = MRBTS
            rs.Fields("class").Value = mo
            rs.Fields("createDate").Value = Now
            rs.Update
            For Each par In node.childNodes
                If par.baseName = "p" Then
                    p_name = par.getAttribute("name")
                    p_value = par.Text
                End If
                
                If par.baseName = "list" Then
                    l_name = par.getAttribute("name")
                    For Each list In par.childNodes
                        i = 0
                        j = 0
                       
                        p_value = ""
                        Dim itemcount As Integer
                        Dim plenth As Integer
                        itemcount = par.childNodes.length
                        plenth = list.childNodes.length
                        
                        Dim arr_p As Variant
                        Dim arr_v As Variant
                        Dim p_val As Variant
                        ReDim arr_p(plenth - 1) As String
                        ReDim arr_v(itemcount - 1) As String
                        ReDim p_val(plenth - 1) As String
                        ReDim v_val(plenth - 1) As String
                        Dim x, y As Integer
                        x = 0
                        y = 0
                        
                        If list.baseName = "item" Then
                            For i = 0 To itemcount - 1
                                For j = 0 To plenth - 1
                                    arr_p(j) = l_name & "_" & list.childNodes(j).getAttribute("name")
                                        For k = 0 To itemcount - 1
                                            arr_v(k) = par.childNodes(k).childNodes(j).Text
                                        Next
                                        For k = 0 To itemcount - 1
                                            v_val(j) = Join(arr_v, ";")
                                        Next
                                Next
                            Next
                            
                            For i = 0 To plenth - 1
                                p_name = arr_p(i)
                                p_value = v_val(i)
                                If InStr(sSql, p_name) > 0 Then GoTo SKIP_ALREADY_IN
                                sSql = sSql & "," & "[" & p_name & "] = """ & p_value & """"
                            Next
                        Else
                            p_name = l_name
                            p_value = par.Text
                        End If
                    Next
                End If
                
                If InStr(sSql, p_name) > 0 Then GoTo SKIP_ALREADY_IN
                    sSql = sSql & "," & "[" & p_name & "] = """ & p_value & """"
                
    SKIP_ALREADY_IN:
            Next
            sSql = Right(sSql, Len(sSql) - 1)
            Call RETU_R_Update_All(sSql, DN_Name)
            
        End If
        rs.Close
    Next
    
    
'ErrorHandler:
    'MsgBox "Error in loading the XML, please try to compact the database before loading."
    'Exit Sub
    
   

     MsgBox "XML is Loaded Successfully"
     Debug.Print ObjXMLDoc.selectNodes("//r:managedObject").length
    
    
    
End Sub

标签： vbadatabasems-accessxml-parsingdomdocument