导入XML文件到Access数据库与多个表

Question

我有一大堆的（平面）的XML文件，例如：

<?xml version="1.0" encoding="UTF-8"?> 
<SomeName> 
    <UID> 
    ID123 
    </UID> 
    <Node1> 
    DataA 
</Node1> 
<Node2> 
    DataB 
</Node2> 
    <Node3> 
    DataC 
</Node3> 
    <AnotherNode1> 
    DataD 
</AnotherNode1> 
    <AnotherNode2> 
    DataE 
</AnotherNode2> 
    <AnotherNode3> 
    DataF 
</AnotherNode3> 
<SingleNode> 
    DataG 
</SingleNode> 
</SomeName> 

现在我实际的XML文件中有太多的节点，所以他们不能被导入到一个表（由于255列限制），所以我需要将数据分成多个表。我已经手工创建了表，所以现在所有访问都需要将节点名称与每个表中的列进行匹配并复制数据。

它只对一个名为'SomeName'的表执行操作，但不改变所有其他表。

我不确定如何获得将我的XML文件正确导入到所有表中的权限。我也已经尝试在每个表格中创建UID字段并将它们链接起来（因为UID对于每个XML数据集都是唯一的），但是这也使得访问不被显示。

我试图找到关于这个问题的任何信息，但迄今为止一无所获。

我非常感谢任何帮助或指点。

Answer 1

由于您需要超过255个字段，因此您必须使用代码执行此操作。您可以将XML加载到MSXML2.DOMDocument中，收集节点值的子集，构建INSERT语句并执行它。

下面是我根据您的样本数据进行测试的过程。这是非常丑陋的，但它的作品。在修改strTagList,strFieldList,strTable和cintNumTables并查看INSERT语句后，请取消注释CurrentDb.Execute行。如果要加载2个以上的表格，请添加其他Case块。

Public Sub Grinner(ByRef pURL As String) 
    Const cintNumTables As Integer = 2 
    Dim intInnerLoop As Integer 
    Dim intOuterLoop As Integer 
    Dim objDoc As Object 
    Dim objNode As Object 
    Dim strFieldList As String 
    Dim strMsg As String 
    Dim strSql As String 
    Dim strTable As String 
    Dim strTag As String 
    Dim strTagList As String 
    Dim strUID As String 
    Dim strValueList As String 
    Dim varTags As Variant 

On Error GoTo ErrorHandler 

    Set objDoc = GetXMLDoc(pURL) 
    Set objNode = objDoc.getElementsByTagName("UID").Item(0) 
    strUID = objNode.Text 

    For intOuterLoop = 1 To cintNumTables 
     Select Case intOuterLoop 
     Case 1 
      strTable = "Table1" 
      strTagList = "Node1,Node2,Node3,AnotherNode1" 
      strFieldList = "UID, N1, N2, N3, A1" 
     Case 2 
      strTable = "Table2" 
      strTagList = "AnotherNode2,AnotherNode3,SingleNode" 
      strFieldList = "UID, A2, A3, SN" 
     Case Else 
      'oops! 
      strTable = vbNullString 
     End Select 
     If Len(strTable) > 0 Then 
      varTags = Split(strTagList, ",") 
      strValueList = "'" & strUID & "'" 
      For intInnerLoop = 0 To UBound(varTags) 
       strTag = varTags(intInnerLoop) 
       Set objNode = objDoc.getElementsByTagName(strTag).Item(0) 
       strValueList = strValueList & ", '" & _ 
        Replace(objNode.Text, "'", "''") & "'" 
      Next intInnerLoop 
      strSql = "INSERT INTO " & strTable & " (" & _ 
       strFieldList & ")" & vbNewLine & _ 
       "VALUES (" & strValueList & ");" 
      Debug.Print strSql 
      'CurrentDb.Execute strSql, dbFailOnError 
     End If 
    Next intOuterLoop 

ExitHere: 
    Set objNode = Nothing 
    Set objDoc = Nothing 
    On Error GoTo 0 
    Exit Sub 

ErrorHandler: 
    strMsg = "Error " & Err.Number & " (" & Err.Description _ 
     & ") in procedure Grinner" 
    MsgBox strMsg 
    GoTo ExitHere 
End Sub 

Public Function GetXMLDoc(pURL) As Object 
    ' early binding requires reference, Microsoft XML 
    'Dim objDoc As MSXML2.DOMDocument30 
    'Dim objParseErr As MSXML2.IXMLDOMParseError 
    'Set objDoc = New MSXML2.DOMDocument30 
    ' late binding; reference not required 
    Dim objDoc As Object 
    Dim objParseErr As Object 
    Dim strMsg As String 

On Error GoTo ErrorHandler 

    Set objDoc = CreateObject("Msxml2.DOMDocument.3.0") 
    objDoc.async = False 
    objDoc.validateOnParse = True 
    objDoc.Load pURL 
    If (objDoc.parseError.errorCode <> 0) Then 
     Set objParseErr = objDoc.parseError 
     MsgBox ("You have error " & objParseErr.reason) 
     Set objDoc = Nothing 
    End If 

ExitHere: 
    Set objParseErr = Nothing 
    Set GetXMLDoc = objDoc 
    On Error GoTo 0 
    Exit Function 

ErrorHandler: 
    strMsg = "Error " & Err.Number & " (" & Err.Description _ 
     & ") in procedure GetXMLDoc" 
    MsgBox strMsg 
    Set objDoc = Nothing 
    GoTo ExitHere 
End Function 

下面是我发现的4个链接有助于VBA/XML/DOM：

• Google: vba xml dom
• msdn: A Beginner's Guide to the XML DOM
• msdn: Use the XML Object Model
• Stack Overflow: How to parse XML in VBA