VBA中DLookup返回2950保留错误的问题求助

问题描述 #

使用Excel 2016和Access 2016，此前在家运行正常的代码，在办公室及后续在家环境中，以下DLookup语句返回2950错误：

varX = DLookup("[Código]", "Campanha", "[Cod Produto] = " & EntradaBD.Fields("Cod Produto").Value)

仅通过程序ADODB连接数据库时出错，手动打开Access数据库后错误消失，其他数据库操作函数在数据库关闭时可正常工作，完整代码如下：

Private Sub cbgrupo_Change()
Dim fonteBD As String
Dim varX As Variant

Set EntradaBD = New ADODB.Recordset

ConectaAccess

If Me.cbgrupo.Value = "TODOS" Then
    fonteBD = "Select * FROM [BancoDados] WHERE [Grupo] is not null ORDER BY [Cod Produto]"
Else
    fonteBD = "Select * FROM [BancoDados] WHERE [Grupo] = '" & Me.cbgrupo.Value & "' ORDER BY [Cod Produto]"
End If
EntradaBD.Open fonteBD, conectabd, adOpenKeyset, adLockReadOnly

If Not (EntradaBD.EOF And EntradaBD.BOF) Then
    EntradaBD.MoveFirst 
    
    Do Until EntradaBD.EOF = True
    varX = DLookup("[Código]", "Campanha", "[Cod Produto] = " & EntradaBD.Fields("Cod Produto").Value)
    If IsNull(varX) Then
        Me.ListBox1.AddItem EntradaBD.Fields("Cod Produto").Value
        Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = EntradaBD.Fields("Produto").Value
    End If

    EntradaBD.MoveNext
    Loop
    
End If

If Not EntradaBD Is Nothing Then EntradaBD.Close


'fecha a conexão com o BD
DesconectaAccess

错误原因 #

DLookup是Access VBA的内置函数，它依赖Access应用程序实例的运行上下文。当仅通过ADODB连接数据库时，并没有启动Access实例，DLookup无法定位到目标数据库的环境，因此抛出2950错误。手动打开Access时，Access实例已运行并加载了数据库，上下文存在，所以DLookup能正常工作。

解决方案 #

方法1：用ADODB查询替代DLookup（推荐） #

直接通过已有的ADODB连接执行查询，获取需要的[Código]值，无需依赖Access实例。修改循环内的代码如下：

Do Until EntradaBD.EOF = True
    Dim rsCampanha As New ADODB.Recordset
    Dim codProduto As Variant
    codProduto = EntradaBD.Fields("Cod Produto").Value
    
    ' 构建查询语句（注意如果Cod Produto是文本类型，需要加单引号）
    Dim sqlCampanha As String
    If IsNumeric(codProduto) Then
        sqlCampanha = "SELECT [Código] FROM [Campanha] WHERE [Cod Produto] = " & codProduto
    Else
        sqlCampanha = "SELECT [Código] FROM [Campanha] WHERE [Cod Produto] = '" & Replace(codProduto, "'", "''") & "'"
    End If
    
    rsCampanha.Open sqlCampanha, conectabd, adOpenForwardOnly, adLockReadOnly
    If rsCampanha.EOF Then
        varX = Null
    Else
        varX = rsCampanha.Fields("[Código]").Value
    End If
    rsCampanha.Close
    Set rsCampanha = Nothing
    
    If IsNull(varX) Then
        Me.ListBox1.AddItem EntradaBD.Fields("Cod Produto").Value
        Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = EntradaBD.Fields("Produto").Value
    End If

    EntradaBD.MoveNext
Loop

注意：如果Cod Produto是文本类型，必须在值前后加单引号，并且要转义值内的单引号（用Replace函数替换为两个单引号），避免SQL语法错误和注入风险。

方法2：启动Access实例并打开数据库 #

如果一定要使用DLookup，可以在连接数据库前启动Access实例并打开目标数据库，确保上下文存在：

Private Sub cbgrupo_Change()
Dim fonteBD As String
Dim varX As Variant
Dim accessApp As Access.Application ' 声明Access实例

Set EntradaBD = New ADODB.Recordset
Set accessApp = New Access.Application
accessApp.OpenCurrentDatabase "你的Access数据库路径" ' 替换为实际路径

ConectaAccess

' 后续原有代码保持不变...

' 最后关闭Access实例
accessApp.CloseCurrentDatabase
Set accessApp = Nothing

DesconectaAccess

这种方法需要确保客户端机器安装了Access，且性能不如直接用ADODB查询高效。

额外建议 #

原代码中拼接Grupo条件的SQL语句存在SQL注入风险，建议改用参数化查询：

If Me.cbgrupo.Value = "TODOS" Then
    fonteBD = "Select * FROM [BancoDados] WHERE [Grupo] is not null ORDER BY [Cod Produto]"
Else
    fonteBD = "Select * FROM [BancoDados] WHERE [Grupo] = ? ORDER BY [Cod Produto]"
End If
EntradaBD.Open fonteBD, conectabd, adOpenKeyset, adLockReadOnly
EntradaBD.Parameters(0).Value = Me.cbgrupo.Value

内容的提问来源于stack exchange，提问作者Lucas Portela