using excel vba to query Active directory

[jimrward]

i am looking for some code to query active directory as follows

1) search for groups in AD using a wildcard
2) for each of the groups found list the members

produce worksheet as follows

group1, membername1
group1, membername2
group1, membername3
group2, membername1
group2, membername2
group3, membername1

 

[jimrward]

i managed to get the desired result in the end by a lot of google and usage of Vbscript from various sources all over the net, in my own novice way

I will try and convert to VBA if at all possible as time permits

If any wants a copy of the vbscript I will paste here

 

[jimrward]

ok, not the prettiest code but it works, this one queries LDAP using a wildcard and returns tallys on one sheets and expanded info on another sheet

appears to run quicker than the VBSCRIPT version, working on the conversion of the one to list users, watch this space

example of group to query ABC-Printers*

Sub LDAPQueryDevices()
'****
' VBSCRIPT to interogate AD/LDAP for a given group and report the following
'
' 1) tally of the number of members of the given group
' 2) list user details against group
'
' Author    Jim Ward
' Creation  27th May 2011
'
' Gleaned from various sources and assembled into the following
'
'****
'
'****
' declare some array storage for names and paths
'****
'

Dim grouppaths(500) As String
Dim groupnames(500) As String

numheader2 = 4
Dim headers2(4) As String

headers2(1) = "GroupName"
headers2(2) = "DeviceName"
headers2(3) = "OperatingSystem"
headers2(4) = "DistinguishedName"

NoEntry = "No Entry"

Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1

Const TallyName = "Counts"
Const ListName = "Devices"

'
'****
' prompt user for group to find
'****
'

groupname = InputBox("Please enter the name of the group:")

If groupname = "" Then
    Exit Sub
End If

'
'****
' 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;"
    
cmd.CommandText = "SELECT adspath,cn from 'LDAP://" & getNC & _
              "' WHERE objectCategory = 'Group' and cn = '" & groupname & "'"

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

'
'****
' Turn off updates and calculations
'****
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Application.DisplayStatusBar = True

'
'****
' found something so create the output files and write the headers
'****
'

Application.StatusBar = "Creating Worksheet headers..."

If i > 0 Then

'
'****
' Copy Field names to header row of worksheet 1
'****
'

    Set objsheet = Worksheets(1)
    objsheet.Cells(1, 1).Value = "GroupName"
    objsheet.Cells(1, 1).Font.Bold = True

    objsheet.Cells(1, 2).Value = "Count"
    objsheet.Cells(1, 2).Font.Bold = True

'
'****
' Copy Field names to header row of worksheet 2
'****
'

    Set objsheet = Worksheets(2)
    For h = 1 To numheader2
        objsheet.Cells(1, h) = headers2(h)
        objsheet.Cells(1, h).Font.Bold = True
    Next
End If

'
'****
' now process each group found and extract all members
'****
'

cl = 1      'count lines
gl = 1      'group lines

Application.StatusBar = "Populating Worksheets..."

For j = 0 To i - 1
    Application.StatusBar = "Writing Group " & j & " of " & i

    Set objgroup = GetObject(grouppaths(j))

    Set objsheet = Worksheets(1)
    cl = cl + 1
    objsheet.Cells(cl, 1).Value = groupnames(j)
    objsheet.Cells(cl, 2).Value = objgroup.Members.Count
    c = objgroup.Members.Count
    g = 0
    Set objsheet = Worksheets(2)
    If objgroup.Members.Count > 0 Then
        For Each objmember In objgroup.Members
            g = g + 1
            Application.StatusBar = "Writing Group Details " & g & " of " & c

            gl = gl + 1
            objsheet.Cells(gl, 1).Value = groupnames(j)
            objsheet.Cells(gl, 2).Value = Right(objmember.Name, Len(objmember.Name) - 3)
            objsheet.Cells(gl, 3).Value = objmember.OperatingSystem
            objsheet.Cells(gl, 4).Value = objmember.distinguishedName
        Next
    Else
        gl = gl + 1
        objsheet.Cells(gl, 1).Value = groupnames(j)
        For h = 2 To numheader2
            objsheet.Cells(gl, h) = NoEntry
        Next
    End If
Next

'
'****
' All done, name sheet, sort data, autofit columns, close up and exit
'****
'
'
'****
' to sort the data we have to actually select the required sheet before we can do anything
'****
'
Application.StatusBar = "Sorting Worksheets..."

Set objworksheet = Worksheets(1)
objworksheet.Name = TallyName
objworksheet.Select

Set objRange = objworksheet.UsedRange
Set objRange2 = Range("A1")

objRange.Sort objRange2, xlAscending, , , , , , xlYes
ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit

Set objworksheet = Worksheets(2)
objworksheet.Name = ListName
objworksheet.Select

Set objRange = objworksheet.UsedRange
Set objRange2 = Range("A1")
Set objRange3 = Range("B1")

objRange.Sort objRange2, xlAscending, objRange3, , xlAscending, , , xlYes
ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit

'
'****
' Turn ON updates and calculations
'****
'

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MsgBox "All Done"

End Sub
Function getNC()
    Set objRoot = GetObject("LDAP://RootDSE")
    getNC = objRoot.get("defaultNamingContext")
End Function

 

[jongooligan]

Have you had a look at the ADO copyfromrecordset method?

http://support.microsoft.com/kb/246335

Might save you from having to dump the recordset into an array and then loop through it.

 

[jimrward]

copyfromrecordset, was looked at especially for the main loop however I only need a small number of the fields available

I could have used it to populate the arrays, but as the number of records was small it was either or, with any potential performance improvements

 

[Air_Cooled_Nut]

I need some AD info for one of my applications. After much searching this thread saved me, thanks Jim! Here's my adaptation of Jim's work that I am using for my needs. I don't know the inner workings of AD so please forgive any mistakes

For this function you pass in a single string which is the AD group name. Optionally, you can set the wildcard exclusion. The function will return an array that contains the info on the AD group, assuming it finds it. The info returned is set in the function; as you can see by the orange text I'm only getting two values. To get additional values uncomment the desired items in the green section and increment the middle element of the array.

Here is how you could call the function. The variable "vTableauGroup" is a single dimension array that contains a list of strings that are the possible AD group names.

Function RemoveUsersFromGroups(vGroupList As Variant)
'Get AD groups used, compare users to users on worksheet, dynamically create batch script & files to remove missing users from Tableau Groups.
Dim vAD_Members As Variant, vTableauGroup As Variant

For Each vTableauGroup In vGroupList
     vAD_Members = AD_Info(vTableauGroup)  'Grab AD possible group
     If vAD_Members(0, 0, 0) = "Empty Set" Then GoTo GetNext
     '...Valid AD group found so process results with the info in the vAD_Members() array...
GetNext:
Next vTableauGroup
End Function

The adapted function:

Option Explicit

Function AD_Info(ByVal sGroup_Name As String, Optional bExcludeWildCard As Boolean = True) As Variant
'Based on http://www.mrexcel.com/forum/excel-questions/553062-using-excel-visual-basic-applications-query-active-directory.html
'Get specific AD/LDAP info for a given group.

Const sNoEntry As String = "No Entry"
Dim GroupPaths() As Variant, GroupNames() As Variant, cmd As Object, cn As Object, rs As Object, objGroup As Object, lRecordCount As Long, lRecordTotal As Long
Dim lIndexCount As Long, objMember As Variant, lMemberCount As Long, vArray() As Variant, x As Long, lCurrentMemberCount As Long, lMemberCounter As Long

ReDim vArray(0, 0, 0)
vArray(0, 0, 0) = "Empty Set"
AD_Info = vArray  'Set default value
If sGroup_Name = "" Then Exit Function  'Nothing passed in so exit
'Remove wildcard characters
If bExcludeWildCard Then
    sGroup_Name = Replace(sGroup_Name, "*", "")
End If

'Set up ADO query and excute 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;"
cmd.CommandText = "SELECT adspath,cn from 'LDAP://" & GetNC & "' WHERE objectCategory = 'Group' and cn = '" & sGroup_Name & "'"
cmd.activeconnection = cn
Set rs = cmd.Execute

'Process the results of the query into arrays
lRecordTotal = -1
On Error GoTo Error_Handler
While rs.EOF <> True And rs.bof <> True
    lRecordTotal = lRecordTotal + 1
    ReDim Preserve GroupPaths(lRecordTotal)
    ReDim Preserve GroupNames(lRecordTotal)
    GroupPaths(lRecordTotal) = rs.Fields("adspath").Value  'AD comprehensive info
    GroupNames(lRecordTotal) = rs.Fields("cn").Value  'Just the AD group name(s)
    rs.movenext
Wend
cn.Close
Set cmd = Nothing
Set cn = Nothing
Set rs = Nothing
If lRecordTotal < 0 Then Exit Function  'AD group is empty or doesn't exist

lIndexCount = 1  'Adjust dimensions as needed
'Process each group found and extract all members

'Get the maximum number of members in the AD group(s) so we can dimension our array
lMemberCount = 0
For lRecordCount = 0 To lRecordTotal
    lCurrentMemberCount = GetObject(GroupPaths(lRecordCount)).Members.Count  'Count of items in AD group name
    If lCurrentMemberCount > lMemberCount Then lMemberCount = lCurrentMemberCount
Next lRecordCount
If lMemberCount = 0 Then Exit Function  'AD group is empty
ReDim vArray(lRecordTotal, lIndexCount, lMemberCount - 1) 'Adjust dimensions as needed
For lRecordCount = 0 To lRecordTotal
    'Fill out Counts sheet
    DoEvents
    Set objGroup = GetObject(GroupPaths(lRecordCount))
    lMemberCount = objGroup.Members.Count  'Count of items in AD group name
    If lMemberCount > 0 Then
        lMemberCounter = -1
        For Each objMember In objGroup.Members
            Application.StatusBar = "Getting " & lMemberCounter & " of " & lMemberCount
            DoEvents
            lMemberCounter = lMemberCounter + 1
            [COLOR="#DAA520"]vArray(lRecordCount, 0, lMemberCounter) = GroupNames(lRecordCount)[/COLOR]
[COLOR="#008000"]            'Replace "z" with element values up to lIndexCount as needed
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.cn  'Name as it appears in Lotus Notes, SameTime, etc.
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.objectclass
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.Description
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.member
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.distinguishedname
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.instancetype
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.whencreated
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.whenchanged
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.uSNCreated  [COLOR="#FF0000"]'Caused error[/COLOR]
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.uSNChanged  [COLOR="#FF0000"]'Caused error[/COLOR]
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.Name
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.objectguid  [COLOR="#FF0000"]'Caused error[/COLOR]
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.objectsid  [COLOR="#FF0000"]'Caused error[/COLOR]
            [COLOR="#DAA520"]vArray(lRecordCount, 1, lMemberCounter) = objMember.samaccountname 'User's AD ID[/COLOR]
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.samaccounttype
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.grouptype
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.objectcategory
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.dscorepropagationdata
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.dcxobjectowner
            ' vArray(lRecordCount, z, lMemberCounter) = objMember.nTSecurityDescriptor  [COLOR="#FF0000"]'Caused error[/COLOR][/COLOR]
        Next
    Else
        For x = 0 To lIndexCount
            vArray(lRecordCount, x, 0) = sNoEntry
        Next x
    End If
    Set objGroup = Nothing
Next lRecordCount

AD_Info = vArray  'Return AD group info
Exit Function

Error_Handler:
If InStr(5, Err.Description, "size limit") Then
    MsgBox "Too many AD groups returned, possibly due to use of a wildcard character.", vbExclamation, "Process Aborted."
Else
    MsgBox "Process Aborted!" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation, "Error in AD_Info module."
End If
On Error Resume Next
cn.Close
Set cmd = Nothing
Set cn = Nothing
Set rs = Nothing
On Error GoTo 0
End Function

Function GetNC()
Dim objRoot As Object
    Set objRoot = GetObject("LDAP://RootDSE")
    GetNC = objRoot.get("defaultNamingContext")
    Set objRoot = Nothing
End Function

 

[ShanePhillip]

@Air_Cooled_Nut, Excellent code. Saved me alot of time. I'm adding worksheet cell mappings and will try to upload that code. Thanks!

 

[richtrem63]

i am looking for some code to query active directory as follows ...


Note to those searching for the truth :

Sometimes the returned field is not readable (for exemple a DirectoryString type)

for example:
Set objConn = New ADODB.Connection
objConn.Provider = "ADsDSOObject"
objConn.Open "Active Directory Provider"
SQL ="SELECT name, description FROM 'LDAP://dc=DOMAIN,dc=COM' where objectCategory='CN=Computer,CN=Schema,CN=Configuration,DC=DOMAIN,DC=COM' ORDER BY name"
Set objRS = New ADODB.Recordset
objRS.Open ssql, objConn, adOpenForwardOnly, adLockUnspecified


If you check the type you will have ? typename(objRS.fields("description").Value) = Variant().

To read the data, add a dimension to it: s = objRS.fields("description").Value(0)

Enjoy!