MS Access - Active Directory Role Membership

Introducing...

This is a VBA module to recursively get all Active Directory Roles for the current user only. It caches the role list the first time it is requested by a user. It will only get the updated list for a user after they reopen the database.

The code...

• Step 1: Create a new module. You can call it whatever you like.
• Step 2): In the VB editor: Tools > References > add the reference "Microsoft Scripting Runtime".
• Step 3: Paste the code from below.
• Step 4: Update the RootPath constant to indicate your Active Directory domain. So if you were working for colinbashbash.edu, it could be "LDAP://dc=colinbashbash,dc=edu".
• Step 5: To use, just access the UserRoles property.

Note: Add error handling if you like. While testing, the EnumGroups function was throwing errors sometimes, so I just set it to On Error Resume Next. That can probably be removed.

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

Examples...

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

Sources...

I pulled some information from these sources (below), some from some code that was currently in our library, and actually wrote 1 or 2 lines myself.

• http://www.dbforums.com/6296643-post48.html
• GetLDAPPathFromUserName based on this source
• http://www.rlmueller.net/List%20User%20Groups.htm
• DoGetUserGroups based on this source
• EnumGroups from this source