Hello,
I use the VBScript under WSH 5.6 below to attempt to list membership of all of the groups in an AD tree. The output is in Excel and seems to work quite well until the script hits a group with multiple members. The script will then abend with the error "(224, 3) Microsoft Office Excel: Sort method of Range class failed" at line 224 which is using the Sort method in order to attempt to sort the accounts by last name, then first name. Does anyone have an idea as to why the sort fails? If I comment out the sort, the script completes properly.
All help will be greatly appreciated.
VBScript follows:
Option Explicit
Const ADS_SCOPE_SUBTREE = 2
Const UF_ACCOUNTDISABLE = &H2
Dim rootDSE
Dim strRootDSE
Dim strCommand
Dim strGroupObj
Dim strMember
Dim strMemberFwd
Dim objExcel
Dim objConnection
Dim objCommand
Dim objRecordSet
Dim objGroup
Dim objMember
Dim objRange
Dim objRange2
Dim objRange3
Dim objMemberFwd
Dim arrMemberOf
Dim sh
Dim i
Dim k
Dim g
Dim x
'connect to the root of AD
Set rootDSE = GetObject("LDAP://RootDSE")
strRootDSE = rootDSE.Get("defaultNamingContext")
strCommand = "SELECT cn, distinguishedName, objectCategory, SN, givenName FROM 'LDAP://" & strRootDSE & "' WHERE objectCategory='group' AND cn = '*' AND member = '*'"
'WScript.Echo strRootDSE
'WScript.Echo strCommand
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add
For Each sh In objExcel.Sheets
i = i + 1
Next
For k = 1 To i-1
objExcel.ActiveWorkbook.Sheets(1).Delete
Next
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.Properties("Sort on") = "cn"
objCommand.CommandText = strCommand
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
g = 1
Do Until objRecordSet.EOF
Call NewSheet
objRecordSet.MoveNext
g = g + 1
Loop
Wscript.Quit
Sub NewSheet
strGroupObj = "LDAP://" & objRecordSet.Fields("distinguishedName").Value
WScript.Echo "DN = " & objRecordSet.Fields("distinguishedName").Value
WScript.Echo "strGroupObj = " & strGroupObj
' On Error Resume Next
Set objGroup = GetObject(strGroupObj)
' On Error Goto 0
objGroup.GetInfo
' On Error Resume Next
arrMemberOf = objGroup.GetEx("member")
If Err.Number = 0 Then
If g > 1 Then
objExcel.Worksheets.Add
Else
objExcel.ActiveWorkbook.Sheets(g).Select()
End If
If Len(objRecordSet.Fields("cn").Value) <= 31 Then
objExcel.ActiveSheet.Name = objRecordSet.Fields("cn").Value
Else
objExcel.ActiveSheet.Name = Left(objRecordSet.Fields("cn").Value,31)
End If
objExcel.Cells(1, 1).Value = "Last name"
objExcel.Cells(1, 2).Value = "First name"
objExcel.Cells(1, 3).Value = "Department"
objExcel.Cells(1, 4).Value = "Phone number"
objExcel.Cells(1, 5).Value = "samAccountName"
objExcel.Cells(1, 6).Value = "Default SMTP Address"
objExcel.Cells(1, 7).Value = "Forwarding SMTP Address"
objExcel.Cells(1, 8).Value = "Keep emails in server Inbox"
objExcel.Cells(1, 9).Value = "Status"
objExcel.Cells(1, 10).Value = strGroupObj
objExcel.Cells(1, 1).EntireRow.Font.Bold = True
objExcel.Cells(1, 1).EntireRow.Font.Underline = True
objExcel.Cells(1, 1).EntireRow.Font.ColorIndex = 10
x=2
For Each strMember in arrMemberOf
Set objMember = GetObject("LDAP://" & strMember)
objExcel.Cells(x, 1).Value = _
objMember.SN
objExcel.Cells(x, 2).Value = _
objMember.givenName
objExcel.Cells(x, 3).Value = _
objMember.department
objExcel.Cells(x, 4).Value = _
objMember.telephoneNumber
objExcel.Cells(x, 5).Value = _
objMember.samAccountName
objExcel.Cells(x, 6).Value = _
objMember.mail
' WScript.Echo objMember.Class
' WScript.Echo objMember.userflags
' If objMember.Class = "user" Then
' If objMember.UserFlags And UF_ACCOUNTDISABLE Then
' objExcel.Cells(x, 9).Value = _
' "Diasbled"
' Else
' objExcel.Cells(x, 9).Value = _
' "Enabled"
' End If
' End If
'On Error Resume Next
' WScript.Echo(objMember.altRecipient)
' If (objMember.altRecipient) Then
' strMemberFwd = objMember.altRecipient
' WScript.Echo(objMember.altRecipient)
' Set objMemberFwd = GetObject("LDAP://" & objMember.altRecipient)
' objExcel.Cells(x, 7).Value = _
' objMemberFwd.mail
' If objMember.deliverAndRedirect = True Then
' objExcel.Cells(x, 8).Value = _
' "Yes"
' Else
' objExcel.Cells(x, 8).Value = _
' "No"
' End If
' End If
On Error GoTo 0
x = x + 1
Next
Set objRange = objExcel.Range("A1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("B1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("C1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("D1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("E1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("F1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("G1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("H1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("I1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("J1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit()
Set objRange = objExcel.Range("A1").SpecialCells(11)
objRange.Activate
Set objRange2 = objExcel.Range("A1")
Set objRange3 = objExcel.Range("B1")
' objRange.Sort objRange2,1,objRange3,,1,,,1
objRange.Sort objRange2,1,objRange3,,1,,,1
Else
g = g -1
End If
On Error GoTo 0
End Sub