this code uses for highlight controls in MS-Access 2003 Forms
copy this code to new VBA Module
all the instruction to implement it included within the code
copy this code to new VBA Module
all the instruction to implement it included within the code
Code:
Option Compare Database
Option Explicit
'Author: Allen Browne
'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.
'
'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