Here is some code that I have used in many apps for years. It is probably a
little dated since MsgBox() change in version 2000. There is a msgbox
replacement function for 2000 and later at
http://www.trigeminal.com/usenet/usenet015.asp?1033.
Public Function FormOnError(pintDataErr As Integer) As Integer
'===================================================================+
'This function can be called from the On Error event of a form |
' to trap data errors such as input mask or invalid data |
'Allow Access to handle other types of errors such as referential |
' integrity, record locking etc. |
'To implement this function, use the following syntax |
' Private Sub Form_Error(DataErr As Integer, Response As Integer) |
' Response = FormOnError(DataErr) |
' End Sub |
' Programmer: Duane Hookom |
' Date: 10/29/1998 |
' Parameters: pintDataErr is the Form Error number |
'===================================================================+
On Error GoTo FormOnError_Err
Dim strErrMsg As String 'For Error Handling
Const INPUTMASK_VIOLATION = 2279
Const DATAVALUE_VIOLATION = 2113 'bad date or too large of number or
text in numeric
Const LIMITTOLIST_VIOLATION = 2237
Const VALIDATION_VIOLATION = 2107 'violation of Validation
Select Case pintDataErr
Case INPUTMASK_VIOLATION, DATAVALUE_VIOLATION,
LIMITTOLIST_VIOLATION, VALIDATION_VIOLATION
Case Else 'Get out and let Access Handle all other errors
FormOnError = acDataErrDisplay
Exit Function
End Select
Dim strMsg As String
Dim strCtlName As String
Dim strCaption As String
Dim strAccessError As String
Dim strCurText As String
Dim intReturn As Integer
Dim ctrl As Control
Set ctrl = Screen.ActiveControl
intReturn = acDataErrContinue
strCtlName = ctrl.Name
strCurText = "The value entered"
On Error Resume Next 'in case ctrl doesn't have a text property or Label
strCurText = ctrl.Text
If ctrl.Controls.Count > 0 Then 'Get the label caption if present
strCaption = ctrl.Controls(0).Caption
End If
On Error GoTo FormOnError_Err 'set error handling back on
strAccessError = Application.AccessError(pintDataErr)
Select Case pintDataErr
Case VALIDATION_VIOLATION
strMsg = "The value " & strCurText & " isn't a valid entry.@" &
_
"The validation rule is: " & strCaption & " " _
& ctrl.ValidationRule & "." & vbCrLf & _
"Enter a valid value or press [Escape] to cancel your
changes.@"
Case INPUTMASK_VIOLATION
Select Case Left(ctrl.InputMask, 10)
Case "99/99/0000"
strMsg = strCurText & " is an invalid date format." & _
"@All dates must contain the century 'm/d/yyyy'.@"
Case Else
strMsg = "An input mask violation occurred in control "
strMsg = strMsg & strCtlName & "." & "@The text/numbers
must " & _
"match the format " & ctrl.InputMask & ".@"
End Select
Case DATAVALUE_VIOLATION
strMsg = strCurText & " is an incorrect value." & "@" & _
"For instance an invalid date or text in a " & _
"numeric field or value too large for the data field@"
Case LIMITTOLIST_VIOLATION
strMsg = strCurText & " is not in the list of options." & _
"@You must enter a value from the list.@"
Case Else
strMsg = "Form data error: " & pintDataErr & vbCrLf &
strAccessError
End Select
Beep 'Get the user's attention
MsgBox strMsg, vbInformation + vbOKOnly, strCaption & " Data Error"
On Error Resume Next
' Select the full text
ctrl.SelStart = 0
ctrl.SelLength = Len(ctrl.InputMask)
FormOnError_Exit:
FormOnError = intReturn
Exit Function
FormOnError_Err:
Select Case Err
Case Else
strErrMsg = strErrMsg & "Error #: " & Format$(Err.Number) &
vbCrLf
strErrMsg = strErrMsg & "Error Description: " & Err.Description
MsgBox strErrMsg, vbInformation, "FormOnError"
Resume FormOnError_Exit
End Select
End Function
