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