David Nishimoto
davepamn@relia.net
Article: Creating your own Access2000 validation routines

Overview: This article explains how to create your own Access 2000 validation routines.Access2000 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