Dim conn, dbpath, sqlcommand, dbTableName
Dim UserName, Department, CN
Dim ObjMember, ObjGroup, strGroupName, strActiveGroup, ObjGroupMember
Dim strDN, objMemberList
Dim objConnection, objCommand, objRootDSE, strDNSDomain
' Dictionary object to track group membership.
objMemberList = CreateObject("Scripting.Dictionary")
objMemberList.CompareMode = vbTextCompare
'######################################
dbpath = "c:\ADUserInfo.mdb" ' change this to the path of your database
'strDomainName = "DOMAINNAME" ' change this to your domain name
objDomain = GetObject("LDAP://rootDse")
DomainString = objDomain.Get("dnsHostName")
'######################################
dbTableName = "tblGroups"
conn = CreateObject("ADODB.Connection")
conn.Provider = "Microsoft.Jet.OLEDB.4.0"
conn.Open(dbpath)
On Error Resume Next
sqlcommand = "CREATE TABLE [" & dbTableName & "] (ADGroupName Text(255), FirstName Text(255), LastName Text(255), SamAccountName Text(255), Department Text(255), IsPrimary BIT, UserAdsPath Memo,ADGroupDescription Text(255))"
conn.Execute(sqlcommand)
On Error GoTo 0
sqlcommand = "DELETE * FROM [" & dbTableName & "]"
conn.Execute(sqlcommand)
objRoot = GetObject("LDAP://RootDSE")
strDNC = objRoot.Get("DefaultNamingContext")
strDNSDomain = objRoot.Get("defaultNamingContext")
objOU = GetObject("LDAP://" & strDNC)
' Setup ADO.
objConnection = CreateObject("ADODB.Connection")
objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open("Active Directory Provider")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
Call enumMembers(objOU)
conn.close()
conn = Nothing
MsgBox("Done")
End Sub
Sub enumMembers(ActiveObjectOU)
For Each objGroupMember In ActiveObjectOU
If objGroupMember.Class = "group" Then
Call EnumGroup(ObjGroupMember)
End If
If objGroupMember.Class = "organizationalUnit" Or objGroupMember.Class = "container" Then
enumMembers(ObjGroupMember)
End If
Next
End Sub
Sub EnumGroup(ByVal objADGroup)
Dim strFilter, strAttributes, objRecordSet, intGroupToken
Dim objMember, strQuery, strNTName
Dim objCommand, conn
' Retrieve "primaryGroupToken" of group.
objADGroup.GetInfoEx(Array(primaryGroupToken), 0)
intGroupToken = objADGroup.Get("primaryGroupToken")
' Use ADO to search for users whose "primaryGroupID" matches the
' group "primaryGroupToken".
strFilter = "(primaryGroupID=" & intGroupToken & ")"
strAttributes = "sAMAccountName"
strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter & ";" & strAttributes & ";subtree"
'WScript.echo strQuery
objCommand.CommandText = strQuery
objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strNTName = objRecordSet.Fields("sAMAccountName")
'ADGroupName = FixValue(ObjADGroup.AdsPath)' use this for ADGroupName if you just want the ADS Path
ADGroupName = Mid(FixValue(objADGroup.Name), 4)
SamAccountName = FixValue(strNTName)
IsPrimary = "1"
UserAdsPath = "(Not Available because used WinNT Provider)"
qryInsert = "INSERT INTO [" & dbTableName & "](ADGroupName, FirstName, LastName, SamAccountName, Department, IsPrimary, UserAdsPath) VALUES ('" & ADGroupName & "','" & FirstName & "','" & LastName & "','" & SamAccountName & "','" & Department & "', '" & IsPrimary & "', '" & UserAdsPath & "')"
conn.Execute(qryInsert)
objRecordSet.MoveNext()
Loop
For Each objMember In objADGroup.Members
On Error Resume Next
ADGroupName = Mid(FixValue(objADGroup.Name), 4)
ADGroupDescription = FixValue(objADGroup.Description)
SamAccountName = FixValue(objMember.SamAccountName)
FirstName = FixValue(objMember.GivenName)
LastName = FixValue(objMember.sn)
Department = FixValue(objMember.Department)
UserADSPath = FixValue(objMember.AdsPath)
IsPrimary = "0"
On Error GoTo 0
qryInsert = "INSERT INTO [" & dbTableName & "](ADGroupName, FirstName, LastName, ADGroupDescription, SamAccountName, Department, IsPrimary, UserAdsPath) VALUES ('" & ADGroupName & "','" & FirstName & "','" & LastName & "','" & ADGroupDescription & "','" & SamAccountName & "','" & Department & "', '" & IsPrimary & "', '" & UserADSPath & "')"
'WScript.Echo qryInsert
conn.Execute(qryInsert)
On Error Resume Next
Next
objMember = Nothing
objRecordSet = Nothing
End Sub
Function FixValue(ByVal sValue)
FixValue = Replace(sValue, "'", "''")
End Function
on line 64 I think, objADGroup.GetInfoEx(Array(primaryGroupToken), 0) is currently throwing an error saying: 'Array' is a type and cannot be used as an expression.
This code that I'm using is a slightly modified version of:
http://www.visualbasicscript.com/m_34962/tm.htm The script itself it working as a standalone *.vbs file, but I cannot seem to get it to compile in MS VB 2008 Express Edition due to this Array error.
Any offers of help muchly appreciated!