Public Function RunQuery(ByVal prmstrQuery As String, _
ByVal prmintRowsToReturn As Integer, _
ParamArray prmarrReturnFields() As Variant) As Variant
On Error GoTo RunQuery_ERR
Const cRETURN_ALL As Integer = 0 'For row-returning queries
Const cRETURN_FIRST As Integer = 1
Const cRETURN_LAST As Integer = -2 'Any positive number could mess up the return
Const cRETURN_NONE As Integer = -1 'For action queries
Dim objDB As DAO.Database
Dim objRS As DAO.Recordset
Dim objField As DAO.Field
Dim objError As Object
Dim strQuery As String
Dim intRowsToReturn As Integer
Dim arrRSFields() As Variant
Dim arrReturnFields As Variant
Dim arrFields As Variant
Dim i As Integer
Dim j As Integer
ReDim arrFields(0, 0)
arrFields(0, 0) = "#ERROR"
intRowsToReturn = CInt(prmintRowsToReturn) 'safety
strQuery = Trim(prmstrQuery)
arrReturnFields = prmarrReturnFields
If strQuery & "x" <> "x" Then
Set objDB = CurrentDb
Set objRS = objDB.OpenRecordset(strQuery)
If intRowsToReturn = cRETURN_NONE Then
'Only action queries will request "RETURN_NONE"
arrFields(0, 0) = objDB.RecordsAffected
ElseIf objRS.RecordCount > 0 Then
If Not IsArray2(arrReturnFields) Then
Select Case intRowsToReturn
Case cRETURN_ALL
arrFields = objRS.GetRows()
Case cRETURN_FIRST
arrFields = objRS.GetRows(1)
Case cRETURN_LAST
'This is as straightforward as i can make it to fetch the last on a "generic" basis
objRS.MoveLast
ReDim arrFields(objRS.Fields.Count - 1, 0)
i = 0
For Each objField In objRS.Fields
arrFields(i, 0) = objField.Value
i = i + 1
Next objField
Set objField = Nothing
Case Else 'Any other positive integer will be considered as the # of rows to return
If intRowsToReturn > 0 Then
arrFields = objRS.GetRows(intRowsToReturn)
End If
End Select
Else 'User requested to return only specific field (slower...)
ReDim arrRSFields(UBound(arrReturnFields))
For i = 0 To UBound(arrRSFields) 'Create an array of field objects based on the return list
Set arrRSFields(i) = objRS.Fields(arrReturnFields(i))
Next i
Select Case intRowsToReturn
Case cRETURN_ALL
ReDim arrFields(UBound(arrRSFields, 1), objRS.RecordCount - 1)
j = 0
Do
For i = 0 To UBound(arrRSFields, 1)
arrFields(i, j) = arrRSFields(i).Value
Next i
j = j + 1
objRS.MoveNext
Loop Until objRS.EOF
Case cRETURN_FIRST
objRS.MoveFirst
For i = 0 To UBound(arrRSFields, 1)
arrFields(i, 0) = arrRSFields(i).Value
Next i
Case cRETURN_LAST
objRS.MoveLast
For i = 0 To UBound(arrRSFields, 1)
arrFields(i, 0) = arrRSFields(i).Value
Next i
End Select
End If 'Not IsArray2(arrReturnFields)
End If 'Rst.RecordCount > 0
End If 'strQuery & "x" <> "x"
RunQuery_END:
Set objRS = Nothing
Set objDB = Nothing
If IsArray2(arrRSFields) Then
For i = 0 To UBound(arrRSFields, 1)
Set arrRSFields(i) = Nothing
Next i
Erase arrRSFields
End If
RunQuery = arrFields 'Return the resultset as an array
Exit Function
RunQuery_ERR:
If DBEngine.Errors.Count > 0 Then
ReDim arrFields(1, DBEngine.Errors.Count) 'dont put .count - 1, first row is needed ...
arrFields(0, 0) = vbObjectError
arrFields(1, 0) = "#ERROR"
i = 1
For Each objError In DBEngine.Errors
arrFields(0, i) = objError.Number
arrFields(1, i) = objError.Description
i = i + 1
Next objError
Else
ReDim arrFields(1, 1)
arrFields(0, 0) = vbObjectError
arrFields(1, 0) = "#ERROR"
arrFields(1, 0) = Err.Number
arrFields(1, 1) = Err.Description
End If
Resume RunQuery_END
End Function
Public Function IsArray2(ByRef prmTestArray)
On Error Resume Next
'Do not make calls to CheckError here, we handle errors manually
Dim intCrasher
intCrasher = UBound(prmTestArray)
IsArray2 = ((Err.Number = 0) And (intCrasher > -1)) 'Returns true or false
Err.Clear
End Function
)
Perhaps I'll be able to do it with assisstance, but I should do that in my other thread.
