Option Compare Database

Option Explicit
'Purpose:       Call this in any form to:
'               (i) highlight required fields, or
'               (ii) highlight the control that has focus.
'
'Usage:         To do both:
'                   =SetupForm([Form])
'               To do just the required fields, or just the focus, use:
'                   =SetupForm([Form], 1)
'                   =SetupForm([Form], 2)
'               Note: Do not substitute your form name for [Form] above.
'
'Author:        Allen Browne    allen@allenbrowne.com
'Version:       21 September 2008.
'Copyright:     None. You can use this in your database for any purpose.
'               We request that you acknowledge the source in your code.
'Documentation: http://allenbrowne.com
'
'Notes:         1. Colors work in Form view and Continuous Form (highlights entire column),
'                   but only the star shows Datasheet view.
'               2. Works on text boxes, combos, and list boxes only.
'               3. Change the colors immediately below to suit (RGB values.)
'
'The RGB value to use as a control's Back Color when it has focus.
Private Const mlngcFocusBackColor = &HB0FFFF
'The RGB value to use as Back Color if a control is bound to a required field.
Private Const mlngcRequiredBackColor = &HD0D0FF

'These constants are for assigning/reading the Tag property.
Private Const mstrcTagBackColor = "UsualBackColor"
Private Const mstrcTagSeparator = ";"
Private Const mstrcTagAssignmnent = "="

Public Function SetupForm(frm As Form, Optional iSetupWhat As Integer = &H7FFF)
    'Purpose:   Set up a form to do both (highlight required, and control with focus.)
    'Argument:  A reference to the form to setup.
    'Usage:     Set form's On Load property to: =SetupForm([Form])
    'Note:      The Required must be handled first (to save the right restore value.)
    Const iSetupRequired = 1
    Const iSetupFocusColor = 2
    
    If (iSetupWhat And iSetupRequired) Then Call SetupRequiredFields(frm)
    If (iSetupWhat And iSetupFocusColor) Then Call SetupFocusColor(frm)
End Function

Public Function SetupFocusColor(frm As Form)
On Error GoTo Err_Handler
    'Purpose:   Set properties for all text boxes, combos, and list boxes, _
                    so they are highlighted when they receive focus.
    'Argument:  A reference to the form to setup.
    'Usage:     Set any form's On Load property to:  =SetupFocusColor([Form])
    'Note:      Skips any control that already has something in OnGotFocus or OnLostFocus.
    'Return:    True on success
    Dim ctl As Access.Control   'Each control on the form.
    
    For Each ctl In frm.Controls
        With ctl
            Select Case .ControlType
            Case acTextBox, acComboBox, acListBox
                If (.OnGotFocus = vbNullString) And (.OnLostFocus = vbNullString) Then
                    .OnGotFocus = "=Hilight([" & .Name & "], True)"
                    .OnLostFocus = "=Hilight([" & .Name & "], False)"
                    .Tag = .Tag & IIf(.Tag <> vbNullString, mstrcTagSeparator, Null) & _
                        mstrcTagBackColor & mstrcTagAssignmnent & .BackColor
                End If
            End Select
        End With
    Next
    SetupFocusColor = True
    
Exit_Handler:
    Set ctl = Nothing
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "SetupFocusColor()"
    Resume Exit_Handler
End Function

Public Function SetupRequiredFields(frm As Form)
On Error GoTo Err_Handler
    'Purpose:   Set properties for all text boxes, combos, and list boxes, _
                    to highlight those bound to a required field.
    'Argument:  A reference to the form to setup.
    'Usage:     Set any form's On Load property to:  =SetupRequired([Form])
    'Return:    True on success
    Dim rs As DAO.Recordset     'Recordset of the form.
    Dim ctl As Access.Control   'Each control on the form.
    Dim strField As String      'Name of the field a control is bound to.
    
    Set rs = frm.Recordset
    For Each ctl In frm.Controls
        Select Case ctl.ControlType
        Case acTextBox, acComboBox, acListBox
            'Ignore unbound, or bound to an expression.
            strField = ctl.ControlSource
            If (strField <> vbNullString) And Not (strField Like "=*") Then
                With rs(strField)
                    If (.Required) Or (.ValidationRule Like "*Is Not Null*") Then
                        ctl.BackColor = mlngcRequiredBackColor
                        Call MarkAttachedLabel(ctl)
                    End If
                End With
            End If
        End Select
    Next
    SetupRequiredFields = True
    
Exit_Handler:
    Set ctl = Nothing
    Set rs = Nothing
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "SetupRequiredFields()"
    Resume Exit_Handler
End Function

Public Function Hilight(ctl As Access.Control, bOn As Boolean)
    'Purpose:   This code that gets called when focus moves into/out of a control.
    'Arguments: ctl = the control whose BackColor should be changed.
    '           bOn = flag: True if receiving focus, False if losing focus.
    Dim strBackColor As String
    
    If bOn Then
        'Assign the 'got focus' color.
        ctl.BackColor = mlngcFocusBackColor
    Else
        'Restore the color from the control's Tag property (white if not found.)
        strBackColor = ReadFromTag(ctl, mstrcTagBackColor)
        If IsNumeric(strBackColor) Then
            ctl.BackColor = Val(strBackColor)
        Else
            ctl.BackColor = vbWhite
        End If
    End If
End Function

Private Function MarkAttachedLabel(ctl As Access.Control)
On Error GoTo Err_Handler
    'Purpose:   Bypass the error if a control has no attached label.
    
    With ctl.Controls(0)
        If Not .Caption Like "*[*]" Then
            .Caption = .Caption & "*"
            .FontBold = True
        End If
    End With

Exit_Handler:
    Exit Function

Err_Handler:
    Resume Exit_Handler
End Function

Private Function ReadFromTag(ctl As Control, strName As String) As String
    'Purpose:   Parse a value from the Tag property of a control.
    'Arguments: ctl = the control whoe Tag property you want to look in.
    '           strName = the name of the variable to search for.
    'Return:    The value of the property. ZLS if not found.
    'Example:   ReadFromTag([Text0], "test") will returns 99 if Text0.Tag is:
    '               test=99
    Dim varArray As Variant
    Dim strValue As String
    Dim i As Long
    
    If ctl.Tag <> vbNullString Then
        varArray = Split(ctl.Tag, mstrcTagSeparator)
        If IsArray(varArray) Then
            For i = LBound(varArray) To UBound(varArray)
                If varArray(i) Like strName & mstrcTagAssignmnent & "*" Then
                    ReadFromTag = Mid(varArray(i), Len(strName) + Len(mstrcTagAssignmnent) + 1&)
                End If
            Next
        End If
    End If
End Function



