Question

我正在尝试编写一个VBA代码，它会使用ADODB连接将数据上传到Access数据库。问题是我想在上传之前检查数据完整性，因此检查输入掩码格式，允许值，是否需要字段，字段长度，数据类型。到目前为止我想通了，我会

让用户选择要上传的数据库和表格（ADODB.OpenSchema）
与DAO连接以获取有关输入掩码和其他信息（至少输入掩码只能由DAO完成）
连接到选定的表，创建空记录集，断开连接（ADODB）
在构建批记录集时测试数据到参数，并忽略具有wrtong数据的行
上传数据

在上传到数据库之前，还有其他常用的方法来测试输入掩码格式的数据吗？请给我指示，我会谷歌休息

如果您有兴趣，请参阅下面的内容。

谢谢

 Option Explicit
Option Base 1

Sub opentest()

Dim file As String, table As String
Dim outputarray As Variant
Dim cancelwork As Boolean
Dim coll As Collection
Set coll = New Collection


Dim adSchemaTables As Long, adOpenDynamic As Long, adLockBatchOptimistic As Long, adUseClient As Long 'named methods/properties must be defined as numbers for late binding
adOpenDynamic = 2
adLockBatchOptimistic = 4
adSchemaTables = 20
adUseClient = 3




With Application.FileDialog(msoFileDialogFilePicker) 'lets user select database
    .Title = "Select Database"
    .AllowMultiSelect = False
    .Show

    If .SelectedItems.Count = 0 Then
            End
        Else
            file = CStr(.SelectedItems(1))
    End If

End With


Dim cnn As Object, rs As Object   ' late binding, should allow no need for ADO library reference in excel
Set cnn = createobject("ADODB.connection")
Set rs = createobject("ADODB.Recordset")

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";" & "Persist Security Info=False"

Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "link")) 'for linked tables

Do While Not rs.EOF
    coll.Add CStr(rs("table_name"))
    rs.MoveNext
Loop

Set rs = Nothing

Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "table")) 'for actual tables

Do While Not rs.EOF
    coll.Add CStr(rs("table_name"))
    rs.MoveNext
Loop

Call ListBox(coll, table) 'lets the user select table where to upload

Set rs = Nothing
Set rs = createobject("ADODB.Recordset")
rs.CursorLocation = adUseClient

rs.Open "select * from " & table & " where false", cnn, adOpenDynamic, adLockBatchOptimistic 'connection

Set rs.ActiveConnection = Nothing 'disconnecting to build data


Call dataload(rs, cancelwork) 'calling dataload function

If cancelwork = True Then
        Call closing(rs, cnn)
        End
End If


Set rs.ActiveConnection = cnn

rs.UpdateBatch 'uploading data



Call closing(rs, cnn)

End Sub

Sub closing(rs As Object, cnn As Object)


rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing

End Sub

Private Sub ListBox(ByVal coll As Collection, ByRef table As String)

Dim item As Variant

For Each item In coll
    ListBoxForm.ListBox1.AddItem (item)
Next item

ListBoxForm.Show
table = ListBoxForm.ListBox1.value

ListBoxForm.ListBox1.Clear

End Sub

Sub dataload(ByRef rs As Object, ByRef cancelwork As Boolean)
Dim loadarray() As Variant
Dim region As Range
Dim response As VbMsgBoxResult

On Error Resume Next
Set region = Application.InputBox(Prompt:="Select data to upload", Type:=8)
If region Is Nothing Then
        End
End If

loadarray = region

If (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) > rs.Fields.Count Then
        MsgBox "Number of columns to be uploaded is greater then number of columns in database, ending"
        cancelwork = True
        Exit Sub
    ElseIf (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) < rs.Fields.Count Then
        response = MsgBox("Number of columns to be uploaded is less then number of columns in database", vbOKCancel)
        If response = vbCancel Then
                cancelwork = True
                Exit Sub
        End If
End If

Set rs = recordsetload(rs, loadarray, region)


End Sub

Private Function recordsetload(rs As Object, loadarray As Variant, region As Range) As Object

Dim rowi As Long, columni As Long, rsrow As Long

For rowi = LBound(loadarray, 1) To UBound(loadarray, 1)
        rs.AddNew
        For columni = LBound(loadarray, 2) To UBound(loadarray, 2)
                rs.Fields(columni - 1).value = loadarray(rowi, columni)
        Next columni
Next rowi

Set recordsetload = rs

End Function

    Sub daotry2()
    Dim file As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Database"
        .AllowMultiSelect = False
        .Show

        If .SelectedItems.Count = 0 Then
                End
            Else
                file = CStr(.SelectedItems(1))
        End If

    End With

    Dim db As Object  'late binding without reference, seems to work, but might cause trouble, not tested
    Dim tbl As Object

    Dim dbe As Object
    Set dbe = CreateObject("DAO.DBEngine.120")  'depends on win version


    Set db = dbe.OpenDatabase(file)
    Set tbl = db.TableDefs("CAPEX")

    Debug.Print tbl.Fields(0).Properties("InputMask")
    Debug.Print tbl.Fields(0).Properties("Size")
    Debug.Print tbl.Fields(0).Properties("ValidationRule")
    Debug.Print tbl.Fields(0).Properties("Required")

    db.Close

    End Sub

Answer 1

所以对我而言，看起来你正在使这种不必要的复杂化。我无法说出最常见的模式，但是当我这样做时，我采用的方法是让代码无形地复制我希望最终附加数据的表，并尝试插入将数据导入该登台表。然后，如果有任何错误，Access会自动创建一个包含＆＃34; ImportError＆＃34;的表。在您可以查看以识别问题的名称中。您可以编写代码来计算每种错误的数量，并将该消息输出给用户。如果未创建ImportError表，则表示没有错误，因此您可以将登台表中的数据复制到最终表中，并删除登台表。

这种方法的好处是您不必让代码检查要附加到的表的输入掩码和验证规则;你只是做到，看看会发生什么。

Answer 2

使用Will Jobs方法

通过创建和使用登台表，我不会删除我遇到的问题。如果我尝试将数据从Excel导入到Access，并且有不符合表规则的断开连接的记录集中添加了数据，则批量更新仍然失败，并且只导入一些行。我不知道导入的内容和失败的内容

我找到的最简单的方法是“On error resume next”的组合，并更新它自己的每个添加的行。如果它不遵循表的规则，则无法更新，我可以在Excel中将此行标记为红色。

轻微更改adLockPesimistic上的连接（值2），并且不会断开记录集

rs.Open "select * from " & table & " where false", cnn, adOpenDynamic, adLockPesimistic 'connection

recordsetload已更改。它将仅添加遵循表规则的行。比较批量更新和单个记录更新，661行23个字段的时间差异非常小（批量更新似乎在这个数据量上一直慢一点）

Private Function recordsetload(rs As Object, loadarray As Variant, region As Range) As Object

Dim rowi As Long, columni As Long, rsrow As Long

Err.Clear
On Error Resume Next
For rowi = LBound(loadarray, 1) To UBound(loadarray, 1)
        If Err.Number = 0 Then
                rs.AddNew
            Else
                Err.Clear
        End If
        For columni = LBound(loadarray, 2) To UBound(loadarray, 2)
                rs.Fields(columni - 1).value = loadarray(rowi, columni)
        Next columni
        rs.Update
        If Err.Number <> 0 Then
                region.Rows(rowi).Interior.colorindex = 3
        End If

Next rowi
On Error GoTo 0

Set recordsetload = rs

End Function

使用ADODB / DAO将数据从Excel上载到数据库（Access），检查数据是否正确输入掩码

2 个答案: