使用SQL和VB6将XML数据导入MS Access表

我有一个XML文件，在/response/result/record下面有许多记录。例如：

<response>
  <result>
    <record>
      <flda>some text</flda>
      <fldb>some text</fldb>
      :     :     :
    </record>
    :    :    :
  </result>
</response>

它将快速地将数据批量加载到数据库中。比从CSV文件中读取每条记录并使用DAO记录集一次添加一条记录快得多

我的问题是：我可以对XML文件做同样的事情吗？语法是什么？我该怎么做

后续问题：我在哪里可以找到关于我在StackOverflow上最初找到的CSV文件的上述时髦的“选择…”语法的文档？

据我所知，您想要的选择语法仅在JETSQL40.CHM文档中定义。这通常与MS Office 2000或更高版本一起安装，但您必须在Program Files特殊文件夹中查找它。那里有很多有用的东西，我通常会自己创建一个快捷方式

但是，由于没有可安装的Jet XML ISAM IISAM，因此您必须像MS Access那样导入XML格式的数据

虽然这确实涉及到循环，但您可以以比人们通常使用的更为优化的方式进行批量插入。下面使用的代码试图做到这一点

该程序有一个表单，其中包含一个菜单项mnuImportXML和一个名为FlexGrid的MSHFlexGrid，用于在第一次运行时创建的数据库中显示记录表的内容：

Option Explicit

Private Const CONNWG As String = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                               & "Jet OLEDB:Engine Type=5;" _
                               & "Jet OLEDB:Create System Database=True;" _
                               & "Data Source='$DB$.mdw';"
Private Const CONNDB As String = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                               & "Jet OLEDB:Engine Type=5;" _
                               & "Jet OLEDB:System Database='$DB$.mdw';" _
                               & "Data Source='$DB$.mdb';"

Private CN As ADODB.Connection
Private QueryRS As ADODB.Recordset
Private UpdateRS As ADODB.Recordset
Private XmlRS As ADODB.Recordset
Private recordsRS As ADODB.Recordset
Private AppendFields As Variant

Public Function OpenConnection(ByVal DbPath As String) As ADODB.Connection
    Dim ExtensionPos As Long

    ExtensionPos = InStrRev(DbPath, ".")
    If ExtensionPos > 0 Then DbPath = Left$(DbPath, ExtensionPos - 1)
    On Error Resume Next
    GetAttr DbPath & ".mdb"
    If Err Then
        On Error GoTo 0
        Set OpenConnection = CreateDB(DbPath)
    Else
        On Error GoTo 0
        Set OpenConnection = New ADODB.Connection
        OpenConnection.Open Replace$(CONNDB, "$DB$", DbPath)
    End If
End Function

Private Function CreateDB(ByVal DbPath As String) As ADODB.Connection
    Dim catDB As Object 'Don't early-bind ADOX objects.

    Set catDB = CreateObject("ADOX.Catalog")
    With catDB
        .Create Replace$(CONNWG, "$DB$", DbPath)
        .Create Replace$(CONNDB, "$DB$", DbPath)
        Set CreateDB = .ActiveConnection
        Set catDB = Nothing
    End With
    With CreateDB
        .Execute "CREATE TABLE [Records](" _
               & "[ID] IDENTITY CONSTRAINT PK_UID PRIMARY KEY," _
               & "[flda] TEXT(255) WITH COMPRESSION," _
               & "[fldb] TEXT(255) WITH COMPRESSION)", , _
                 adCmdText Or adExecuteNoRecords
    End With
End Function

Private Sub RefreshGrid()
    QueryRS.Open "[Records]", , , adLockReadOnly, adCmdTable
    Set FlexGrid.DataSource = QueryRS
    QueryRS.Close
End Sub

Private Sub Form_Load()
    Set CN = OpenConnection("demo.mdb")
    Set QueryRS = New ADODB.Recordset
    QueryRS.CursorLocation = adUseClient
    Set QueryRS.ActiveConnection = CN
    Set XmlRS = New ADODB.Recordset
    XmlRS.ActiveConnection = "Provider=MSDAOSP;Data Source=MSXML2.DSOControl.3.0"
    Set UpdateRS = New ADODB.Recordset
    Set UpdateRS.ActiveConnection = CN
    UpdateRS.Properties("Append-Only Rowset").Value = True
    AppendFields = Array("flda", "fldb")
    RefreshGrid
End Sub

Private Sub Form_Resize()
    If WindowState <> vbMinimized Then
        FlexGrid.Move 0, 0, ScaleWidth, ScaleHeight
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    CN.Close
End Sub

Private Sub mnuImportXML_Click()
    XmlRS.Open "response.xml"
    Set recordsRS = XmlRS.Fields("record").Value
    UpdateRS.Open "Records", , , adLockOptimistic, adCmdTableDirect
    CN.BeginTrans
    With recordsRS
        Do Until .EOF
            UpdateRS.AddNew AppendFields, _
                            Array(.Fields(AppendFields(0)).Value, _
                                  .Fields(AppendFields(1)).Value)
            .MoveNext
        Loop
    End With
    CN.CommitTrans
    UpdateRS.Close
    Set recordsRS = Nothing
    XmlRS.Close
    RefreshGrid
End Sub

这是在表单加载的初始化过程中完成的。它稍微提高了性能

我不知道有什么更快的方法可以做到这一点。Jet无法将XML文档用作外部数据库。它只能使用具有IISAM的数据库类型，如文本、HTML、Excel 8.0、dBase IV和Paradox

无论微软只是懒惰，没有考虑就将XML从Jet 4.0中删除，XML文档的层次结构本质在不扩展Jet SQL语法的情况下并没有给它们留下很多选项，或者我还没有找到一些语法。。。我只是说不上来。

有几个答案建议如何将XML数据转换为CSV格式，然后可以使用您描述的方法导入CSV。

Option Explicit

Private Const CONNWG As String = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                               & "Jet OLEDB:Engine Type=5;" _
                               & "Jet OLEDB:Create System Database=True;" _
                               & "Data Source='$DB$.mdw';"
Private Const CONNDB As String = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                               & "Jet OLEDB:Engine Type=5;" _
                               & "Jet OLEDB:System Database='$DB$.mdw';" _
                               & "Data Source='$DB$.mdb';"

Private CN As ADODB.Connection
Private QueryRS As ADODB.Recordset
Private UpdateRS As ADODB.Recordset
Private XmlRS As ADODB.Recordset
Private recordsRS As ADODB.Recordset
Private AppendFields As Variant

Public Function OpenConnection(ByVal DbPath As String) As ADODB.Connection
    Dim ExtensionPos As Long

    ExtensionPos = InStrRev(DbPath, ".")
    If ExtensionPos > 0 Then DbPath = Left$(DbPath, ExtensionPos - 1)
    On Error Resume Next
    GetAttr DbPath & ".mdb"
    If Err Then
        On Error GoTo 0
        Set OpenConnection = CreateDB(DbPath)
    Else
        On Error GoTo 0
        Set OpenConnection = New ADODB.Connection
        OpenConnection.Open Replace$(CONNDB, "$DB$", DbPath)
    End If
End Function

Private Function CreateDB(ByVal DbPath As String) As ADODB.Connection
    Dim catDB As Object 'Don't early-bind ADOX objects.

    Set catDB = CreateObject("ADOX.Catalog")
    With catDB
        .Create Replace$(CONNWG, "$DB$", DbPath)
        .Create Replace$(CONNDB, "$DB$", DbPath)
        Set CreateDB = .ActiveConnection
        Set catDB = Nothing
    End With
    With CreateDB
        .Execute "CREATE TABLE [Records](" _
               & "[ID] IDENTITY CONSTRAINT PK_UID PRIMARY KEY," _
               & "[flda] TEXT(255) WITH COMPRESSION," _
               & "[fldb] TEXT(255) WITH COMPRESSION)", , _
                 adCmdText Or adExecuteNoRecords
    End With
End Function

Private Sub RefreshGrid()
    QueryRS.Open "[Records]", , , adLockReadOnly, adCmdTable
    Set FlexGrid.DataSource = QueryRS
    QueryRS.Close
End Sub

Private Sub Form_Load()
    Set CN = OpenConnection("demo.mdb")
    Set QueryRS = New ADODB.Recordset
    QueryRS.CursorLocation = adUseClient
    Set QueryRS.ActiveConnection = CN
    Set XmlRS = New ADODB.Recordset
    XmlRS.ActiveConnection = "Provider=MSDAOSP;Data Source=MSXML2.DSOControl.3.0"
    Set UpdateRS = New ADODB.Recordset
    Set UpdateRS.ActiveConnection = CN
    UpdateRS.Properties("Append-Only Rowset").Value = True
    AppendFields = Array("flda", "fldb")
    RefreshGrid
End Sub

Private Sub Form_Resize()
    If WindowState <> vbMinimized Then
        FlexGrid.Move 0, 0, ScaleWidth, ScaleHeight
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    CN.Close
End Sub

Private Sub mnuImportXML_Click()
    XmlRS.Open "response.xml"
    Set recordsRS = XmlRS.Fields("record").Value
    UpdateRS.Open "Records", , , adLockOptimistic, adCmdTableDirect
    CN.BeginTrans
    With recordsRS
        Do Until .EOF
            UpdateRS.AddNew AppendFields, _
                            Array(.Fields(AppendFields(0)).Value, _
                                  .Fields(AppendFields(1)).Value)
            .MoveNext
        Loop
    End With
    CN.CommitTrans
    UpdateRS.Close
    Set recordsRS = Nothing
    XmlRS.Close
    RefreshGrid
End Sub

UpdateRS.Properties("Append-Only Rowset").Value = True