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
Private Const RootPath As String = "LDAP://dc=YOUR_DOMAIN_HERE,dc=com"
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)
Set objGroupList = CreateObject("Scripting.Dictionary")
objGroupList.CompareMode = vbTextCompare
Call EnumGroups(objUser)
Set objUser = Nothing
End Sub
Private Sub EnumGroups(ByVal objADObject)
On Error Resume Next
Dim colstrGroups, objGroup, j
colstrGroups = objADObject.memberOf
If (IsEmpty(colstrGroups) = True) Then
Exit Sub
End If
If (TypeName(colstrGroups) = "String") Then
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)
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
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.