weAscend.com

Function fUnique(Optional intCombo As Integer, _

Optional strTable As String, Optional strSubForm As String) As Boolean

'*******************************************
'Name: fUnique (Function)
'Purpose: Test for duplicate combination of fields
'Author: Michael Blake
'Contact: www.weAscend.com
'Date: September 05, 2000, 02:26:03 PM
'Called by: Any form on the Before Update event
'Calls: None
'Inputs: Optional intCombo - Allows for different scenarios
' Optional strTable - If form is based on query
' instead of a table then this
' needs to be defined.
' NOTE: This is required if
' there is a subform.
' Optional strSubForm - If validation occurs in a subform.
' NOTE: Can not be used if the subform
' is on another subform.
'Output: Boolean - True if record is unique,
' False if record exists already
'
'Notes:
'
'The following table has to exist in the DB:
'
' tblUnique
' ---------
' TableName (PK) - Text
' TableField (PK) - Text
' Combo (PK) - Number
'
'Enter the table and each field that together
'MUST be unique. The field named Combo is used to create
'more than one set of combinations for a table.
'The default value for Combo is zero.
'
'Use this function in the Before Update event
'of a form. If the result is False then display
'a message box to alert the user that there is
'a duplicate entry. Use Cancel = True to
'prevent the record from being updated.
'
' Example:
'
' If Not (fUnique(0, "tblTable", "sfSubForm")) Then
' If MsgBox("Duplicate values entered. Do you want to create duplicates?" _
' , vbYesNo, "Duplicate Entries") = vbNo Then
' Cancel = True
' Me.Undo
' End If
' End If
'
'Please keep the previous comments intact when
'using this code. Report any bugs that you encounter.
' - Thank you
'*******************************************

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsUnique As DAO.Recordset
Dim rsTest As DAO.Recordset
Dim strSQLUnique As String
Dim strCriteria As String
Dim strSQL As String
Dim strForm As String
Dim strError As String
Dim ctlControl As Control
Dim i As Integer
Dim intCount As Integer
Dim intFieldCount As Integer
Dim strQuote(25) As String

On Error GoTo Error_Handler

strQuote(10) = Chr(34)
strQuote(12) = Chr(34)
strQuote(8) = "#"
strQuote(3) = ""
strQuote(7) = ""


strForm = Screen.ActiveForm.Name

If Len(strTable) = 0 Then strTable = Forms(strForm).RecordSource

strSQL = "SELECT * FROM tblUnique WHERE ([tblUnique].[TableName] = " _
& Chr(34) & strTable & Chr(34) & " And [tblUnique].[Combo] = " & intCombo & ")"

strSQLUnique = "SELECT * FROM " & strTable
strCriteria = " WHERE ("
intFieldCount = 0

Set db = CurrentDb()
Set rs = db.OpenRecordset(strTable)
Set rsUnique = db.OpenRecordset(strSQL)

With rsUnique
If Not (.BOF And .EOF) Then
.MoveLast
.MoveFirst

If Len(strSubForm) > 0 Then
For intCount = 1 To .RecordCount
i = 0
For Each ctlControl In Forms(strForm).Controls(strSubForm).Form
If Forms(strForm).Controls(strSubForm).Form.Controls(i).ControlType = acTextBox _
Or Forms(strForm).Controls(strSubForm).Form.Controls(i).ControlType = acComboBox _
Or Forms(strForm).Controls(strSubForm).Form.Controls(i).ControlType = acListBox Then
If Forms(strForm).Controls(strSubForm).Form.Controls(i).ControlSource = !TableField Then
strCriteria = strCriteria & !TableField & _
IIf(IsNull(Forms(strForm).Controls(strSubForm).Form.Controls(i)), " Is Null", " = " & strQuote(rs(!TableField).Type) _
& Forms(strForm).Controls(strSubForm).Form.Controls(i) & strQuote(rs(!TableField).Type)) & " And "
intFieldCount = intFieldCount + 1
End If
End If
i = i + 1
Next
.MoveNext
Next intCount
Else
For intCount = 1 To .RecordCount
i = 0
For Each ctlControl In Forms(strForm)
If Forms(strForm).Controls(i).ControlType = acTextBox _
Or Forms(strForm).Controls(i).ControlType = acComboBox _
Or Forms(strForm).Controls(i).ControlType = acListBox Then
If Forms(strForm).Controls(i).ControlSource = !TableField Then
strCriteria = strCriteria & !TableField & _
IIf(IsNull(Forms(strForm).Controls(i)), " Is Null", " = " & strQuote(rs(!TableField).Type) _
& Forms(strForm).Controls(i) & strQuote(rs(!TableField).Type)) & " And "
intFieldCount = intFieldCount + 1
End If
End If
i = i + 1
Next
.MoveNext
Next intCount
End If
Else
GoTo Error_Handler
End If
If Not (intFieldCount = .RecordCount) Then GoTo Error_Control
End With

strCriteria = Left(strCriteria, Len(strCriteria) - 5) & ")"
strSQLUnique = strSQLUnique & strCriteria

Set rsTest = db.OpenRecordset(strSQLUnique)

fUnique = (rsTest.BOF And rsTest.EOF)

Exit_Function:
Set rs = Nothing: Set rsUnique = Nothing: Set rsTest = Nothing: Set db = Nothing
Exit Function

Error_Handler:
fUnique = True
GoTo Exit_Function

Error_Control:
strError = "Form design error:" & vbCrLf
strError = strError & "Contact the administrator of this database" & vbCrLf
strError = strError & "The number of fields on this form matching the number of fields in tblUnique are incongruent. "
strError = strError & "Check to make sure the control sources are named properly and that the form is not based on a query. "
strError = strError & "Also make sure that the controls match the fields in tblUnique."
Call MsgBox(strError, vbOKOnly, "Function fUnique Error")
GoTo Error_Handler

End Function

 

Contact Us