Option Compare Database 'Use database order for string comparisons
Option Explicit
' Replacement Functions for DLookup, DCount & DSum , DMax & DMin
'
' Notes:
' Any spaces in field names or table names will probably result in an error
' If this is the case then provide the brackets yourselfs, e.g.
' tLookup("My field","My table name with spaces in") will blow big time
' tLookup("[My field]","[My table name with spaces in]") will be ok
' These functions will not bracket the field/table names for you so as to
' remain as flexible as possible, e.g. you can call tSum() to add or multiply or
' whatever along the way, e.g. tSum("Price * Qty","Table","criteria") or if you're
' feeling adventurous, specify joins and the like in the table name.
'
' See tLookup function for changes from last version
'
' Uses DAO
'
' VB Users
' Get rid of tLookupParam() and the case in the error trapping
' of tLookup() that calls it, this uses a function built-in to
' MS-Access.
Public Enum tLookupReset
tLookupDoNothing = 0
tLookupRefreshDb = 1
tLookupSetToNothing = 2
End Enum
Function tCount(pstrField As String, pstrTable As String, Optional pstrCriteria As String, Optional pdb As Database, Optional pLookupReset As tLookupReset = tLookupDoNothing) As Long
' Function tCount
' Purpose: Replace DCount, which is slow on attached tables
' Created: 1 Feb 1996 T.Best
' TB 28 Jan 2003
' Make this call TLookup() so we'll only need concentrate on
' one set of error handling code
tCount = tLookup("count(" & pstrField & ")", pstrTable, pstrCriteria, pdb, pLookupReset)
End Function
Function tMax(pstrField As String, pstrTable As String, Optional pstrCriteria As String, Optional pdb As Database, Optional pLookupReset As tLookupReset = tLookupDoNothing) As Variant
' Function tMax
' Purpose: Replace DMax, which is slow on attached tables
' Created: 1 Feb 1996 T.Best
' TB 28 Jan 2003
' Make this call TLookup() so we'll only need concentrate on
' one set of error handling code
' ArnelGP 11 Feb 2014
' uses Top Value
pstrTable = "(Select Top 1 " & pstrField & " As Expr9999 From " & pstrTable & _
" Where " & IIf(IsMissing(pstrCriteria), "(1=1)", pstrCriteria) & _
" Order By 1 Desc)"
tMax = tLookup("Expr9999", pstrTable, , pdb, pLookupReset)
'tMax = tLookup("max(" & pstrField & ")", pstrTable, pstrCriteria, pdb, pLookupReset)
End Function
Function tMin(pstrField As String, pstrTable As String, Optional pstrCriteria As String, Optional pdb As Database, Optional pLookupReset As tLookupReset = tLookupDoNothing) As Variant
' Function tMin
' Purpose: Replace DMin, which is slow on attached tables
' Created: 1 Feb 1996 T.Best
' TB 28 Jan 2003
' Make this call TLookup() so we'll only need concentrate on
' one set of error handling code
' ArnelGP 11 Feb 2014
' uses Top Value
pstrTable = "(Select Top 1 " & pstrField & " As Expr9999 From " & pstrTable & _
" Where " & IIf(IsMissing(pstrCriteria), "(1=1)", pstrCriteria) & _
" Order By 1 Asc)"
tMin = tLookup("Expr9999", pstrTable, , pdb, pLookupReset)
'tMin = tLookup("min(" & pstrField & ")", pstrTable, pstrCriteria, pdb, pLookupReset)
End Function
Function tSum(pstrField As String, pstrTable As String, Optional pstrCriteria As String, Optional pdb As Database, Optional pLookupReset As tLookupReset = tLookupDoNothing) As Double
' Function tSum
' Purpose: Replace DSum, which is slow on attached tables
' Created: 1 Feb 1996 T.Best
' TB 28 Jan 2003
' Make this call TLookup() so we'll only need concentrate on
' one set of error handling code
tSum = Nz(tLookup("sum(" & pstrField & ")", pstrTable, pstrCriteria, pdb, pLookupReset), 0)
End Function
Function tLookup(pstrField As String, pstrTable As String, Optional pstrCriteria As String, Optional pdb As Database, Optional pLookupReset As tLookupReset = tLookupDoNothing) As Variant
On Error GoTo tLookup_Err
' Function tLookup
' Purpose: Replace DLookup, which is slow on attached tables
' For where you can't use TbtLookup() if there's more
' than one field in the criteria or field is not indexed.
' Created: 9 Jan 1996 T.Best
' Mod 1 Feb 1996 T.Best
' Error Trapping brought in line with this procurement system.
' Mod 13 Apr 1999 T.Best
' Lookups to ODBC datasource use the gdbSQL database object.
' Mod 14 Apr 1999 T.Best
' gdbSQL object no good if doing lookup on a local table, DOH!
' Mod 11 Jan 2002 G.Hughes
' Removed gdbSQL as it was slowing tLookup Down.!!!!!!!!!
' Mod Unlogged
' Someone put gdbSQL back in
' Mod 27 Jan 2003 T. Best
' Optimise gdbSQL to use Pass-through, it wickedly fast
' mod 13 Mar 2003
' Taken out gdbSQL for redistribution and replaced
' the DbEngine with CurrentDB to avoid the now well
' documented (in CDMA) DbEngine reference bug.
' Added tLookupReset Parameter which does the following
' tLookupDoNothing Do nothing
' tLookupRefreshDb Refreshes collections on the db
' tLookupCloseDb Sets the db to nothing
' Also added a db parameter so programmer can call it using
' their own db variable, which may be something they opened
' elsewhere (Idea by D.Fenton in CDMA).
Static dbLookup As DAO.Database
Dim rstLookup As DAO.Recordset
Dim varvalue As Variant
Dim strSQL As String
' if calling function sends a db then we'll use that
If Not pdb Is Nothing Then
Set dbLookup = pdb
Else
' If our db vari is not initialised or the calling
' process wants the db objects refreshed then we'll
' set the db var using CurrentDb()
If dbLookup Is Nothing Or pLookupReset = tLookupRefreshDb Then
If Not dbLookup Is Nothing Then
Set dbLookup = Nothing
End If
Set dbLookup = CurrentDb()
End If
End If
' If no criteria specified then we don't even want to get as far
' as putting the word "where" in there
If Len(pstrCriteria) = 0 Then
strSQL = "Select " & pstrField & " From " & pstrTable
Else
' handle those instances where you call tLookup using a field
' on a form but can't be bothered to check whether it's null
' first before calling, e.g. =tLookup("col1","table","col2=" & txtWhatever)
' if txtWhatever was null it would cause an error, this way if there's
' nothing after the "=" sign then we assume it was null so we'll make
' it look for one.
' You may want to handle this differently and avoid looking up
' data where the criteria field is null and just always return a
' null in which case you'd need to add code to avoid doing the
' lookup altogether or just change the criteria to " = Null" as
' nothing will ever match with " = Null" so the function would
' return null.
If Right(RTrim(pstrCriteria), 1) = "=" Then
pstrCriteria = RTrim(pstrCriteria)
pstrCriteria = Left(pstrCriteria, Len(pstrCriteria) - 1) & " is Null"
End If
' build our SQL string
strSQL = "Select " & pstrField & " From " & pstrTable & " Where " & pstrCriteria
End If
' now open a recordset based on our SQL
Set rstLookup = dbLookup.OpenRecordset(strSQL, dbOpenSnapshot, dbReadOnly)
' chekc if we returned anything at all
If Not rstLookup.BOF Then
' return the value returned in the query
varvalue = rstLookup(0)
Else
' no records matched, return a null
varvalue = Null
End If
tLookup = varvalue
tLookup_Exit:
On Error Resume Next
rstLookup.Close
Set rstLookup = Nothing
Exit Function
tLookup_Err:
Select Case Err
Case 3061
' Error 3061 - Too Few Parameters - Expected x, you know those programmers
' should really parse out those form object references for themselves but
' we can try to retrieve the situation here by evaluating any parameters
' we find in the SQL string.
tLookup = tLookupParam(strSQL, dbLookup)
Case Else
MsgBox Err.Description, 16, "Error " & Err.Number & " in tLookup() on table " & pstrTable & vbCr & vbCr & "SQL=" & strSQL
End Select
Resume tLookup_Exit
Resume
End Function
Function tLookupParam(pstrSQL As String, pdb As Database) As Variant
' Called when tLookup, tCount, tMax, tMin or tSum have bombed out
' with an expected parameter error, will go and create a querydef
' and then attempt to evaluate the parameters
' Error Trapped: 12/02/1999 10:21:24 Admin
On Error GoTo tCountParam_Err
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim PRM As DAO.Parameter
Dim strMsg As String
Dim I As Long
Set qdf = pdb.CreateQueryDef("", pstrSQL)
strMsg = vbCr & vbCr & "SQL=" & pstrSQL & vbCr & vbCr
For I = 0 To qdf.Parameters.Count - 1 ' Each prm In qdf.Parameters
Set PRM = qdf.Parameters(I)
strMsg = strMsg & "Param=" & PRM.Name & vbCr
Debug.Print PRM.Name
PRM.Value = Eval(PRM.Name)
Set PRM = Nothing
Next
Set rst = qdf.OpenRecordset()
rst.MoveFirst
tLookupParam = rst(0)
tCountParam_Exit:
On Error Resume Next
Set PRM = Nothing
rst.Close
Set rst = Nothing
qdf.Close
Set qdf = Nothing
Exit Function
tCountParam_Err:
Select Case Err
Case Else
MsgBox Err.Description & strMsg, 16, "Error #" & Err.Number & " In tLookupParam()"
End Select
Resume tCountParam_Exit
Resume
End Function
