Add records with loop and display custom error message for err:3022 1

[sterlecki]

I am adding records chosen from as list box to a table using a command button. Inevitably users will try to add duplicates to this table. The table uses a dual key of API and ContactName.

When I try to create my own message box to replace the error message for err 3022 the code hangs on [highlight].update [/highlight]and does NOT got to my err handler. What's wrong here and what is the fix?

Private Sub cmd_AddWellContacts_Click()
On Error GoTo Err_cmd_AddWellContacts_Click

Dim API As String
Dim db As DAO.Database
Dim rs As DAO.Recordset

Dim item As Integer
Dim Cri, LBx As ListBox, itm, Build As String, DQ As String
   
   Set LBx = Forms![Main Form]![lst_SelectWellContacts]
   Set db = CurrentDb
   Set rs = db.OpenRecordset("data_WellContacts")
       
  

   
   With rs
        
        For Each itm In LBx.ItemsSelected
        .AddNew
        !API = API
        !Contacts_ID = LBx.Column(0, itm)
        !ContactPosition = LBx.Column(1, itm)
        !ContactName = LBx.Column(2, itm)
        !ContactInitials = LBx.Column(3, itm)
        !ContactWorkPhone = LBx.Column(4, itm)
        !ContactCellPhone = LBx.Column(5, itm)
        !ContactHomePhone = LBx.Column(6, itm)
        !ContactEmail = LBx.Column(7, itm)
        !OperationsGroup = LBx.Column(8, itm)
        !DateCreated = Now()
        !UserCreated = fOSUserName()
        [highlight].Update 'hangs here[/highlight]
        .Bookmark = rs.LastModified
    Next
    End With
    rs.Close
    Me.Refresh
    Forms![Main Form]![frm_Wellcontacts subform].Form.Requery

'
Exit_cmd_AddWellContacts_Click:
    Set db = Nothing
    Exit Sub

Err_cmd_AddWellContacts_Click:
    MsgBox Err.Description
    
    Select Case Err.Number
        Case 3022
        MsgBox (Err.Number & "One or More of your Selections are Already Contacts for the Selected Well" _
                & "Please Edit Contact Selection and Try Again!")

        MsgBox Err & vbCrLf & Error$, , "Error"

        End Select


    Resume Exit_cmd_AddWellContacts_Click
    
End Sub

 

[Remou]

It would probably be best to avoid the error:

   Set rs = db.OpenRecordset("data_WellContacts")
       
     
   With rs
        
        For Each itm In LBx.ItemsSelected
         .FindFirst "API='" & API _
            & "' ContactName = '" & LBx.Column(2, itm) & "'"
        
        If rs.NoMatch Then
          .AddNew
          !API = API
          !Contacts_ID = LBx.Column(0, itm)
          !ContactPosition = LBx.Column(1, itm)
          !ContactName = LBx.Column(2, itm)
          <...>
        Else
          MsgBox "API='" & API _
            & "' ContactName = '" & LBx.Column(2, itm) _
            & "' Previously entered record"
        End If

http://lessthandot.com

 

[LaDeana1]

Try adding .edit just before you loop and after the with statement.

 

[sterlecki]

Remou,

Tried your suggestion. got an error 3251 "Operation Not supported for this type of object." The debugger highlighted at:

.FindFirst "API='" & API _
& "' ContactName = '" & LBx.Column(2, itm) & "'

 

[sterlecki]

Thanks Remou for getting me on the right track!

Got it! Needed to use the Seek method.

Dim item As Integer
Dim Cri, LBx As ListBox, itm, Build As String, DQ As String
   
   Set LBx = Forms![Main Form]![lst_SelectWellContacts]
   Set db = CurrentDb
   Set rs = db.OpenRecordset("data_WellContacts")
       
  

   
   With rs
        
        For Each itm In LBx.ItemsSelected
        
        [highlight].Index = "PrimaryKey"
        .Seek "=", LBx.Column(0, itm), API[/highlight]
        
  If rs.NoMatch Then
        .AddNew
        !API = API
        !Contacts_ID = LBx.Column(0, itm)
        !ContactPosition = LBx.Column(1, itm)
        !ContactName = LBx.Column(2, itm)
        !ContactInitials = LBx.Column(3, itm)
        !ContactWorkPhone = LBx.Column(4, itm)
        !ContactCellPhone = LBx.Column(5, itm)
        !ContactHomePhone = LBx.Column(6, itm)
        !ContactEmail = LBx.Column(7, itm)
        !OperationsGroup = LBx.Column(8, itm)
        !DateCreated = Now()
        !UserCreated = fOSUserName()
        .Update
        .Bookmark = rs.LastModified
    Else
         MsgBox "API='" & API _
            & "' ContactName = '" & LBx.Column(2, itm) _
            & "' Previously entered record"
    End If
    Next
    End With
    rs.Close
    Me.Refresh
    Forms![Main Form]![frm_Wellcontacts subform].Form.Requery

'
Exit_cmd_AddWellContacts_Click:
    Set db = Nothing
    Exit Sub

Err_cmd_AddWellContacts_Click:
    MsgBox Err.Description