Create Validation Routines in Access 2000 (Article)
Author: David Nishimoto
Version Compatibility: Visual Basic 6
Instructions: Copy the declarations and code below and paste directly into your VB project.
David Nishimoto davepamn@relia.net Article: Creating your own Access 2000 validation routines
Overview: This article explains how to create your own Access 2000 validation routines. Access 2000 has ValidationRules you can create for each control. However, I found it easier to use Visual Basic techniques to validate my data.
You may wonder why these validation routines were created in Access when the data types and bound controls could prevent most of the data errors. In truth, I uses these routines to validated using Active Server Pages by converting the validation routines to javascript. The javascript was converted to vbascript and run in this Access 2000 demonstration.
You may find creating your own validation routines more flexible and functional than the validation rules in Access.
Objectives: 1. You will be able to determine if user input is a valid number, date, in a list, within a number range, or a field value in a table.
Basic Setup:
1. One command button name "cmdValidate" 2. Five TextBoxes: a. txtNumber b. txtDate c. txtList d. txtRange e. txtInTable
Code
Option Explicit Option Compare Database Purpose: The Validate button has been pressed by the user. Each validation type is run. The IsIntable validation function assumes you have a table called processes with a field named processname. Private Sub cmdValidate_Click() Dim errorMessage As String Dim List(3) As String List(0) = "Hello" List(1) = "World" List(2) = "Utah" Call IsaNumber(txtNumber, errorMessage) Call IsaDate(txtDate, errorMessage) Call IsaListItem(txtList, errorMessage, List) Call IsInRange(txtRange, errorMessage, 3, 5) Call IsInTable(txtInTable, errorMessage, "processes", "processname", "STRING") msgbox errorMessage End Sub Purpose: Valids the user input is a number Public Sub IsaNumber(objText As TextBox, errormsg As String) On Error GoTo IsANumber_Error objText.SetFocus If IsNumeric(objText.Text) = False Then errormsg = errormsg & objText.name & ":" & objText.Text & " is not numeric " & Chr(13) & Chr(10) objText.BackColor = &HFF& Else objText.BackColor = &HFFFFFF End If Exit_IsaNumber: Exit Sub IsANumber_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsaNumber End Sub Purpose: The user input is a date Public Sub IsaDate(objText As TextBox, errormsg As String) On Error GoTo IsaDate_Error objText.SetFocus If IsDate(objText.Text) = False Then errormsg = errormsg & objText.name & ":" & objText.Text & " is not a date " & Chr(13) & Chr(10) objText.BackColor = &HFF& Else objText.BackColor = &HFFFFFF End If Exit_IsaDate: Exit Sub IsaDate_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsaDate End Sub Purpose: A list of valid choices are checked against the users input. The text comparison is not case sensitive. Public Sub IsaListItem(objText As TextBox, errormsg As String, List() As String) On Error GoTo IsaListItem_Error Dim sValue Dim i Dim bFound objText.SetFocus sValue = objText.Value bFound = False For i = 0 To UBound(List) - 1 If ucase(List(i)) = ucase(sValue) Then bFound = True Exit For End If Next If bFound = False Then errormsg = errormsg & objText.name & ":" & objText.Text & " is not a valid entry " & Chr(13) & Chr(10) objText.BackColor = &HFF& Else objText.BackColor = &HFFFFFF End If Exit_IsaListItem: Exit Sub IsaListItem_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsaListItem End Sub Purpose: The user input is a numeric value within a certain upper and lower range. Public Sub IsInRange(objText As TextBox, errormsg As String, _ lowerlimit As Integer, upperlimit As Integer) On Error GoTo IsInRange_Error Dim sValue objText.SetFocus Call IsaNumber(objText, errormsg) If IsNull(objText.Value) Then sValue = 0 Else sValue = objText.Value End If If sValue < lowerlimit Or sValue > upperlimit Then errormsg = errormsg & objText.name & ":" & objText.Text & " is not in range " & Chr(13) & Chr(10) objText.BackColor = &HFF& Else objText.BackColor = &HFFFFFF End If Exit_IsInRange: Exit Sub IsInRange_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsInRange End Sub Purpose: The user input is a field value for an access 2000 table. Usually, a bound combo box is used to select a valid field value. However, you may have a need to check for valid database matching. Public Sub IsInTable(objText As TextBox, errormsg As String, tablename As String, _ fieldname As String, datetype As String) On Error GoTo IsInTable_Error Dim sValue Dim rs Dim sql Dim bFound objText.SetFocus sValue = objText If datetype = "STRING" Then sql = "select * from " & tablename & " where ucase(" & fieldname & ")=" & IsNVLString(UCase(sValue)) ElseIf datetype = "DATE" Then Call IsaDate(objText, errormsg) sql = "select * from " & tablename & " where " & fieldname & "=" & IsNVLDate(sValue) ElseIf datetype = "NUMERIC" Then Call IsaNumber(objText, errormsg) sql = "select * from " & tablename & " where " & fieldname & "=" & IsNVLNumber(sValue) End If Set rs = CurrentDB().OpenRecordset(sql) bFound = False If Not rs.EOF Then bFound = True End If rs.Close Set rs = Nothing If bFound = False Then errormsg = errormsg & objText.name & ":" & objText.Text & " is not in table " & Chr(13) & Chr(10) objText.BackColor = &HFF& Else objText.BackColor = &HFFFFFF End If Exit_IsInTable: Exit Sub IsInTable_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsInTable End Sub Purpose: Returns a single quote enclosed string with embedded single quotes being converted into double single quotes. If the parameter is an empty string than return a null. Function IsNVLString(parameter) On Error GoTo IsNVLString_Error If IsNull(parameter) Or parameter = "" Then IsNVLString = "Null" GoTo Exit_IsNVLString End If IsNVLString = "'" & FixApostrophy(parameter) & "'" Exit_IsNVLString: Exit Function IsNVLString_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsNVLString End Function Purpose: Return either a number or a null. Function IsNVLNumber(parameter) On Error GoTo IsNVLNumber_Error If IsNull(parameter) Or parameter = "" Then IsNVLNumber = "Null" GoTo Exit_IsNVLNumber End If IsNVLString = parameter Exit_IsNVLNumber: Exit Function IsNVLNumber_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsNVLNumber End Function Purpose: Return a # enclosed string if the user data is a date type or null if the parameter is empty. Function IsNVLDate(parameter) On Error GoTo IsNVLDate_Error If IsNull(parameter) Or parameter = "" Then IsNVLDate = "Null" GoTo Exit_IsNVLDate End If IsNVLDate = "#" & parameter & "#" Exit_IsNVLNumber: Exit Function IsNVLNumber_Error: #If gnDebug Then Stop Resume #End If msgbox Err.Description & ":" & Err.Number Resume Exit_IsNVLNumber End Function Purpose: Replace each single quote with two single quotes. Public Function FixApostrophy(ByVal sSQL As String) Dim sFront$, sBack$, nParamLen% Dim sPhrase As String Dim wLength As Integer Dim i As Integer On Error GoTo FixApostrophy_Error wLength = Len(sSQL) For i = 1 To wLength If Mid$(sSQL, i, 1) = "'" Then sPhrase = sPhrase + "''" Else sPhrase = sPhrase + Mid$(sSQL, i, 1) End If Next FixApostrophy = sPhrase Exit_FixApostrophy: Exit Function FixApostrophy_Error: #If gnDebug Then Stop Resume #End If 'Standard error handling statement msgbox Err.Description & ":" & Err.Number Resume Exit_FixApostrophy End Function