Forgot to include two modules ---
basTags ---
Option Compare Database 'Use database order for string comparisons
Option Explicit
Const SEPARATOR = ";"
Const ERR_TAG_TOO_LONG = 2176
Private Function DeleteTag(ctl As Control, strTagName As String)
' Delete a specific tag name and its value from the
' requested control's .Tag property.
'
' Return True if successful, otherwise return False.
' This should only fail if the requested tag can't be found.
'
Dim intEndPos As Integer
Dim strLeftPart As String
Dim varNewTag As Variant
Dim intPos As Integer
Dim varTag As Variant
varTag = ctl.Tag
' Look for the tag that you've asked to delete.
intPos = FindTagPos(varTag, strTagName)
If intPos = 0 Then
DeleteTag = varTag
Exit Function
End If
' Find the end of the requested tag value.
intEndPos = InStr(intPos + 1, varTag, SEPARATOR)
' Gather up the part of the tag string to the left of the
' requested tag.
strLeftPart = Left(varTag, intPos - 1)
' If there's stuff to the right of the requested tag, tack it
' onto the end of the tag.
If intEndPos > 0 Then
varTag = strLeftPart & Mid(varTag, intEndPos + 1)
End If
ctl.Tag = varTag
DeleteTag = varTag
End Function
Private Function FindTagPos(varTag As Variant, strTagName As String) As
Integer
Dim intPos As Integer
If Not IsNull(varTag) Then
' Handle the error that will occur when you try and find
' Mid(varTag, intPos - 1, 1) when intPos == 1. This is a
' very likely occurrence, and is not really an error in this case.
On Error Resume Next
Do
intPos = InStr(varTag, strTagName & "=")
' It better either be at the beginning of the tag property or
' be preceded by a semi-colon!
If (intPos = 1) Or (Mid(varTag, intPos - 1, 1) = SEPARATOR) Then
Exit Do
End If
Loop While intPos > 0
On Error GoTo 0
End If
FindTagPos = intPos
End Function
Function glrGetTag(ctl As Control, strTagName As String) 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.
Dim varTag As Variant
Dim intPos As Integer
Dim intEndPos As Integer
Dim varResult As Variant
varTag = ctl.Tag
varResult = Null
intPos = FindTagPos(varTag, strTagName)
If intPos > 0 Then
intPos = intPos + Len(strTagName)
intEndPos = InStr(intPos + 1, varTag, SEPARATOR)
If intEndPos = 0 Then
varResult = Mid(varTag, intPos + 1)
Else
varResult = Mid(varTag, intPos + 1, intEndPos - intPos - 1)
End If
End If
glrGetTag = varResult
End Function
Function glrPutTag(ctl As Control, strTagName As String, varTagValue As
Variant) As Integer
' Append the value
'
' [strTagName]=[varTagValue]
'
' onto the .Tag property for the requested control. If the
' tagName already exists, it is deleted first and then the new
' value is appended to the end. If the function completes successfully,
' it returns True (-1). If it fails, it returns 0.
'
Dim varTag As Variant
Dim intPos As Integer
Dim varOldTag As Variant
On Error GoTo PT_Err
varOldTag = ctl.Tag
varTag = DeleteTag(ctl, strTagName)
' If there's already a value in the tag string for the tag
' you're trying to replace, just REMOVE it. Then at the end,
' the code will tack the new value onto the end of the tag value
' before assigning it back into the .Tag property.
' By passing in a ZLS for the strTagValue (""), you effectively
' delete the tag. Or, you can pass a Null value, too, since, in that
' case, Len(varTagValue) will be Null, and that isn't greater than 0
' (actually, it's Null), so the code will never add on anything.
If Len(varTagValue) > 0 Then
varTag = varTag & strTagName & "=" & varTagValue & SEPARATOR
End If
' Assign the new tag value and then return True.
ctl.Tag = varTag
glrPutTag = True
Exit Function
PT_Err:
If Err = ERR_TAG_TOO_LONG Then
' Make sure C.Tag hasn't changed. Then return False.
ctl.Tag = varOldTag
glrPutTag = False
Else
MsgBox "Error: " & Error & " (" & Err & ")"
End If
Exit Function
End Function
basCarry ---
Option Compare Database 'Use database order for string comparisons
Option Explicit
Function glrAtNew(frm As Form)
' Check to see if the current record is the New record.
' Returns True/False.
' This function is based on the concept that you can't retrieve
' a bookmark for the New record, so Access flags the error. This
' function returns True if the error is non-zero, which it will be if
' the New record is current.
Const ERR_NO_CURRENT_ROW = 3021
Dim strTemp As String
On Error Resume Next
strTemp = frm.Bookmark
glrAtNew = (Err = ERR_NO_CURRENT_ROW)
On Error GoTo 0
End Function
Function glrRestoreValues(strForm As String, strControl As String)
' Given a form name and a control name,
Dim varTemp As Variant
Dim ctl As Control
' Deal with the error that might occur when trying
' to access the control name passed in.
On Error Resume Next
Set ctl = Forms(strForm)(strControl)
If Err = 0 Then
If IsNull(ctl) Then
' If glrGetTag() can't find the tag value it needs,
' it'll just return Null. And that will be fine
' in this case.
ctl = glrGetTag(ctl, "CarryValue")
End If
End If
RestoreValuesExit:
On Error GoTo 0
Exit Function
RestoreValuesErr:
MsgBox Error & " (" & Err & ")"
Resume RestoreValuesExit
End Function
Function glrStoreValues(strForm As String, strControl As String)
Dim varTemp As Variant
Dim ctl As Control
' Deal with the error that might occur when trying
' to access the control name passed in.
On Error GoTo StoreValuesErr
Set ctl = Forms(strForm)(strControl)
If Err = 0 Then
varTemp = glrPutTag(ctl, "CarryValue", ctl)
End If
StoreValuesExit:
Exit Function
StoreValuesErr:
MsgBox Error & " (" & Err & ")"
Resume StoreValuesExit
End Function
Sub glrSweep(frm As Form, strCommand As String)
' Walk through all the controls on the form, looking in the
' Tag property for the Carry tag value. If it's there and it's True,
' then execute the command passed into this function.
Const QUOTE = """"
Dim IntI As Integer
Dim varTemp As Variant
Dim C As String
For IntI = 0 To frm.Count - 1
If glrGetTag(frm(IntI), "Carry") Then
varTemp = strCommand & "(" & QUOTE & frm.Name & QUOTE & "," &
QUOTE & frm(IntI).Name & QUOTE & ")"
varTemp = Eval(varTemp)
End If
Next IntI
End Sub
