在 VBA 中使用 DAO QueryDef 时出现“未定义函数”

Question

我正在将 Access 2007 查询分配给 Excel VBA 中的 QueryDef。我的查询调用用户定义函数，因为它对使用正则表达式评估字段的结果执行计算。我使用 QueryDef 是因为我在 UserForm 中收集值并希望将它们作为参数传递给查询。

当我运行我的 VBA 代码时，我收到一个错误：“运行时错误 '3085': Undefined function 'regexFunc' in expression。”

This question 提示问题是 DAO 无法从 Excel 调用 Access UDF，因此我将我的 UDF 复制到 Excel VBA 模块中，但仍然出现错误。

访问查询：

select field1 from dataTable where regexFunc(field1)=[regexVal]

这是 Excel VBA 代码：

'QueryDef function
Sub makeQueryDef (str As String)

Dim qdf As QueryDef
Dim db As Database

Set db = OpenDatabase(DBpath)
Set qdf = db.QueryDefs("paramQuery")
qdf.Parameters("regexVal") = (str="test")
doSomething qdf

End Sub

'Regex function copied from Access VBA module to Excel VBA module
Function regexFunc(str As String) As Boolean

Dim re As RegExp
Dim matches As MatchCollection

regexFunc = False
Set re = New RegExp
re.Pattern = "\reg[ex](pattern)?"
Set matches = re.Execute(str)
If matches.Count <> 0 Then
    regexFunc = True
End If

End Function

Answer 1

这就是我的做法……刚刚测试过它，它适用于我的 UDF：

一件事 - 您是否需要不使用 New Access.Application？

Sub GetMyDataWithUDF()
    Dim oApp As Access.Application
    Dim qd As QueryDef

    sFileName = "C:\Users\AUser\Desktop\adatabase.mdb"
    Set oApp = New Access.Application
    oApp.OpenCurrentDatabase (sFileName)

    Set qd = oApp.CurrentDb.QueryDefs("Query1")

    If oApp.DCount("*", "MSysObjects", "Name='dataTableResults'") > 0 Then _
        oApp.CurrentDb.TableDefs.Delete "dataTableResults"

    qd.Parameters("avalue") = "4"
    qd.Execute

    oApp.Quit
    Set oApp = Nothing

    Dim oRS As ADODB.Recordset
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFileName & ";User Id=admin;Password=;"
    Set oRS = New ADODB.Recordset
    oRS.Open "SELECT * FROM dataTableResults", sConn
    Sheet1.Cells.Clear
    Sheet1.Range("A1").CopyFromRecordset oRS
    oRS.Close
    Set oRS = Nothing
End Sub

注意，我将基础查询设为 SELECT ... INTO 查询，该查询创建了一个名为“dataTableResults”的表

这是我在 Access 中的查询 (QueryDef)：

SELECT dataTable.Field1, dataTable.Field2 INTO dataTableResults
FROM dataTable
WHERE mysqr(dataTable.Field1)=[avalue];

我的 MS-Access DB 有一个名为“mysqr”的函数，它在上面的 SQL 中使用。

Function mysqr(Num)
        mysqr = Num * Num
    End Function

我要查询的表“dataTable”只是一个数字列表，所以如果我的参数“avalue”是“16”，那么我会返回“4”行。如果我输入“4”（在我的代码中），我会得到“2”。

Answer 2

我已经解决了这个问题。以下是我的做法。

首先我将查询更改为记录集并将其传递给我的过滤函数：

function filteredQDF(qdf As QueryDef, boolVal As Boolean) As Variant

Dim rs As Recordset
Dim rows_rs As Variant
Dim rs_new As Recordset
Dim filtered As Variant


Set rs = qdf.OpenRecordset

rs.MoveLast
rs.MoveFirst

rows_rs = rs.GetRows(rs.RecordCount)
rows_rs = Application.WorksheetFunction.Transpose(rows_rs)
filtered = filterFunction(rows_rs, boolVal)

filteredQDF = filtered

End Function

这里是过滤函数，它创建一个新数组，用通过 UDF 布尔检查的行填充它，然后返回它：

Function filterFunction(sourceArray As Variant, checkValue As Boolean) As Variant


Dim targetArray As Variant
Dim cols As Long
Dim targetRows As Long
Dim targetCursor As Long


'get # of columns from source array
cols = UBound(sourceArray, 2)

'count total number of target rows because 2D arrays cannot Redim Preserve
'checking sourceArray(r,2) because that's the criterion column
targetRows = 0
For r = 1 To UBound(sourceArray, 1)
    If myUDF(CStr(sourceArray(r, 2))) = checkValue Then
        targetRows = targetRows + 1
    End If
Next

'set minimum target rows to 1 so that function will always return an array
If targetRows = 0 Then
    targetRows = 1
End If

'redim target array with target row count
ReDim targetArray(targetRows, cols)

'set cursor for assigning values to target array
targetCursor = 0


'iterate through sourceArray, collecting UDF-verified rows and updating target cursor to populate target array
For r = 1 To UBound(sourceArray, 1)
    If myUDF(CStr(sourceArray(r, 2))) = checkValue Then
        For c = 1 To cols
            targetArray(targetCursor, c - 1) = sourceArray(r, c)
        Next
        targetCursor = targetCursor + 1
    End If
Next


'assign return value
filterFunction = targetArray

End Function