Last active
November 12, 2015 23:54
-
-
Save mbirth/c9fb0d6c7ce118ad5eb4 to your computer and use it in GitHub Desktop.
Queries the Active Directory (via LDAP) for users belonging to ExampleGroup or one of its subgroups. The resulting users are written into the first Excel sheet.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
' Based on a VBA script of Jim Ward | |
Sub LDAPQueryDevices() | |
Dim grouppaths(500) As String | |
Dim groupnames(500) As String | |
Dim headers2 As Variant | |
headers2 = Array("GroupName", "Name", "Login", "DN", "Group1", "Group2") | |
Const xlAscending = 1 | |
Const xlDescending = 2 | |
Const xlYes = 1 | |
'**** | |
' set up our ADO query and excute it to find group matches | |
'**** | |
Application.StatusBar = "Searching for Records..." | |
Set cmd = CreateObject("ADODB.Command") | |
Set cn = CreateObject("ADODB.Connection") | |
Set rs = CreateObject("ADODB.Recordset") | |
cn.Open "Provider=ADsDSOObject;" | |
' LDAP_MATCHING_RULE_IN_CHAIN, see http://msdn.microsoft.com/en-us/library/aa746475%28VS.85%29.aspx | |
cmd.CommandText = "SELECT adspath,cn from 'LDAP://" & getNC & _ | |
"' WHERE objectClass = 'User' and 'memberof:1.2.840.113556.1.4.1941:' = 'CN=ExampleGroup,OU=Ressources - Applications and Services,OU=Groups,OU=Administration,DC=example,DC=org'" | |
cmd.activeconnection = cn | |
Set rs = cmd.Execute | |
'**** | |
' process the results of the query into our arrays for later | |
'**** | |
i = 0 | |
While rs.EOF <> True And rs.bof <> True | |
grouppaths(i) = rs.Fields("adspath").Value | |
groupnames(i) = rs.Fields("cn").Value | |
rs.movenext | |
i = i + 1 | |
Wend | |
cn.Close | |
If i = 0 Then | |
MsgBox "Nothing Found, Exiting" | |
Exit Sub | |
End If | |
Application.StatusBar = "Records Found..." & i | |
Freeze | |
PrepareSheet 1, headers2 | |
'**** | |
' now process each group found and extract all members | |
'**** | |
ul = 1 'user lines | |
Dim objuser As Object | |
Application.StatusBar = "Populating Worksheets..." | |
For j = 0 To i - 1 | |
Application.StatusBar = "Writing User " & j & " of " & i | |
Set objuser = GetObject(grouppaths(j)) | |
Set objsheet = Worksheets(1) | |
ul = ul + 1 | |
objsheet.Cells(ul, 1).Value = groupnames(j) | |
objsheet.Cells(ul, 2).Value = objuser.Get("displayName") | |
objsheet.Cells(ul, 3).Value = objuser.Get("sAMAccountName") | |
objsheet.Cells(ul, 4).Value = objuser.Get("distinguishedName") | |
groups = objuser.Get("memberOf") | |
' when there's only one group in memberOf, groups is a String, otherwise it's an Array | |
objsheet.Cells(ul, 5).Value = MatchGroup(groups, "R_Type1_*") | |
objsheet.Cells(ul, 6).Value = MatchGroup(groups, "R_Type2_*") | |
Next | |
sortSheet | |
Unfreeze | |
MsgBox "All Done" | |
End Sub | |
' Returns only the CN from a complete DN | |
Function GetCN(ByVal DN As String) | |
parts = Split(DN, ",") | |
GetCN = Right(parts(0), Len(parts(0)) - 3) | |
End Function | |
' Returns the CN of a matching (wildcards!) group or empty string | |
Function MatchGroup(groups As Variant, mask As String) As String | |
If IsArray(groups) Or IsObject(groups) Then | |
For Each usergroup In groups | |
cn = GetCN(usergroup) | |
If cn Like mask Then | |
MatchGroup = cn | |
Exit Function | |
End If | |
Next | |
Else | |
cn = GetCN(groups) | |
If cn Like mask Then | |
MatchGroup = cn | |
Exit Function | |
End If | |
End If | |
MatchGroup = "" | |
End Function | |
' Checks if on of groups is expectedCN | |
Function IsInGroup(groups As Variant, expectedCN As String) As Boolean | |
If IsArray(groups) Or IsObject(groups) Then | |
For Each usergroup In groups | |
cn = GetCN(usergroup) | |
If cn = expectedCN Then | |
IsInGroup = True | |
Exit Function | |
End If | |
Next | |
Else | |
cn = GetCN(groups) | |
If cn = expectedCN Then | |
IsInGroup = True | |
Exit Function | |
End If | |
End If | |
IsInGroup = False | |
End Function | |
' Turns off auto-calc and screen updates | |
Sub Freeze() | |
Application.ScreenUpdating = False | |
Application.Calculation = xlCalculationManual | |
Application.DisplayStatusBar = True | |
End Sub | |
' Turns on auto-calc and screen updates | |
Sub Unfreeze() | |
Application.ScreenUpdating = True | |
Application.Calculation = xlCalculationAutomatic | |
Application.StatusBar = False | |
End Sub | |
Sub PrepareSheet(SheetNum As Integer, ColumnTitles As Variant) | |
Application.StatusBar = "Creating Worksheet headers..." | |
Dim Title As Variant | |
Set objsheet = Worksheets(SheetNum) | |
objsheet.Cells.Clear | |
tc = 0 | |
For Each TitleText In ColumnTitles | |
tc = tc + 1 | |
objsheet.Cells(1, tc) = TitleText | |
objsheet.Cells(1, tc).Font.Bold = True | |
Next | |
End Sub | |
Sub sortSheet() | |
Application.StatusBar = "Sorting Worksheets..." | |
Set objworksheet = Worksheets(1) | |
objworksheet.Name = "Benutzer" | |
objworksheet.Select | |
Set objRange = objworksheet.UsedRange | |
Set objRange2 = Range("C1") | |
objRange.Sort objRange2, xlAscending, , , , , , xlYes | |
ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit | |
End Sub | |
Function getNC() | |
Set objRoot = GetObject("LDAP://RootDSE") | |
getNC = objRoot.Get("defaultNamingContext") | |
End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment