Guest_imported
New member
- Jan 1, 1970
- 0
I refer to the wonderful article called Q262099 - ACC2000 Filter-by-Form Example by by Getz, Litwin, and Reddick (Sybex),' Copyright 1994 - 1997. All rights reserved, written for the table tblclients. It works excellent when the ClientD is a unique 5 letters word. However my ClientID is an unique auto number, not a Text, and I cannot use this fine function.Can anybody help me to modify the function,?
=========
Option Compare Database 'Use database order for string comparisons
Option Explicit
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
' REQUIRES A REFERENCE TO Microsoft DAO 3.6.
Const adhcSeparator = ";"
Const adhcAssignment = "="
Function adhDeleteItem(ByVal varInfo As Variant, ByVal varItemName As Variant) As Variant
' Delete a specific item name and its value.
'
' Return the new info string, with the requested
' item and its value removed.
'
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to delete from varInfo
'
' Out:
' Return value: varInfo, with the item and its value deleted.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhDeleteItem(varInfo, "y"
' will return "x=5;z=12;"
Dim lngEndPos As Long
Dim strLeftPart As String
Dim lngPos As Long
Dim intRet As Integer
On Error GoTo adhDeleteItem_Err
' Look for the tag that you've asked to delete.
lngPos = adhFindItemPos(varInfo, varItemName)
If lngPos > 0 Then
' Find the end of the requested tag value. This'll be
' 0 if there's no more items after this one.
lngEndPos = InStr(lngPos + 1, varInfo, adhcSeparator)
' Gather up the part of the tag string to the left of the
' requested tag. This can't fail, since you wouldn't be
' here if lngPos wasn't greater than 0.
strLeftPart = Left$(varInfo, lngPos - 1)
' If there's stuff to the right of the requested item, tack it
' onto the end of the info string.
If lngEndPos > 0 Then
varInfo = strLeftPart & Mid$(varInfo, lngEndPos + 1)
End If
End If
adhDeleteItem = varInfo
adhDeleteItem_Exit:
Exit Function
adhDeleteItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhDeleteItem"
End Select
Resume adhDeleteItem_Exit
End Function
Sub adhErrorHandler(intErr As Integer, strError As String, strProc As String)
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
MsgBox "Error: " & strError & " (" & intErr & "", _
vbInformation, strProc
End Sub
Private Function adhFindItemPos(varInfo As Variant, varItemName As Variant) As Long
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
Dim lngPos As Long
Dim intRet As Integer
On Error GoTo adhFindItemPos_Err
lngPos = 0
' Don't even bother if the info string or the item name is null
' Use a little trick here to trap both the Null case and the
' zero-length string case: if Len(yourString & vbNullString) = 0, then
' <yourString> is either Null or a ZLS.
If Len(varInfo & vbNullString) > 0 And Len(varItemName & vbNullString) > 0 Then
' Stick a adhcSeparator on the front, and then look for
' ";varItemName="
' If it's there, it'll find it on the first pass. No loops!
' This code must be fast, since it gets called A LOT!
lngPos = InStr(adhcSeparator & varInfo, adhcSeparator & varItemName & adhcAssignment)
End If
adhFindItemPos = lngPos
adhFindItemPos_Exit:
Exit Function
adhFindItemPos_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhFindItemPos"
End Select
Resume adhFindItemPos_Exit
End Function
Function adhGetItem(ByVal varInfo As Variant, ByVal varItemName As Variant) As Variant
' Retrieve a specific item value.
' This function will either return the requested
' value or Null if the item name wasn't found.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to retrieve from varInfo
'
' Out:
' Return value: the value associated with varItemName.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhGetItem(varInfo, "y"
' will return 7
'
Dim lngPos As Long
Dim lngEndPos As Long
Dim varResult As Variant
Dim intRet As Integer
On Error GoTo adhGetItem_Err
varResult = Null
lngPos = adhFindItemPos(varInfo, varItemName)
' If the item was found, keep a'goin'.
If lngPos > 0 Then
' Move lngPos to the start of the item value, and
' lngEndPos to the next adhcSeparator, if there is one.
lngPos = lngPos + Len(varItemName) + Len(adhcAssignment)
lngEndPos = InStr(lngPos, varInfo, adhcSeparator)
' Interpret a zero-length property as Null
If lngEndPos = lngPos Then
varResult = Null
Else
' If there wasn't a adhcSeparator, just use the rest
' of the info string. Otherwise, take the part between
' lngPos and lngEndPos.
If lngEndPos = 0 Then
varResult = Mid$(varInfo, lngPos)
Else
varResult = Mid$(varInfo, lngPos, lngEndPos - lngPos)
End If
End If
End If
adhGetItem = varResult
adhGetItem_Exit:
Exit Function
adhGetItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhGetItem"
End Select
Resume adhGetItem_Exit
End Function
Function adhPutItem(ByVal varInfo As Variant, ByVal varItemName As Variant, ByVal varItemValue As Variant) As Variant
' Append the value
'
' [varItemName]=[varItemValue];
'
' onto the varInfo value passed in. If the
' item name already exists, it is deleted first and then the new
' value is appended to the end.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to place into varInfo
' varItemValue: value of item
' Out:
' Return value: modified value of varInfo.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhPutItem(varInfo, "q", "15"
' will return "x=5;y=7;z=12;q=15;"
'
On Error GoTo adhPutItem_Err
Dim intRet As Integer
' If there's already a value in the info string for the item
' you're trying to replace, just REMOVE it.
varInfo = adhDeleteItem(varInfo, varItemName)
' By passing in a null or ZLS for the strItemValue, you effectively
' delete the tag.
If Len(varItemValue & vbNullString) > 0 Then
varInfo = varInfo & varItemName & adhcAssignment & varItemValue & adhcSeparator
End If
adhPutItem = varInfo
adhPutItem_Exit:
Exit Function
adhPutItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhPutItem"
End Select
Resume adhPutItem_Exit
End Function
Function adhCtlTagDeleteItem(ctl As Control, ByVal varItemName As Variant)
' Delete a specific tag name and its value from the
' requested control's .Tag property.
'
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' ctl: reference to a control
' varItemName: name of item to delete
' Out:
' Return Value: the control's Tag property, with the item deleted.
' See adhDeleteItem for details.
ctl.Tag = adhDeleteItem(ctl.Tag, varItemName)
adhCtlTagDeleteItem = ctl.Tag
End Function
Function adhCtlTagGetItem(ctl As Control, ByVal varItemName As Variant) As Variant
' Retrieve a specific tag name from the requested control's
' .Tag property. This function will either return the requested
' value or Null if the tag name wasn't found.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
adhCtlTagGetItem = adhGetItem(ctl.Tag, varItemName)
End Function
Function adhCtlTagPutItem(ctl As Control, ByVal varItemName As Variant, ByVal varItemValue As Variant) As Integer
' Append the value
'
' [varItemName]=[varItemValue]
'
' onto the .Tag property for the requested control.
' See adhPutItem() for more information.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
Const adhcErrTagTooLong = 2176
Dim varOldTag As Variant
On Error GoTo CtlTagPutItemErr
' Assign the new tag value and then return True.
varOldTag = ctl.Tag
ctl.Tag = adhPutItem(varOldTag, varItemName, varItemValue)
adhCtlTagPutItem = True
ctlTagPutItemExit:
Exit Function
CtlTagPutItemErr:
If Err.Number = adhcErrTagTooLong Then
' Make sure ctl.Tag hasn't changed. Then return False.
ctl.Tag = varOldTag
Else
adhErrorHandler Err.Description, Err.Number, "adhCtlTagPutItem"
End If
adhCtlTagPutItem = False
Resume ctlTagPutItemExit
End Function
Option Compare Database 'Use database order for string comparisons
Option Explicit
' REQUIRES A REFERENCE TO Microsoft DAO 3.6.
Const QUOTE = """"
' This string is the text that gets appended
' to the chosen form name, once it's become a
' QBF form. It's completely arbitrary, and can be
' anything you like.
Public Const conQBFSuffix = "_QBF"
Private Function BuildSQLString( _
ByVal strFieldName As String, _
ByVal varFieldValue As Variant, _
ByVal intFieldType As Integer)
' Build string that can be used as part of an
' SQL WHERE clause. This function looks at
' the field type for the specified table field,
' and constructs the expression accordingly.
Dim strTemp As String
On Error GoTo HandleErrors
If Left$(strFieldName, 1) <> "[" Then
strTemp = "[" & strFieldName & "]"
End If
' If the first part of the value indicates that it's
' to be left as is, leave it alone. Otherwise,
' munge the value as necessary.
If IsOperator(varFieldValue) Then
strTemp = strTemp & " " & varFieldValue
Else
' One could use the BuildCriteria method here,
' but it's not as flexible as I'd like to
' be. So, this code does all the work manually.
Select Case intFieldType
Case dbBoolean
' Convert to TRUE/FALSE
strTemp = strTemp & " = " & CInt(varFieldValue)
Case dbText, dbMemo
' Assume we're looking for anything that STARTS with the text we got.
' This is probably a LOT slower. If you want direct matches
' instead, use the commented-out line.
' strTemp = strTemp & " = " & QUOTE & varFieldValue & QUOTE
strTemp = strTemp & " LIKE " & QUOTE & varFieldValue & "*" & QUOTE
Case dbByte, dbInteger, dbLong, dbCurrency, dbSingle, dbDouble
' Convert to straight numeric representation.
strTemp = strTemp & " = " & varFieldValue
Case dbDate
' Convert to #date# format.
strTemp = strTemp & " = " & "#" & varFieldValue & "#"
Case Else
' This function really can't handle any of the other data types. You can
' add more types, if you care to handle them.
strTemp = vbNullString
End Select
End If
BuildSQLString = strTemp
ExitHere:
Exit Function
HandleErrors:
MsgBox "Error: " & Err.Description & " (" & Err.Number & "", vbExclamation, "BuildSQLString"
strTemp = vbNullString
Resume ExitHere
End Function
Private Function BuildWHEREClause(frm As Form) As String
' Build the full WHERE clause based on fields
' on the passed-in form. This function attempts
' to look at all controls that have the correct
' settings in the Tag properties.
Dim strLocalSQL As String
Dim strTemp As String
Dim varDataType As Integer
Dim varControlSource As Variant
Dim ctl As Control
Const conAND As String = " AND "
For Each ctl In frm.Controls
' Get the original control source.
varControlSource = adhCtlTagGetItem(ctl, "qbfField"
If Not IsNull(varControlSource) Then
' If the value of the control isn't null...
If Not IsNull(ctl) Then
' then get the value.
varDataType = adhCtlTagGetItem(ctl, "qbfType"
If Not IsNull(varDataType) Then
strTemp = "(" & BuildSQLString(varControlSource, ctl, varDataType) & ""
strLocalSQL = strLocalSQL & conAND & strTemp
End If
End If
End If
Next ctl
' Trim off the leading " AND "
If Len(strLocalSQL) > 0 Then
BuildWHEREClause = "(" & Mid$(strLocalSQL, Len(conAND) + 1) & ""
End If
End Function
Public Function DoQBF(ByVal strFormName As String, _
Optional blnCloseIt As Boolean = True) As String
' Load the specified form as a QBF form. If
' the form is still loaded when control returns
' to this function, then it will attempt to
' build an SQL WHERE clause describing the
' values in the fields. DoQBF() will return
' either that SQL string or an empty string,
' depending on what the user chose to do and
' whether or not any fields were filled in.
' In:
' strFormName: Name of the form to load
' blnCloseIt: Close the form, if the user didn't?
' Out:
' Return Value: The calculated SQL string.
Dim strSQL As String
DoCmd.OpenForm strFormName, WindowMode:=acDialog
' You won't get here until user hides or closes the form.
' If the user closed the form, there's nothing
' to be done. Otherwise, build up the SQL WHERE
' clause. Once you're done, if the caller requested
' the QBF form to be closed, close it now.
If IsFormLoaded(strFormName) Then
strSQL = BuildWHEREClause(Forms(strFormName))
If blnCloseIt Then
DoCmd.Close acForm, strFormName
End If
End If
DoQBF = strSQL
End Function
Public Function QBFDoClose()
' This is a function so it can be called easily
' from the Properties window directly.
' Close the current form.
On Error Resume Next
DoCmd.Close
End Function
Public Function QBFDoHide(frm As Form)
' This is a function so it can be called easily
' from the Properties window directly.
Dim strSQL As String
Dim strParent As String
'Get the name of the Parent form
strParent = adhGetItem(frm.Tag, "Parent" & vbNullString
'Create the appropriate WHERE clause based on the fields with data in them.
strSQL = DoQBF(frm.Name, False)
If Len(strParent) > 0 Then
'Open the Parent form filtered with the Where clause generated above
DoCmd.OpenForm FormName:=strParent, View:=acNormal, WhereCondition:=strSQL
End If
'Make this QBF form invisible.
frm.Visible = False
End Function
Private Function IsFormLoaded(strName As String) As Boolean
' Return a logical value indicating whether a
' given formname is loaded or not.
' You could use the IsLoaded property of a member
' of the AllForms collection to get this information, but
' that method raises an error if you ask about a
' for that doesn't exist. The obscure SysCmd function
' does not.
On Error Resume Next
IsFormLoaded = (SysCmd(acSysCmdGetObjectState, acForm, strName) <> 0)
End Function
Private Function IsOperator(varValue As Variant) As Boolean
' Return a logical value indicating whether a
' value passed in is an operator or not.
' This is NOT infallible, and may need correcting.
Dim strTemp As String
strTemp = Trim$(UCase(varValue))
IsOperator = False
' Check first character for <,>, or =
If InStr(1, "<>=", Left$(strTemp, 1)) > 0 Then
IsOperator = True
' Check for IN (x,y,z)
ElseIf ((Left$(strTemp, 4) = "IN (" And (Right$(strTemp, 1) = "") Then
IsOperator = True
' Check for BETWEEN ... AND ...
ElseIf ((Left$(strTemp, 8) = "BETWEEN " And (InStr(1, strTemp, " AND " > 0)) Then
IsOperator = True
' Check for NOT xxx
ElseIf (Left$(strTemp, 4) = "NOT " Then
IsOperator = True
' Check for LIKE xxx
ElseIf (Left$(strTemp, 5) = "LIKE " Then
IsOperator = True
End If
End Function
=========
Option Compare Database 'Use database order for string comparisons
Option Explicit
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
' REQUIRES A REFERENCE TO Microsoft DAO 3.6.
Const adhcSeparator = ";"
Const adhcAssignment = "="
Function adhDeleteItem(ByVal varInfo As Variant, ByVal varItemName As Variant) As Variant
' Delete a specific item name and its value.
'
' Return the new info string, with the requested
' item and its value removed.
'
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to delete from varInfo
'
' Out:
' Return value: varInfo, with the item and its value deleted.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhDeleteItem(varInfo, "y"
' will return "x=5;z=12;"
Dim lngEndPos As Long
Dim strLeftPart As String
Dim lngPos As Long
Dim intRet As Integer
On Error GoTo adhDeleteItem_Err
' Look for the tag that you've asked to delete.
lngPos = adhFindItemPos(varInfo, varItemName)
If lngPos > 0 Then
' Find the end of the requested tag value. This'll be
' 0 if there's no more items after this one.
lngEndPos = InStr(lngPos + 1, varInfo, adhcSeparator)
' Gather up the part of the tag string to the left of the
' requested tag. This can't fail, since you wouldn't be
' here if lngPos wasn't greater than 0.
strLeftPart = Left$(varInfo, lngPos - 1)
' If there's stuff to the right of the requested item, tack it
' onto the end of the info string.
If lngEndPos > 0 Then
varInfo = strLeftPart & Mid$(varInfo, lngEndPos + 1)
End If
End If
adhDeleteItem = varInfo
adhDeleteItem_Exit:
Exit Function
adhDeleteItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhDeleteItem"
End Select
Resume adhDeleteItem_Exit
End Function
Sub adhErrorHandler(intErr As Integer, strError As String, strProc As String)
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
MsgBox "Error: " & strError & " (" & intErr & "
", _vbInformation, strProc
End Sub
Private Function adhFindItemPos(varInfo As Variant, varItemName As Variant) As Long
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
Dim lngPos As Long
Dim intRet As Integer
On Error GoTo adhFindItemPos_Err
lngPos = 0
' Don't even bother if the info string or the item name is null
' Use a little trick here to trap both the Null case and the
' zero-length string case: if Len(yourString & vbNullString) = 0, then
' <yourString> is either Null or a ZLS.
If Len(varInfo & vbNullString) > 0 And Len(varItemName & vbNullString) > 0 Then
' Stick a adhcSeparator on the front, and then look for
' ";varItemName="
' If it's there, it'll find it on the first pass. No loops!
' This code must be fast, since it gets called A LOT!
lngPos = InStr(adhcSeparator & varInfo, adhcSeparator & varItemName & adhcAssignment)
End If
adhFindItemPos = lngPos
adhFindItemPos_Exit:
Exit Function
adhFindItemPos_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhFindItemPos"
End Select
Resume adhFindItemPos_Exit
End Function
Function adhGetItem(ByVal varInfo As Variant, ByVal varItemName As Variant) As Variant
' Retrieve a specific item value.
' This function will either return the requested
' value or Null if the item name wasn't found.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to retrieve from varInfo
'
' Out:
' Return value: the value associated with varItemName.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhGetItem(varInfo, "y"
' will return 7
'
Dim lngPos As Long
Dim lngEndPos As Long
Dim varResult As Variant
Dim intRet As Integer
On Error GoTo adhGetItem_Err
varResult = Null
lngPos = adhFindItemPos(varInfo, varItemName)
' If the item was found, keep a'goin'.
If lngPos > 0 Then
' Move lngPos to the start of the item value, and
' lngEndPos to the next adhcSeparator, if there is one.
lngPos = lngPos + Len(varItemName) + Len(adhcAssignment)
lngEndPos = InStr(lngPos, varInfo, adhcSeparator)
' Interpret a zero-length property as Null
If lngEndPos = lngPos Then
varResult = Null
Else
' If there wasn't a adhcSeparator, just use the rest
' of the info string. Otherwise, take the part between
' lngPos and lngEndPos.
If lngEndPos = 0 Then
varResult = Mid$(varInfo, lngPos)
Else
varResult = Mid$(varInfo, lngPos, lngEndPos - lngPos)
End If
End If
End If
adhGetItem = varResult
adhGetItem_Exit:
Exit Function
adhGetItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhGetItem"
End Select
Resume adhGetItem_Exit
End Function
Function adhPutItem(ByVal varInfo As Variant, ByVal varItemName As Variant, ByVal varItemValue As Variant) As Variant
' Append the value
'
' [varItemName]=[varItemValue];
'
' onto the varInfo value passed in. If the
' item name already exists, it is deleted first and then the new
' value is appended to the end.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' varInfo: string of items, delimited with adhcSeparator
' varItemName: name of item to place into varInfo
' varItemValue: value of item
' Out:
' Return value: modified value of varInfo.
'
' Example:
' If varInfo is "x=5;y=7;z=12;", calling
' adhPutItem(varInfo, "q", "15"
' will return "x=5;y=7;z=12;q=15;"
'
On Error GoTo adhPutItem_Err
Dim intRet As Integer
' If there's already a value in the info string for the item
' you're trying to replace, just REMOVE it.
varInfo = adhDeleteItem(varInfo, varItemName)
' By passing in a null or ZLS for the strItemValue, you effectively
' delete the tag.
If Len(varItemValue & vbNullString) > 0 Then
varInfo = varInfo & varItemName & adhcAssignment & varItemValue & adhcSeparator
End If
adhPutItem = varInfo
adhPutItem_Exit:
Exit Function
adhPutItem_Err:
Select Case Err.Number
Case Else
adhErrorHandler Err.Number, Err.Description, "adhPutItem"
End Select
Resume adhPutItem_Exit
End Function
Function adhCtlTagDeleteItem(ctl As Control, ByVal varItemName As Variant)
' Delete a specific tag name and its value from the
' requested control's .Tag property.
'
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
' In:
' ctl: reference to a control
' varItemName: name of item to delete
' Out:
' Return Value: the control's Tag property, with the item deleted.
' See adhDeleteItem for details.
ctl.Tag = adhDeleteItem(ctl.Tag, varItemName)
adhCtlTagDeleteItem = ctl.Tag
End Function
Function adhCtlTagGetItem(ctl As Control, ByVal varItemName As Variant) As Variant
' Retrieve a specific tag name from the requested control's
' .Tag property. This function will either return the requested
' value or Null if the tag name wasn't found.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
'
adhCtlTagGetItem = adhGetItem(ctl.Tag, varItemName)
End Function
Function adhCtlTagPutItem(ctl As Control, ByVal varItemName As Variant, ByVal varItemValue As Variant) As Integer
' Append the value
'
' [varItemName]=[varItemValue]
'
' onto the .Tag property for the requested control.
' See adhPutItem() for more information.
' Adapted from Microsoft Access 2 Developer's Handbook
' by Getz, Litwin, and Reddick (Sybex)
' Copyright 1994 - 1997. All rights reserved.
Const adhcErrTagTooLong = 2176
Dim varOldTag As Variant
On Error GoTo CtlTagPutItemErr
' Assign the new tag value and then return True.
varOldTag = ctl.Tag
ctl.Tag = adhPutItem(varOldTag, varItemName, varItemValue)
adhCtlTagPutItem = True
ctlTagPutItemExit:
Exit Function
CtlTagPutItemErr:
If Err.Number = adhcErrTagTooLong Then
' Make sure ctl.Tag hasn't changed. Then return False.
ctl.Tag = varOldTag
Else
adhErrorHandler Err.Description, Err.Number, "adhCtlTagPutItem"
End If
adhCtlTagPutItem = False
Resume ctlTagPutItemExit
End Function
Option Compare Database 'Use database order for string comparisons
Option Explicit
' REQUIRES A REFERENCE TO Microsoft DAO 3.6.
Const QUOTE = """"
' This string is the text that gets appended
' to the chosen form name, once it's become a
' QBF form. It's completely arbitrary, and can be
' anything you like.
Public Const conQBFSuffix = "_QBF"
Private Function BuildSQLString( _
ByVal strFieldName As String, _
ByVal varFieldValue As Variant, _
ByVal intFieldType As Integer)
' Build string that can be used as part of an
' SQL WHERE clause. This function looks at
' the field type for the specified table field,
' and constructs the expression accordingly.
Dim strTemp As String
On Error GoTo HandleErrors
If Left$(strFieldName, 1) <> "[" Then
strTemp = "[" & strFieldName & "]"
End If
' If the first part of the value indicates that it's
' to be left as is, leave it alone. Otherwise,
' munge the value as necessary.
If IsOperator(varFieldValue) Then
strTemp = strTemp & " " & varFieldValue
Else
' One could use the BuildCriteria method here,
' but it's not as flexible as I'd like to
' be. So, this code does all the work manually.
Select Case intFieldType
Case dbBoolean
' Convert to TRUE/FALSE
strTemp = strTemp & " = " & CInt(varFieldValue)
Case dbText, dbMemo
' Assume we're looking for anything that STARTS with the text we got.
' This is probably a LOT slower. If you want direct matches
' instead, use the commented-out line.
' strTemp = strTemp & " = " & QUOTE & varFieldValue & QUOTE
strTemp = strTemp & " LIKE " & QUOTE & varFieldValue & "*" & QUOTE
Case dbByte, dbInteger, dbLong, dbCurrency, dbSingle, dbDouble
' Convert to straight numeric representation.
strTemp = strTemp & " = " & varFieldValue
Case dbDate
' Convert to #date# format.
strTemp = strTemp & " = " & "#" & varFieldValue & "#"
Case Else
' This function really can't handle any of the other data types. You can
' add more types, if you care to handle them.
strTemp = vbNullString
End Select
End If
BuildSQLString = strTemp
ExitHere:
Exit Function
HandleErrors:
MsgBox "Error: " & Err.Description & " (" & Err.Number & "
", vbExclamation, "BuildSQLString"strTemp = vbNullString
Resume ExitHere
End Function
Private Function BuildWHEREClause(frm As Form) As String
' Build the full WHERE clause based on fields
' on the passed-in form. This function attempts
' to look at all controls that have the correct
' settings in the Tag properties.
Dim strLocalSQL As String
Dim strTemp As String
Dim varDataType As Integer
Dim varControlSource As Variant
Dim ctl As Control
Const conAND As String = " AND "
For Each ctl In frm.Controls
' Get the original control source.
varControlSource = adhCtlTagGetItem(ctl, "qbfField"
If Not IsNull(varControlSource) Then
' If the value of the control isn't null...
If Not IsNull(ctl) Then
' then get the value.
varDataType = adhCtlTagGetItem(ctl, "qbfType"
If Not IsNull(varDataType) Then
strTemp = "(" & BuildSQLString(varControlSource, ctl, varDataType) & "
"strLocalSQL = strLocalSQL & conAND & strTemp
End If
End If
End If
Next ctl
' Trim off the leading " AND "
If Len(strLocalSQL) > 0 Then
BuildWHEREClause = "(" & Mid$(strLocalSQL, Len(conAND) + 1) & "
"End If
End Function
Public Function DoQBF(ByVal strFormName As String, _
Optional blnCloseIt As Boolean = True) As String
' Load the specified form as a QBF form. If
' the form is still loaded when control returns
' to this function, then it will attempt to
' build an SQL WHERE clause describing the
' values in the fields. DoQBF() will return
' either that SQL string or an empty string,
' depending on what the user chose to do and
' whether or not any fields were filled in.
' In:
' strFormName: Name of the form to load
' blnCloseIt: Close the form, if the user didn't?
' Out:
' Return Value: The calculated SQL string.
Dim strSQL As String
DoCmd.OpenForm strFormName, WindowMode:=acDialog
' You won't get here until user hides or closes the form.
' If the user closed the form, there's nothing
' to be done. Otherwise, build up the SQL WHERE
' clause. Once you're done, if the caller requested
' the QBF form to be closed, close it now.
If IsFormLoaded(strFormName) Then
strSQL = BuildWHEREClause(Forms(strFormName))
If blnCloseIt Then
DoCmd.Close acForm, strFormName
End If
End If
DoQBF = strSQL
End Function
Public Function QBFDoClose()
' This is a function so it can be called easily
' from the Properties window directly.
' Close the current form.
On Error Resume Next
DoCmd.Close
End Function
Public Function QBFDoHide(frm As Form)
' This is a function so it can be called easily
' from the Properties window directly.
Dim strSQL As String
Dim strParent As String
'Get the name of the Parent form
strParent = adhGetItem(frm.Tag, "Parent"
& vbNullString'Create the appropriate WHERE clause based on the fields with data in them.
strSQL = DoQBF(frm.Name, False)
If Len(strParent) > 0 Then
'Open the Parent form filtered with the Where clause generated above
DoCmd.OpenForm FormName:=strParent, View:=acNormal, WhereCondition:=strSQL
End If
'Make this QBF form invisible.
frm.Visible = False
End Function
Private Function IsFormLoaded(strName As String) As Boolean
' Return a logical value indicating whether a
' given formname is loaded or not.
' You could use the IsLoaded property of a member
' of the AllForms collection to get this information, but
' that method raises an error if you ask about a
' for that doesn't exist. The obscure SysCmd function
' does not.
On Error Resume Next
IsFormLoaded = (SysCmd(acSysCmdGetObjectState, acForm, strName) <> 0)
End Function
Private Function IsOperator(varValue As Variant) As Boolean
' Return a logical value indicating whether a
' value passed in is an operator or not.
' This is NOT infallible, and may need correcting.
Dim strTemp As String
strTemp = Trim$(UCase(varValue))
IsOperator = False
' Check first character for <,>, or =
If InStr(1, "<>=", Left$(strTemp, 1)) > 0 Then
IsOperator = True
' Check for IN (x,y,z)
ElseIf ((Left$(strTemp, 4) = "IN ("
And (Right$(strTemp, 1) = "") ThenIsOperator = True
' Check for BETWEEN ... AND ...
ElseIf ((Left$(strTemp, 8) = "BETWEEN "
And (InStr(1, strTemp, " AND " > 0)) ThenIsOperator = True
' Check for NOT xxx
ElseIf (Left$(strTemp, 4) = "NOT "
ThenIsOperator = True
' Check for LIKE xxx
ElseIf (Left$(strTemp, 5) = "LIKE "
ThenIsOperator = True
End If
End Function
