Active Directory

'Option Explicit
'Move Computers to Specific OUs
'I call this my OU-Reorganizer
'Deji Akomolafe - March 2003

Const ADS_SCOPE_SUBTREE = 2

Set FSO=CreateObject("Scripting.FileSystemObject")

Set FSOWriteNO=FSO.OpenTextFile("C:\list_NoResponse_Computers.xls", 8, True)
Set FSOWriteDC=FSO.OpenTextFile("C:\list_DCs.xls", 8, True)
Set FSOWriteReport=FSO.OpenTextFile("C:\Moved_Computers.xls", 8, True)

FSOWriteNO.WriteLine ("Computer Name") & vbTab & ("Location")


Set objShell = CreateObject("Wscript.Shell")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCOmmand.ActiveConnection = objConnection
objCommand.CommandText = _
    "Select Name, distinguishedName from 'LDAP://DC=myCompany,DC=com' " _
        & "where objectClass='computer'"  
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 30 
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
objCommand.Properties("Cache Results") = False 
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst

Do Until objRecordSet.EOF

	objComputerName = objRecordSet.Fields("Name").Value
	objComputerDN = objRecordSet.Fields("distinguishedName").Value


	'Don't touch the Domain controller's OU
	if instr (UCASE(objComputerDN), UCASE("Domain Controllers")) > 0 Then
		FSOWriteDC.WriteLine  UCASE(objComputerName) & vbTab & " IS IN " & vbTab & UCASE(objComputerDN)
	Else

	'Uncomment this to specify a computer to move by name
	'if instr (UCASE(objComputerDN), UCASE("kel7")) > 0 Then

		'OK, Now we've got a Computer, let's ping it. 
		'We do this so that we can find their subnet and then decide where they are located.
		Set objScriptExec = objShell.Exec("ping -n 1 -w 1 " & UCASE(objComputerName))
		strPing = ObjScriptExec.StdOut.ReadAll
		if instr (UCASE(strPing), UCASE("Pinging")) > 0 Then

		if instr (strPing, "10.10") > 0 Then
				strNewOU = "OU1"
		Else
		if instr (strPing, "10.20") > 0 Then
				strNewOU = "LONDON-OU"
		Else
		if instr (strPing, "10.50") > 0 Then	
				strNewOU = "HQ-OU"
		Else
		if instr (strPing, "10.130") > 0 Then
				strNewOU = "EMEA-OU"'

		'Add more Else ....IF where necessary

		End If
		End If
		End If
		End If

			'We have pre-created all these OUs 
			objNewOU = "LDAP://OU=" & strNewOU & ",OU=ComputersOU,DC=myCompany,DC=com"
			objComputerCN = "CN=" & objComputerName
			objComputerLDAP = "LDAP://" & objComputerDN
			
			On Error Resume Next
			Set objMoveComputer =  GetObject(objNewOU)
			Wscript.Echo objComputerName
			objMoveComputer.MoveHere objComputerLDAP, objComputerCN
			Set objMoveComputer = Nothing

			FSOWriteReport.WriteLine objComputerName & vbTab & strNewOU

		Else
		FSOWriteNo.WriteLine objComputerName & vbTab & objComputerDN
		End If
	'Uncomment this to specify a computer to move by name
	'End If
	End If	 'this ends the Domain controllers exception list
    	objRecordSet.MoveNext
Loop

FSOWriteDC.Close
set FSOWriteDC=nothing
FSOWriteNO.Close
set FSOWriteNO=nothing
set FSO=nothing