如何使用VBA校验Access数据库Team列值在Active Directory中是否有效

1. 核心AD查询函数实现 #

该函数用于校验输入的团队值是否存在于AD的office属性列表中，采用晚绑定无需额外添加引用：

Function isTeamExistInAD(teamName As String) As Boolean
    Dim conn As Object, cmd As Object, rs As Object
    Dim domainDN As String
    
    ' 获取当前域的根路径
    Set conn = CreateObject("ADODB.Connection")
    Set cmd = CreateObject("ADODB.Command")
    conn.Provider = "ADsDSOObject"
    conn.Open "Active Directory Provider"
    Set cmd.ActiveConnection = conn
    
    ' 构造LDAP查询，过滤office属性等于传入的团队值的对象
    ' 如果团队值存储在AD组对象中，可将objectClass=user修改为objectClass=group
    cmd.CommandText = "<LDAP://rootDSE>;distinguishedName;(&(objectClass=user)(office=" & Replace(teamName, "'", "\'") & "));subtree"
    Set rs = cmd.Execute
    
    ' 查询结果非空则说明该团队值存在
    isTeamExistInAD = Not rs.EOF
    
    ' 释放资源
    rs.Close
    conn.Close
    Set rs = Nothing
    Set cmd = Nothing
    Set conn = Nothing
End Function

2. 修正单条记录校验逻辑 #

原代码错误点在于不能直接遍历字符串，校验函数需先调用正则校验格式，再调用AD查询校验存在性：

Function checkTeam(teamStr As String) As Boolean
    ' 第一步：先调用你已有的正则函数校验格式，这里的正则规则替换为你实际用的规则
    Dim formatValid As Boolean
    formatValid = (regexp(teamStr, "^[A-Z]{2,3}\d{1,2}$") <> "") ' 示例正则，替换为你的实际规则
    
    If Not formatValid Then
        checkTeam = False
        Exit Function
    End If
    
    ' 第二步：格式合法则查询AD是否存在该团队
    checkTeam = isTeamExistInAD(teamStr)
End Function

3. 批量遍历表记录完成校验 #

该主函数可直接遍历你存储数据的表，自动过滤无效记录，你需要替换代码中的表名、字段名：

Sub filterValidTeamRecords()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim validFlag As Boolean
    
    Set db = CurrentDb
    ' 替换为你实际的表名
    Set rs = db.OpenRecordset("你的表名", dbOpenDynaset)
    
    If rs.EOF And rs.BOF Then
        MsgBox "表中无记录"
        rs.Close
        Set rs = Nothing
        Set db = Nothing
        Exit Sub
    End If
    
    rs.MoveFirst
    Do While Not rs.EOF
        ' 替换为你实际的Team字段名
        validFlag = checkTeam(Nz(rs!Team, ""))
        If validFlag Then
            ' 有效记录保留，直接跳过
            rs.MoveNext
        Else
            ' 无效记录删除
            rs.Delete
            rs.MoveNext
        End If
    Loop
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    MsgBox "校验完成，已移除所有无效团队记录"
End Sub

注意事项 #

• 运行代码的设备需要加入域，且当前登录用户具备AD普通只读权限（默认域用户都有该权限）
• 正则规则请替换为你实际使用的校验规则，示例仅作参考
• 执行删除操作前建议先备份原表数据，避免误删

内容的提问来源于stack exchange，提问作者SHA-256