Question

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

例如，如果用户在GroupA中，并且Group_A的所有成员都在Group_B中，我需要知道用户是否在Group_B中，他们是在Group_A中。这就是我现在拥有的： **** EDIT在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

结束功能

Answer 1

好的，我通过MS得到了解决方案。我在Access窗体上有一些代码，它将Group名称传递给一个存在于Module中的函数。该函数遍历用户所属的所有组，并遍历传入的组中的任何组。如果用户是组的成员或者是作为传递的成员的组的成员，则返回true。在集团。

表格代码：

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

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

Public strOut As String
Public objGroupList, objUser

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代码：

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

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

1 个答案: