Hello, i have two forms which works as data entry forms.
The first form work just fine and the second form throws "error 424".
The error is located in private function ControlCriteria.
How come form 1 don't throw error 424, if form 2 dos when the code is more or less the same?
Form 1.
Code:
Option Compare Database
Option Explicit
Private Function addCrLf(AddValue As Integer) As String
'Convenience routine to build a concatenated string of carriage returns / line feeds
'given a specified count
Dim intCount As Integer
Dim strReturn As String
strReturn = ""
For intCount = 1 To AddValue
strReturn = strReturn & vbCrLf
Next intCount
addCrLf = strReturn
End Function
Private Function ControlCriteria()
On Error GoTo Err_Process
Dim rs As Recordset
Dim col1 As New Collection
Dim CriteriaVal As Integer 'Criteria confirms the criteria requerments are met.
Dim CritieraErr As Integer 'Fier when a expected Error is encounterd.
Dim intReturn As Integer 'Counts the amount of times the frm do not meet the criterias
Dim intResponse As Integer
Dim intStatus As Integer
Dim varCritItem As Variant
Dim varItem As Variant
Dim strMsg As String
CriteriaVal = 0
CritieraErr = -1
intReturn = 0
Set rs = CurrentDb.OpenRecordset("tblClients", dbOpenSnapshot, dbReadOnly)
rs.FindFirst "ClientID = "" & Me.txtClientID & """
If rs.NoMatch = True Then
Me.txtClientID.SetFocus
Else
CritieraErr = CritieraErr + 2
GoTo Err_Process
End If
'col1 have to meet the setren criterias
With col1
.Add Me.txtClientID
.Add Me.txtFirstName
.Add Me.txtLastName
.Add Me.txtRegisteredOf
.Add Me.txtRegisteredDate
End With
For Each varCritItem In col1
If (Not IsNull(varCritItem)) Then
CriteriaVal = CriteriaVal + 1
varCritItem.BackColor = RGB(242, 242, 242)
varCritItem.ForeColor = RGB(26, 26, 26)
Else
intReturn = intReturn + 1
varCritItem.BackColor = RGB(207, 123, 121)
varCritItem.ForeColor = RGB(26, 26, 26)
End If
Next varCritItem
'Debug.Print intReturn
Select Case intReturn
Case Is <= -1
Me.Undo
DoCmd.Close acForm, Me.Name
CritieraErr = CritieraErr + 3
GoTo Err_Process
Case Is >= 6
Me.Undo
DoCmd.Close acForm, Me.Name
CritieraErr = CritieraErr + 3
GoTo Err_Process
Case 1 To 5
'Criteria = false
GoTo Err_Process
Case 0 'All the Crierias are vailed
If (CriteriaVal = 5) Then
intStatus = saveRecord()
End If
End Select
Exit_Process:
Exit Function
Err_Process:
Select Case CritieraErr
Case 1 'Shuld fire when the user tries to enter a ID that alredy exists in the db in "tblClients/Client_ID"
Me.txtClientID.BackColor = RGB(255, 0, 0)
Me.txtClientID.ForeColor = RGB(70, 70, 70)
strMsg = "Varning: Ogitligt Personnummer." & addCrLf(2) & _
"En klient med det här personnummert existerar redan i systemet!"
intResponse = MsgBox(strMsg, vbInformation)
Case 2 'Shuld fire when intReturn hold a number that is larger or smaler the expexted.
strMsg = "Expected Error, Contat db Administator." & addCrLf(2) & _
"//Admin-Team."
intResponse = MsgBox(strMsg, vbInformation)
End Select
Resume Exit_Process
End Function
Private Function saveRecord() As Integer
'Return Values:
'vbOK (1) = Save successful
'vbNo (7) = Default; could not save at this time
'vbCancel (2) = User canceled save
'vbError (10) = an unexpected error occurred in the procedure
On Error GoTo Err_Process
Dim intReturn As Integer
Dim intResponse As Integer
Dim strMsg As String
strMsg = "Du håller på att spara en ny klient, är du säker på att du vill forsätta?" & addCrLf(2) & _
"Varning; "" Avbryt"" kommer att radera o-sparade ändringar!"
intResponse = MsgBox(strMsg, vbExclamation + vbOKCancel, "Spara klient?")
If (intResponse = vbOK) Then
Me.Dirty = False
DoCmd.Close acForm, Me.Name
Else
Me.Undo
End If
intReturn = intReturn
Exit_Prcocess:
saveRecord = intReturn
Exit Function
Err_Process:
Resume Exit_Prcocess
End Function
Private Sub cmdCancle_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmdUnDo_Click()
' On Error GoTo Err_Process
Dim col1 As New Collection
Dim varItem As Variant
With col1
.Add Me.txtClientID
.Add Me.txtFirstName
.Add Me.txtLastName
.Add Me.txtRegisteredOf
.Add Me.txtRegisteredDate
End With
For Each varItem In col1
If varItem.BackColor = RGB(207, 123, 121) Then
varItem.BackColor = RGB(236, 236, 236)
varItem.ForeColor = RGB(26, 26, 26)
Me.Undo
End If
Next varItem
Me.Undo
Me.Refresh
Exit_Process:
Exit Sub
Err_Process:
Resume Exit_Process
End Sub
Private Sub cmdSave_Click()
Dim intStatus As Integer
intStatus = ControlCriteria()
End Sub
Private Sub Form_Open(Cancel As Integer)
Me.RecordSource = "tblClients"
End Sub
Private Sub cmdNext_Click()
Dim intStatus As Integer
intStatus = saveRecord()
DoCmd.OpenForm , acNormal, "", "", acFormAdd, acDialog
End Sub
Form 2.
This code throws error 424
Code:
Option Compare Database
Option Explicit
Private Function controlCerteria()
'On Error GoTo Err_Process
Dim intStatus As Integer
Dim intReturn As Integer
intReturn = 0
Dim col1 As Variant
Dim varCritItem As Variant
Dim CritieraErr As Integer
CritieraErr = -1
Dim intVal As Integer
intVal = 0
'Me.txtClientID.BackColor = RGB(0, 255, 0)
With col1
.Add Me.txtClientID
.Add Me.cboOro
.Add Me.txtOro_info
.Add Me.cboKommunkod
.Add Me.cboAnsvarig
.Add Me.txtDateAtgStart
End With
For Each varCritItem In col1
If (Not IsNull(varCritItem)) Then
varCritItem.BackColor = RGB(0, 255, 0)
Else
intReturn = intReturn + 1
varCritItem.BackColor = RGB(255, 0, 0)
End If
Next varCritItem
Debug.Print intReturn
Select Case intReturn
Case Is <= 1
Me.Undo
DoCmd.Close acForm, Me.Name
CritieraErr = CritieraErr + 3
GoTo Err_Process
Case Is >= 6
Me.Undo
DoCmd.Close acForm, Me.Name
CritieraErr = CritieraErr + 3
GoTo Err_Process
Case 1 To 6
GoTo Err_Process
Case 0
If intVal = 6 Then
intStatus = saveRecord()
End If
End Select
Exit_Process:
Exit Function
Err_Process:
Resume Exit_Process
End Function
Private Sub cmdCancle_Click()
Me.Undo
DoCmd.Close acForm, "frmErrand"
End Sub
Private Sub cmdSave_Click()
Dim intStatus As Integer
intStatus = controlCerteria()
End Sub