Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo ErrHandler
Dim rst As Recordset
Dim strSQL As String
Dim strMsg As String
Dim IntCount As Integer
Dim rply As VbMsgBoxResult
Const MAX As Integer = 10
If ValidateUserEntries = False Then
Cancel = True
MsgBox "Please enter all required fields!", vbExclamation, "Update Warning"
Exit Sub
End If
strSQL = "SELECT [TransID], [Date of Service], [Amount], [Medical Provider] FROM" & _
" [TableName] WHERE" & _
" [Date of Service]=#" & Me!txtDate & "#" & _
" AND [Amount]=" & Me!txtAmount & _
" AND [Medical Provider]='" & Me!txtProvider & "'"
Set rst = CurrentDb().OpenRecordset(strSQL, dbOpenSnapshot)
'build a message to display if duplicates found.
'if large number of records found, truncate the
'message so it fits on a message box:
While Not (rst.EOF Or (IntCount > MAX))
strMsg = strMsg & "Transaction " & rst("TransID") & _
" already entered for " & rst("Date of Service") & vbCrLf
rst.MoveNext
IntCount = IntCount + 1
Wend
If IntCount > MAX Then
strMsg = strMsg & "Continued..." & vbCrLf
End If
If Len(strMsg) > 0 Then
rply = MsgBox(strMsg & vbCrLf & "Proceed anyway?", vbQuestion + vbOKCancel, "Duplicate Entries")
Select Case rply
Case VbMsgBoxResult.vbOK
'proceed with update
Case VbMsgBoxResult.vbCancel
Cancel = True
End Select
End If
ExitHere:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Sub
ErrHandler:
Debug.Print Err, Err.Description
Resume ExitHere
End Sub