如何在 MS Access VBA 中迭代活动目录组（角色）

How to iterate active directory groups (roles) in MS Access VBA

提问by Alan Fisher

I have some code which will return true if a user is in a specific group that I pass in, however if the user is in another group that is part of the goroup I'm passing in, the function will return false. I need to be able to iterate through the groups to see if the user may be a member of a group that is in the group I'm interested in.

如果用户在我传入的特定组中，我有一些代码将返回 true，但是如果用户在我传入的组中的另一个组中，该函数将返回 false。我需要能够遍历组以查看用户是否可能是我感兴趣的组中的组的成员。

So as an example, if a user is in GroupA and all members of Group_A are in Group_B and I need to know if the user is in Group_B, which they are by being in Group_A. Here is what I have now: ****EDIT added function GetCurrentUser used in IsUserInRole()

举个例子，如果一个用户在 GroupA 中，而 Group_A 的所有成员都在 Group_B 中，我需要知道用户是否在 Group_B 中，他们在 Group_A 中。这是我现在所拥有的：****编辑在 IsUserInRole() 中使用的添加函数 GetCurrentUser

Public Function GetCurrentUser() As String
    GetCurrentUser = Environ("USERNAME")
End Function

Public Function IsUserInRole(role) As Boolean
Dim UserObj As Object
Dim GroupObj As Object

Dim strObjectString As String
strObjectString = "WinNT://my domain/" & GetCurrentUser() & ""
Set UserObj = GetObject(strObjectString)

For Each GroupObj In UserObj.Groups

Debug.Print GroupObj.Name

   If GroupObj.Name = role Then
        IsUserInRole = True
        Exit Function
   End If
Next

End Function

结束函数

回答by Alan Fisher

Ok, I got a solution to this through MS. I have some code on the Access Form that passes a Group name into a function that lives in a Module. The function iterates through all the Groups the user is a member of and itereates through any Groups within the Group passed in. It returns true if the user is a member of the Group or is a member of a Group that is a member of the passed in Group.

好的，我通过 MS 得到了解决方案。我在访问表单上有一些代码，它将组名传递给位于模块中的函数。该函数遍历用户所属的所有组，并遍历传入的组内的任何组。如果用户是该组的成员或属于传递的组的成员，则返回 true在集团。

Code on Form:

表格代码：

strGroup = "_System Admin"
If IsCurrentUserInGroup(strGroup) = True Then
    MsgBox "In System Admin"
End If

Declared Public variables at top of Module:

在模块顶部声明的公共变量：

Public strOut As String
Public objGroupList, objUser

IsCurrentUserInGroup Code:

IsCurrentUserInGroup 代码：

Function IsCurrentUserInGroup(ByVal strGroup) As Boolean

Dim objSysInfo As Object
Dim strDN As String

'Get currentlly logged in users info
Set objSysInfo = CreateObject("ADSystemInfo")
strDN = objSysInfo.UserName

On Error Resume Next
Set objUser = GetObject("LDAP://" & strDN)
If (Err.Number <> 0) Then
   On Error GoTo 0
   MsgBox "User not found" & vbCrLf & strDN

End If
On Error GoTo 0

' Bind to dictionary object.
Set objGroupList = CreateObject("Scripting.Dictionary")

' Enumerate group memberships.
If EnumGroups(objUser, "", strGroup) = True Then
    IsCurrentUserInGroup = True
Else
    IsCurrentUserInGroup = False
End If

End Function    

EnumGroups Code:

枚举组代码：

Public Function EnumGroups(ByVal objADObject, ByVal strOffset, ByVal strGroup) As Boolean
' Recursive subroutine to enumerate user group memberships.
' Includes nested group memberships.
Dim colstrGroups, objGroup, j
objGroupList.CompareMode = vbTextCompare
colstrGroups = objADObject.memberOf
If (IsEmpty(colstrGroups) = True) Then
    Exit Function
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
         strOut = strOut + strOffset & objGroup.distinguishedName + Chr(13) + Chr(10)
        Call EnumGroups(objGroup, strOffset & "--", "")
    Else
        strOut = strOut + strOffset + strOffset & objGroup.distinguishedName & " (Duplicate)" + Chr(13) + Chr(10)
    End If
    Exit Function
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
        If objGroup.sAMAccountName = strGroup Then
            EnumGroups = True                 
        End If
        objGroupList.Add objGroup.sAMAccountName, True
        strOut = strOut + strOffset & objGroup.distinguishedName + Chr(13) + Chr(10)
        Call EnumGroups(objGroup, strOffset & "--", "")
    Else
        strOut = strOut + strOffset & objGroup.distinguishedName & " (Duplicate)" + Chr(13) + Chr(10)
    End If
Next
End Function