Microsoft Access 2000 How To's Series - Page 6

Access 2000 Data Validation

This article details how to create your own Access 2000 validation routines. While Access 2000 has its own validation rules that you can create for each control, I've found it easier to use Visual Basic techniques to validate 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 use these routines to validate 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 built-in validation rules in Access.

Objective: To be able to determine if the user input is a valid number, a date, in a list, within a number range, or a field value in a table.

Basic Setup

1. One command button named "cmdValidate"
2. Five text boxes:

a. txtNumber
b. txtDate
c. txtList
d. txtRange
e. txtInTable

Code

Option Explicit
Option Compare Database

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

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

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

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

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

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

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

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

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

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

Next Access "How To": Access Tree View and List Box Row Source

Back to Access 2000 How To's Series Home