Results 1 to 3 of 3
  1. #1
    ThornofSouls's Avatar
    ThornofSouls is offline Advanced Beginner
    Windows 7 64bit Access 2013
    Join Date
    Aug 2015
    Location
    Sweden, Gothenburg
    Posts
    42

    Question My code throws error 424. How do i work around this?

    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

  2. #2
    ranman256's Avatar
    ranman256 is online now VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    It means an object did not get created.
    prob. col1
    you assign it .ADD
    but did not define it. I suspect its a collection,
    do DIM COL1 AS NEW COLLECTION

  3. #3
    ThornofSouls's Avatar
    ThornofSouls is offline Advanced Beginner
    Windows 7 64bit Access 2013
    Join Date
    Aug 2015
    Location
    Sweden, Gothenburg
    Posts
    42
    Thx ranman256, it did the trick!

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 6
    Last Post: 01-29-2014, 08:03 AM
  2. Code Does not work
    By larabeelw in forum Access
    Replies: 11
    Last Post: 11-27-2013, 03:18 PM
  3. vba code dont work
    By mikichi in forum Programming
    Replies: 7
    Last Post: 11-12-2013, 01:59 PM
  4. VBA code used to work now it does not
    By rachello89 in forum Programming
    Replies: 9
    Last Post: 06-15-2012, 08:48 AM
  5. Replies: 1
    Last Post: 03-07-2012, 02:00 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums