MS Access - Active Directory 角色成员资格

介绍...

这是一个 VBA 模块，仅用于递归获取当前用户的全部 Active Directory 角色。它会在首次被用户请求时缓存角色列表。只有在用户重新打开数据库后，才会获取更新的角色列表。

代码...

• 步骤 1：创建一个新的模块。你可以随意命名它。
• 步骤 2：在 VB 编辑器中：工具 > 引用 > 添加引用“Microsoft Scripting Runtime”。
• 步骤 3：粘贴下面的代码。
• 步骤 4：更新 RootPath 常量，以指示你的 Active Directory 域。例如，如果你在 colinbashbash.edu 工作，它可以是 "LDAP://dc=colinbashbash,dc=edu"。
• 步骤 5：要使用，只需访问 UserRoles 属性即可。

注意：如果需要，可以添加错误处理。在测试期间，EnumGroups 函数有时会抛出错误，所以我只是将其设置为 On Error Resume Next。这可能可以删除。

Option Compare Database

Declare Function wu_GetUserName Lib "advapi32.dll" _
        Alias "GetUserNameA" (ByVal lpbuffer As String, _
                              nSize As Long) As Long
Declare Function wu_GetComputerName Lib "kernel32" _
        Alias "GetComputerNameA" (ByVal lpbuffer As String, _
                                  nSize As Long) As Long

Private objGroupList As Scripting.Dictionary

'***********************
'SET YOUR ROOT PATH HERE
'no really, it's a good idea
'***********************
Private Const RootPath As String = "LDAP://dc=YOUR_DOMAIN_HERE,dc=com"

'*******************************************
'HERE'S THE ONLY PUBLIC THING IS THIS MODULE
'*******************************************
Public Property Get UserRoles() As Scripting.Dictionary
    If objGroupList Is Nothing Then DoGetUserGroups
    Set UserRoles = objGroupList
End Property

Private Function GetCurrentUserName() As String
    Dim strUserName As String, lngResult As Long
    strUserName = String$(255, 0)
    lngResult = wu_GetUserName(strUserName, 255)
    GetCurrentUserName = Left(strUserName, InStr(1, strUserName, Chr(0)) - 1)
End Function

Private Sub DoGetUserGroups()
    Dim objUser As Object
    Dim path As String
    
    path = GetLDAPPathFromUserName(GetCurrentUserName)
    Set objUser = GetObject(path)
    
    ' Bind to dictionary object.
    Set objGroupList = CreateObject("Scripting.Dictionary")
    objGroupList.CompareMode = vbTextCompare
    
    ' Enumerate group memberships.
    Call EnumGroups(objUser)
    
    ' Clean up.
    Set objUser = Nothing
End Sub

Private Sub EnumGroups(ByVal objADObject)
    On Error Resume Next
    ' Recursive subroutine to enumerate user group memberships.
    ' Includes nested group memberships.
    Dim colstrGroups, objGroup, j
    
    colstrGroups = objADObject.memberOf
    If (IsEmpty(colstrGroups) = True) Then
        Exit Sub
    End If
    If (TypeName(colstrGroups) = "String") Then
        ' Escape any forward slash characters, "/", with the backslash
        ' escape character. All other characters that should be escaped are.
        colstrGroups = Replace(colstrGroups, "/", "\/")
        Set objGroup = GetObject("LDAP://" & colstrGroups)
        If (objGroupList.Exists(objGroup.sAMAccountName) = False) Then
            objGroupList.Add objGroup.sAMAccountName, True
            Call EnumGroups(objGroup)
        End If
        Set objGroup = Nothing
        Exit Sub
    End If
    For j = 0 To UBound(colstrGroups)
        ' Escape any forward slash characters, "/", with the backslash
        ' escape character. All other characters that should be escaped are.
        colstrGroups(j) = Replace(colstrGroups(j), "/", "\/")
        Set objGroup = GetObject("LDAP://" & colstrGroups(j))
        If (objGroupList.Exists(objGroup.sAMAccountName) = False) Then
            objGroupList.Add objGroup.sAMAccountName, True
            Call EnumGroups(objGroup)
        End If
    Next
    Set objGroup = Nothing
End Sub

Private Function GetLDAPPathFromUserName(UserName As String) As String
    'Note: Code to search Active Directory given the user login name.
    
    Const ADS_SCOPE_SUBTREE = 2
    
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rs As ADODB.Recordset
    
    conn.Provider = "ADsDSOObject"
    conn.Open "Active Directory Provider"
    Set cmd.ActiveConnection = conn
    
    cmd.Properties("Page Size") = 1000
    cmd.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    cmd.CommandText = "SELECT AdsPath FROM '" & RootPath & _
        "' WHERE objectCategory='user' And sAMAccountName = '" & UserName & "'"
    
    Set rs = cmd.Execute
    
    If Not rs.EOF And Not rs.BOF Then
        rs.MoveFirst
        GetLDAPPathFromUserName = rs("Adspath").Value
    End If
    rs.Close
End Function

示例...

Function UserIsCookieEatingAdmin() As Boolean
    UserIsCookieEatingAdmin = UserRoles.Exists("CookieEatingAdmin")
End Function
Function UserIsInRole(RoleName as String) As Boolean
    UserIsInRole = UserRoles.Exists(RoleName)
End Function
Function GetRoleList() As String
    Dim item As String
    GetRoleList = ""
    For Each item in UserRoles.Items
       GetRoleList = GetRoleList & item & ", "
    Next
End Function

来源...

我从以下来源（如下所示）提取了一些信息，还有一些来自我们库中现有的代码，并且实际上我自己写了 1 或 2 行代码。

• http://www.dbforums.com/6296643-post48.html
• GetLDAPPathFromUserName 基于此来源
• http://www.rlmueller.net/List%20User%20Groups.htm
• DoGetUserGroups 基于此来源
• EnumGroups 来自此来源