«Неопределенная функция» при использовании DAO QueryDef в VBA - PullRequest
Новая
       77

«Неопределенная функция» при использовании DAO QueryDef в VBA

1 голос
/ 18 августа 2011

Я назначаю запрос Access 2007 для QueryDef в Excel VBA. Мой запрос вызывает пользовательскую функцию, потому что он выполняет вычисление результатов вычисления поля с помощью регулярного выражения. Я использую QueryDef, потому что я собираю значения в пользовательской форме и хочу передать их в запрос в качестве параметров.

Когда я запускаю свой код VBA, я получаю сообщение об ошибке: «Ошибка времени выполнения« 3085 »: неопределенная функция« regexFunc »в выражении».

Этот вопрос говорит о том, что проблема в том, что DAO не может вызывать Access UDF из Excel, поэтому я скопировал свой 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

Ответы [ 2 ]

1 голос
/ 18 августа 2011

Я решил это. Вот как я это сделал.

Сначала я изменяю запрос на набор записей и передаю его в свою функцию фильтрации: 

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
1 голос
/ 18 августа 2011

Вот как я бы это сделал ... только что проверил, и он отлично работает с моим 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

Это мой запрос (QueryDef)в Access: 

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

В моей базе данных MS-Access есть функция "mysqr", которая используется в приведенном выше SQL. 

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

Таблица "dataTable".Запрашивать это просто список чисел, поэтому, если мой параметр «avalue» равен «16», я получаю строку «4» обратно.Если я введу «4» (как в моем коде), я получу «2» обратно.

...