VBA 将 DAO 连接字符串和 Recordset 转换为 ODBC

Question

我有一个在 Word 中用 VBA 编写的加载项，该加载项相当陈旧。我认为它可以追溯到 1997 年。目前 VBA 代码将连接到 Access 2003 数据库并查询表并返回数据记录集并从该表查询中生成供应商列表。

下面是使用 DAO 方法的代码。现在的问题是我们收到的具有 Windows 10 的较新计算机没有 DAO 方法使用的旧库。 （加上 DAO 本身已经过时了）。

Public strData() As String

Sub GetData(strTable As String)
Dim dbf As DAO.Database
Dim rst As DAO.Recordset
Dim Counter As Long
Dim strCriteria As String


If strTable = "VendorQ" Then
    strCriteria = "SELECT NameSort FROM Vendor Where Qualified = -1 ORDER BY NameSort"
ElseIf strTable = "VendorU" Then
    strCriteria = "SELECT NameSort FROM Vendor Where Qualified = 0 ORDER BY NameSort"
ElseIf strTable = "MainR" Then
    strCriteria = "SELECT NameSort FROM Vendor ORDER BY NameSort"
Else
    MsgBox "Error"
End If

Set dbf = OpenDatabase("\\fileLocation\center.mdb")
Set rst = dbf.OpenRecordset(strCriteria)

frmCenter.MousePointer = fmMousePointerHourGlass
Counter = 0
If rst.RecordCount > 0 Then
    rst.MoveLast

    ReDim strData(rst.RecordCount - 1) As String
    rst.MoveFirst
    Do Until rst.EOF
        strData(Counter) = rst![NameSort]
        Counter = Counter + 1
        rst.MoveNext
    Loop
Else
    ReDim strData(0)
End If
frmCenter.MousePointer = fmMousePointerArrow
rst.Close
End Sub

这将返回一个列表：

该表已经存在于 MySQL 数据库中，因此我可以使用 ODBC 连接来检索数据，而不会将 Access 作为通向链接表的通道。我尝试转换连接字符串并连接到数据库，但由于某种原因没有显示供应商列表。

这是转换后的代码：

Public strData() As String

Sub GetData(strTable As String)
Dim rst As ADODB.Recordset
Dim Counter As Long
Dim strCriteria As String
Dim conn As ADODB.Connection

Set remoteCon = New ADODB.Connection

conStr = "DRIVER={MySQL ODBC 5.2 ANSI Driver};" & _
    "SERVER=server;DATABASE=database;" & _
    "UID=uid;PWD=pwd"
    
remoteCon.ConnectionString = conStr
remoteCon.Open

remoteCon.Execute ("USE database;")

Set rst = New ADODB.Recordset

If strTable = "VendorQ" Then
    strCriteria = "SELECT NameSort FROM Vendor Where Qualified = -1 ORDER BY NameSort"
ElseIf strTable = "VendorU" Then
    strCriteria = "SELECT NameSort FROM Vendor Where Qualified = 0 ORDER BY NameSort"
ElseIf strTable = "MainR" Then
    strCriteria = "SELECT NameSort FROM Main ORDER BY NameSort"
Else
    MsgBox "Error"
End If

With rst
    .ActiveConnection = remoteCon
    .CursorType = adOpenDynamic
    .LockType = adLockOptimistic
    .Source = strCriteria
    .Open
End With

frmCenter.MousePointer = fmMousePointerHourGlass
Counter = 0
If rst.RecordCount > 0 Then
    rst.MoveLast

    ReDim strData(rst.RecordCount - 1) As String
    rst.MoveFirst
    Do Until rst.EOF
        strData(Counter) = rst![NameSort]
        Counter = Counter + 1
        rst.MoveNext
    Loop
Else
    ReDim strData(0)
End If
frmCenter.MousePointer = fmMousePointerArrow
rst.Close
End Sub

是否有其他方法可以从 ODBC 源填充记录集？

Answer 1

RecordCount 在您运行到记录集的末尾（例如在 MoveLast 中）之前通常是不可靠的，所以我会使用 EOF 来代替：

If Not rst.EOF Then
    rst.MoveLast
    ReDim strData(rst.RecordCount - 1) As String
    rst.MoveFirst
    Do Until rst.EOF
        strData(Counter) = rst![NameSort]
        Counter = Counter + 1
        rst.MoveNext
    Loop
Else
    ReDim strData(0)
End If

编辑：

仅供参考，在我的测试中 RecordCount 使用 adOpenDynamic 始终为 -1，但我使用 adOpenKeyset 得到了正确的值

如果RecordCount 不可靠，那么您可以使用GetRows() 将记录传输到二维数组，然后使用它来调整大小并填充strData

If Not rs.EOF Then
    arrRecs = rs.GetRows 'a 2D array (0 to #cols-1, 0 to #rows-1)
    ReDim strData(UBound(arrRecs, 2))
    For i = 0 To UBound(arrRecs, 2)
        strData(i) = arrRecs(0, i)
    Next i
Else
    ReDim strData(0)
End If

Answer 2

请参阅 Erik A https://stackoverflow.com/a/46130089/2359206 的回答 将 .CursorLocation = adUseClient 添加到第一个打开的字符串解决了这个问题。