導入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