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