快速开发窗体字段唯一值检查函数|自定义函数CheckUnique

时　间:2013-12-05 09:25:02
作　者:Aaron   ID：20267  城市：闵行
摘　要:'//函数名：CheckUnique
'//函数功能:对编辑窗体中设定了唯一值规则的字段进行检查
'//输入参数：
正　文:

//***************************************************************
'//函数名：CheckUnique
'//函数功能:对编辑窗体中设定了唯一值规则的字段进行检查
'//输入参数：
'//                DataEditObject：需要进行检查的窗体或子窗体,Object类型
'//                TableName：编辑窗体所对应的表的名称，String类型
'//输出：
'//         True:所有的设定了唯一值规则的字段内容没有重复
'//         False:一个或多个设定了唯一值规则的字段内容有重复，并所有将有重复的字段标签弹以警告对话框
'//                   方式输出
'//使用限制:
'//               (1)表中主键必须是ID
'//               (2)字段一般为文本型字段，因为数字和日期型字段检查重复情况的时候较少
'//               (3)窗体中控件的名字与字段名要相同
'//               (4)窗体中控件的Tag属性中要包含文本
'//               (5)如果出现系统错误，函数将返回True,以保证程序向下运行

Public Function CheckUnique(DataEditObject As Object, TableName As String) As Boolean
    Dim objControl As Object
    Dim strFieldName As String
    Dim strCritical As String
    Dim strErrMessage As String
    Dim txtControl As TextBox
    Dim lngCurrentID As Long
    Dim lngQueryID As Long
    Dim lngDuplicates As Long

    On Error GoTo ErrorHandler
    '//初始化
    CheckUnique = True
    lngCurrentID = Nz(DataEditObject![ID], 0)    '//对于新增加的记录当前无ID值,所以取ID＝0
    '//遍历控件，找出需要验证唯一规则的控件
    For Each objControl In DataEditObject.Controls
        If InStr(1, objControl.Tag, "", vbTextCompare) > 0 Then
            Set txtControl = objControl
            '//空值不检验
            If IsNull(txtControl) Then
                GoTo NextControl
            End If
            strFieldName = txtControl.Name    '//字段名
            strCritical = strFieldName & "='" & txtControl & "' AND ID<>" & lngCurrentID    '//查找条件
            lngDuplicates = DCount("ID", TableName, strCritical)
            If lngDuplicates > 0 Then
                objControl.SetFocus
                CheckUnique = False
                strErrMessage = strErrMessage & objControl.Controls(0).Caption & "不能重复！" & vbCrLf
            End If
        End If
NextControl:
    Next
    If Not CheckUnique Then
        If Len(strErrMessage) > 0 Then
            MsgBox strErrMessage, vbCritical, "提示"
        End If
    End If
ExitHere:
    Set txtControl = Nothing
    Exit Function
ErrorHandler:
    MsgBoxEx Err.Description, vbCritical
    CheckUnique = True '//防止程序出现错误时，可以继续执行
    GoTo ExitHere
End Function