Change the line
"<LDAP://DC= >;" and
"<GC://dc=com>;" and
add your domain path.
It doesn't work on groups with spaces.
It dumps the users id to a file and then querys AD for the first and last
name, and department. You can change it to what you want. Hope this comes
across correctly when I paste this..
Dim wsh
Set WSH = WScript.CreateObject("WScript.shell")
dim objGroup,objMember
'only works on groups with no spaces
group = InputBox("Enter the name of the group to dump to Excel.")
Title = "Members Of The User Group " & group
Const ForAppending = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
("c:\" & GROUP & ".TXT", ForAppending, True)
Set objConnection2 = CreateObject("ADODB.Connection")
objConnection2.Open "Provider=ADsDSOObject;"
Set objCommand2 = CreateObject("ADODB.Command")
objCommand2.ActiveConnection = objConnection2
objcommand2.commandtext = _
"<LDAP://DC= >;" & _
"(&(objectCategory=group)(objectClass=group)" & _
"(sAMAccountName=" & group &"));" & _
"sAMAccountName, distinguishedName;subtree"
Set objRecordSet2 = objCommand2.Execute
If objRecordSet2.RecordCount = 0 Then
Wscript.Echo "ERROR. The group " & strgp &" *** is not found in Active
Directory. "
Wscript.quit
Else
While Not objRecordset2.EOF
strgrppath = objrecordset2.fields("distinguishedName")
objRecordset2.MoveNext
Wend
End If
strmanagedby = ""
Set objGroup = GetObject _
("LDAP://" & strgrppath &"")
objTextFile.WriteLine (title)
For each objMember in objGroup.Members
GrpUserList= objMember.Name
GrpUserName= objMember.displayNAme
objTextFile.WriteLine (grpuserlist & vbtab & GrpUserName)
Next
Const ForReading = 1
indat="C:\" & group & ".txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
(indat, ForReading)
Dim objXL
Set objXL = WScript.CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add
objXL.Columns(1).ColumnWidth = 17
objXL.Columns(2).ColumnWidth = 22
objXL.Columns(3).ColumnWidth = 22
objXL.Columns(4).ColumnWidth = 15
objXL.Columns(5).ColumnWidth = 18
objXL.Cells(1, 1).Value = "ID"
objXL.Cells(1, 2).Value = "User Name"
objXL.Cells(1, 3).Value = "Description"
objXL.Cells(1, 4).Value = "First"
objXL.Cells(1, 5).Value = "Last"
objXL.Range("A1:E1").Select
objXL.Selection.Font.Bold = True
objXL.Selection.Interior.ColorIndex = 1
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 2
objXL.Columns("B:B").Select
objXL.Selection.HorizontalAlignment = &hFFFFEFDD ' xlLeft
Dim intIndex8
intIndex8 = 2
Do Until objTextFile.AtEndOfStream
on error resume Next
strusrpath = objTextFile.Readline
'string manipulation
intIndex = InStr(UCase(strusrpath), "=")
If intIndex> 0 Then
strOU = Mid(strusrpath, intIndex+1)
End If
intIndex1 = InStrRev (strOU, vbTab)
If intIndex1> 0 Then
intIndex2=intIndex1 - 1
strOU1 = UCase(Left(strOU, intIndex2))
strOU2 = Mid(strOU, intIndex1+1)
End If
'Find user and pull description info
offdesc = " "
firstname = " "
Lastname = " "
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.CommandText = _
"<GC://dc=com>;" & _
"(&(objectCategory=person)(objectClass=user)" & _
"(sAMAccountName=" & strOU1 & "));" & _
"sAMAccountName, distinguishedName;subtree"
Set objRecordSet = objCommand.Execute
If objRecordSet.RecordCount = 0 Then
'Wscript.Echo "ERROR. The User id " & user & " is not in Active
Directory." & vbcrlf & "User not added. Please check the id and run again."
'WScript.quit
Else
While Not objRecordset.EOF
strusrpath = objrecordset.fields("distinguishedName")
objRecordset.MoveNext
Wend
Set objuser = GetObject("LDAP://" & strusrpath &"")
On Error Resume Next
offdesc = objuser.Get("description")
firstname = objuser.Get("givenName")
lastname = objuser.Get("sn")
End If
Call Show(strOU1,StrOU2,offdesc)
Loop
Sub Show(strOU1,StrOU2,offdesc)
objXL.Cells(intIndex8, 1).Value = strOU1
objXL.Cells(intIndex8, 2).Value = strOU2
objXL.Cells(intIndex8, 3).Value = offdesc
objXL.Cells(intIndex8, 4).Value = firstname
objXL.Cells(intIndex8, 5).Value = lastname
intIndex8 = intIndex8 + 1
objXL.Cells(intIndex8, 1).Select
End Sub
WScript.echo "Dumped group " & group & " to excel."
