Question

这是我第四次写这篇文章，所以请多多包涵。我整天都在努力解决这个问题，我觉得我真的很接近解决方案，但还远远没有解决。我已经阅读了很多有关Stack Overflow和其他地方的文章，但无法弄清楚。这段代码的一部分是从SO的另一种解决方案中借用的，而另一部分工作不正常（据我所知）

我想做的是允许用户单击MS Access中表单中的按钮，该按钮将运行下面的VBA代码。

代码的第一部分将打开一个对话框，允许用户选择一个文件夹。该文件夹将容纳所有要更新到表中的XML文件。（这将是一个持续的过程）
从这一点开始，我想创建一个循环，循环遍历每个XML文件并获取5个数据点（标记为 serial，CalDueDate，日期，时间，和 OverallResult ），然后将这5个字段放入Access表中。

我已经一遍又一遍地运行解决方案和调试器，并且不断提出不同的错误。但是，我相信我已将其范围缩小到最后一个错误（手指交叉），这就是我要向社区寻求帮助的原因。

Private Sub Command4_Click()
'Folder selector'
Dim xStrPath As String
Dim xFileDialog As Object
Dim xFile As String
Dim xCount As Long
'Now merge XML lookup and table entry'
Const cintNumTables As Integer = 1
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 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDialog
        .AllowMultiSelect = False
        .Title = "Select a Folder to Import XML Files from"
        .Show
End With

xStrPath = xFileDialog.SelectedItems(1)
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xml")
xCount = 1
  Do While xFile <> ""
    For intOuterLoop = 1 To cintNumTables
        Select Case intOuterLoop
        Case 1
            strTable = "XMLConvertedTable"
            strTagList = "serial,CalDueDate,date,time,overallResult"
            strFieldList = "Serial, DateCalibrationDue, DateCalibrated, TimeCalibrated, TestResult"
        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)
                strValueList = strValueList & ", '" & "'"
            Next intInnerLoop
'works? to this point'
            strSQL = "INSERT INTO " & strTable & " (" & strFieldList & ")" & vbNewLine & "Values (" & strValueList & ");"
            Debug.Print strSQL
            CurrentDb.Execute strSQL, dbFailOnError
        End If
    Next intOuterLoop
  Loop
ExitHere:
    Set objNode = Nothing
    Set objDoc = Nothing
    On Error GoTo 0
    Exit Sub

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

示例XML

<?xml version="1.0" encoding="UTF-8"?>
<resultset>
     <info>
           <instrument>instrument 1</instrument>
           <serial>000000</serial>
           <calDueDate>12 June 2019</calDueDate>
           <date>May 13 2019</date>
           <time>4:48:00 PM</time>
           <overallResult>PASS</overallResult>
           <opID>Not Used</opID>

更新

我已将代码编辑为如下所示，以减轻跟踪所有内容的混乱。我还发现错误位于SQL语句中。我发现变量strTable，strTagList和strFieldList正确地将代码传递到了SQL语句。

Private Sub Command5_Click()

'Folder selector'
 Dim xStrPath As String
 Dim xFileDialog As Object
 Dim xFile As String
 Dim xCount As Long
 'Now merge XML lookup and table entry'
 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 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDialog
    .AllowMultiSelect = False
    .Title = "Select a Folder to Import XML Files from"
    .Show
End With

xStrPath = xFileDialog.SelectedItems(1)
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xml")
    Do While xFile <> ""
        strTable = "XMLConvertedTable"
        strTagList = "serial, CalDueDate, date, time, overallResult"
        strFieldList = "Serial, DateCalibrationDue, DateCalibrated,     
        TimeCalibrated, TestResult"
        If Len(strTable) > 0 Then
            varTags = Split(strTagList, ",")
'There is an error in the next statement (error 13)'
            strValueList = varTags & ",'"
            strSQL = "INSERT INTO " & strTable & " (" & _
            strFieldList & ")" & "VALUES (" & strValueList & ");"
            Debug.Print strSQL
        CurrentDb.Execute strSQL, dbFailOnError
    End If
 Loop

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

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

我现在遇到的错误是

过程“重试”中的错误13（类型不匹配）

任何帮助将不胜感激！

Image of Access Table Design View

Answer 1

在您的varTags循环中，以下行： strValueList = strValueList & ", '" & "'" 似乎缺少对strTag的引用。

这将导致参数编号不匹配，因为strFieldList和strValueList的大小将不相同。

我猜应该是strValueList = strValueList & ", '" & strTag & "'"。

此外，您可能不应该在vbNewLine字符串中包含strSQL。

从桌面文件夹中的多个XML文件中获取多个字段并将其放入访问表中

1 个答案: