'AD SMS Compare and Cleanup.vbs, formerly Compare_AD_SMS.vbs
'Alan dot Kaplan at VA dot GOV
'5/24/2010
'This script, originally written in 2004 compares AD and SCCM/SMS database
'it has a lot of cut and paste from other scripts, and the code reflects this.
'This version has improved error handling, adds OU navigation and the ability to delete records not in AD from SCCM
'6/4/2010 Fixed searching outside of users domain.
'Version 2.0 6/18/2010 Fixed Default Domain search, global catalog search and typos
'added additional cancel options and filter to list only reports

Option Explicit
dim wshShell
dim fso, appendout
Dim oConnMDB 					'connection to Access
Dim dbName, sqlRS, mdbRS
Dim retval, message
Dim ADCon, ocommand, strsql 	'As ADODB.Command
Const ForAppend = 8
Const adOpenStatic = 3
Const adLockOptimistic = 3
Set wshShell = WScript.CreateObject("WScript.Shell")
dim quote
quote=chr(34)
Dim strSite
Dim logfile
Dim strAdsPath
Dim objLocator, oSMSWMI
Dim SMSDB
Dim bSMSDel
bSMSDel = False
Dim strPingStatus

Dim iDays 'Default days for active PCs
iDays = 90
Dim bDisabled, lngBias
Const DisabledFlag = &H2
Dim iPWAge, bServers
Dim strProvider
Dim strIP, strSanctuaryserver
Dim strReportFile
Dim strSiteList
dim aTemp
dim i
Dim query, strMyADSPath

'Make sure running Cscript.
If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote, 1, true
    WScript.Quit            	'...and stop running as WScript
End If

message = "This script generates reports of SMS or SCCM clients not in Active Directory, and "&_
"computers in AD which do not appear in the SMS/SCCM database. There is an option to delete systems from " & _
"SMS/SCCM which are not found in AD. You must have your SMS/SCCM SQL database setup for integrated authentication, " & _ 
"and have adequate rights to query."

If cint(OSver) = 6 Then 
	message = message & " ***** This has been tested on an XP workstation, and that is recommended. To run on 2008 " & _
	"you must open an elevated command prompt and type cscript.exe " & quote & WScript.ScriptFullName & quoate & "."
End If 

retval = MsgBox(message, vbokcancel+vbinformation,"AD SMS Script V2 Introduction")
If retval = vbcancel Then Wscript.Quit

Set mdbRS = CreateObject("ADODB.Recordset")
Set sqlRS = CreateObject("ADODB.Recordset")
dim desktop 
Dim strFilter
desktop = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\"

set fso = CreateObject("Scripting.FileSystemObject")
dbName = Desktop  & "ADandSMS.mdb"

'Delete old Acess DB 
If fso.FileExists(dbName) Then
	fso.DeleteFile(dbName)
End If

retval = vbno
CreateDB
GetDom

Do until retval =vbYes
	retval = MsgBox("Starting at " & strAdsPath & ". Is this correct?",vbYesNoCancel,"Confirm AD path")
	If retval = vbCancel Then Quit
	If retval = vbNo Then GetDom
Loop

' Create the object to make the WMI connection
SMSDB=InputBox("Enter name of SMS Database server","SMS DB Server")
If SMSDB = "" Then Quit

Dim LogPrefix
LogPrefix = Month(Now)& "-" & Day(Now) & "-" & Year(Now) & "_" & SMSDB & "_"

On Error Resume Next
Set objLocator = CreateObject("WbemScripting.SWbemLocator")
Set oSMSWMI = objLocator.ConnectServer(SMSDB, "root\sms")
If Err <> 0 Then 
	MsgBox Err.Description,vbCritical + vbOKOnly,"Failed"
	Quit
End If 

strSite=InputBox("Enter Name of SMS Primary site.","SMS site Name",GuessSite(smsdb))
If strSite = "" Then Quit	

message = "Do you also want to delete from your SMS/SCCM database offline systems that not in the Active Directory path you selected?"
retval = MsgBox(message,vbyesnocancel + vbQuestion + vbDefaultButton2,"Delete SMS Records?")
If retval = vbYes Then bSMSDel = True
if retval = vbCancel then Quit   

Dim message2 
If bSMSDel = true Then 
	message2 = "the delete"
Else
	message2 = "the list of systems that would have been deleted"
End If 

message = "Do you want to limit " & message2 & " to systems beginning with " & strSite & " or some other prefix?"
retval = MsgBox (message,vbYesNo,"Filter") 
If retval = vbYes Then
	If bSMSDel = True Then 
		message2 = "delete"
	Else
		message2 = "list"
	End If 
	message = "Only  "&message2&" that begin with this (no wildcards)"
	strFilter = InputBox(message,"Filter",strSite)
	strFilter = " Left(UCase(SMSName),"& Len(strFilter) &") Like '"& strFilter &"' AND "
End If 



QuerySMS
ADOConnect
ADOQuery
Reports
DelFromSMS

OConnMDB.Close
Set oConnMDB = Nothing

message = "Done.  The logfiles have been placed on your desktop, plus a temporary Access " &_
	"database with tables containing AD and SMS information. " &_
	"Do you want to delete the database?"

retval = MsgBox(message,vbyesno + vbquestion,"Delete Temp File?")
If retval = vbyes Then 
 	fso.DeleteFile(dbName)
End If 

Wscript.Quit			'Script ends
 
 
'==================
'Functions and Subs
'==================

Sub CreateDB() 
	'Makes an Access DB even if you don't have Access installed
 	Set OConnMDB = CreateObject("ADOX.Catalog")
 	OConnMDB.Create _
 	    "Provider = Microsoft.Jet.OLEDB.4.0; " & _
 	        "Data Source = " &dbName 
 	Set OConnMDB = Nothing
 	
 	Set oConnMDB = CreateObject("ADODB.Connection")
	
	OConnMDB.Open _
	    "Provider= Microsoft.Jet.OLEDB.4.0; " & _
	        "Data Source=" & dbname 
	
	strsql = "CREATE TABLE ADPCs(" & _
		"ADName TEXT(100)," & _
		"AdsPath TEXT(250)," & _
		"PWDLastSet Date," & _
		"WhenCreated Date," & _
		"LastLogon date," & _
		"PWage number," & _
		"Disabled yesno," & _
		"Description Text(150)," & _
		"OperatingSystem Text(150)," & _
		"SP Text(30))"
		'WScript.Echo strsql
	OConnMDB.Execute strsql
	OConnMDB.Execute "CREATE TABLE SMSPCs(SMSName TEXT(50),SiteCode TEXT(5), MachineID TEXT(10))"

End Sub 

Sub QuerySMS()
	Dim oSMSWMIConn
	Set oSMSWMIConn = CreateObject("ADODB.Connection")
	WScript.Echo "Connecting to SMS Database"
	On Error Resume Next
	oSMSWMIConn.Open _
	    "Provider = SQLOLEDB;" &_
	    "Data Source =" & SMSDB & ";"&_
	    "Initial Catalog=SMS_" & strSite & ";"&_
	    "INTEGRATED SECURITY=sspi;"
		If Err <> 0 Then
			MsgBox Err.Description,vbCritical & vbOKOnly,"Error"
			WScript.Quit
		End If 
	
	On Error GoTo 0

	Dim strCollection, tArray, i
	
	message = ""
	strSQL = "Select CollectionID, Name FROM v_Collection WHERE (CollectionID LIKE 'SMS%') OR " & _
    "(CollectionID LIKE '"&strSite&"%')"
	'open cx to SMS SQL
	sqlRS.Open strSql, oSMSWMIConn, adOpenStatic, adLockOptimistic
	tArray = sqlRS.GetRows()
	sqlRS.Close	
	
	For i = 0 To UBound(tArray,2)
		message = message &  i+1 & ") " & tArray(1,i) & VbCrLf 
	Next
	
	'***** collection number 001 by default is All Systems *****
	
	retval = InputBox(message,"Select Collection to Search",1)
	If isempty(retval) Then Quit
	
	strCollection =  tArray(0,cint(retval)-1)
	
	strSQL = "SELECT System_DISC.Netbios_Name0, siteCode, MachineID  " &_
		"FROM System_DISC Left JOIN _RES_COLL_" & strCollection & " " &_ 
		" ON System_DISC.ItemKey = _RES_COLL_" & strCollection & ".MachineID " &_
		"Where Netbios_Name0 is not Null "&_
		"Order by siteCode,Netbios_Name0"
	
	'WScript.Echo strsql
	'open cx to SMS SQL

	
	sqlRS.Open strSql, oSMSWMIConn, adOpenStatic, adLockOptimistic

	'open cx to MDB file
	mdbRS.Open "SELECT * FROM SMSPCs" , _
    oConnMDB, adOpenStatic, adLockOptimistic	
	
	WScript.Echo "Starting SMS Query"
	On Error resume next
	Do Until sqlRS.EOF
		'Wscript.Echo RS("NetBios_Name0") & vbtab & RS("siteCode")
		mdbRS.AddNew
		mdbRS("SMSName") = sqlRS("NetBios_Name0")
		mdbRS("SiteCode") = sqlRS("siteCode")
		mdbRS("MachineID") = sqlRS("MachineID")
		mdbRS.Update
		sqlRS.Movenext
	Loop
	
	On Error goto 0
	WScript.Echo "Finished SMS Query"
	
	'sqlRS.Close
	mdbRS.Close
	oSMSWMIConn.Close
End Sub 


Sub ADOConnect()
	Dim domain,sADsPath,sfilter, sAttribsToReturn, sDepth
	WScript.Echo vbcrlf & "Connecting to Active Directory"
	
	'Create ADO connection object for Active Directory
	Set ADCon = CreateObject("ADODB.Connection")
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on CreateObject"
	  End If
	ADCon.Provider = "ADsDSOObject"
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Provider"
	  End If
	ADCon.Open "Active Directory Provider"
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Open"
	  End If
	 
	'Create ADO command object for the connection.
	Set ocommand = CreateObject("ADODB.Command")
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on CreateObject"
	  End If
	  
	ocommand.ActiveConnection = ADCon
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Active Connection"
	  End If
End Sub


Sub ADOQuery()
	If mdbrs.State = 1 Then mdbRS.Close
	WScript.Echo "Starting AD Query"
	Dim domain,sADsPath,sfilter, sAttribsToReturn, sDepth, strCommand
	
	If mid(stradspath,instr(stradspath,",DC")) <> Mid(strMyADSPath,instr(strMyADSPath,",DC")) Then 
		wshShell.Popup "Using Global Catalog, OS information will not be available",15,"Global Catalog Search"
		sADsPath = "<GC://" & strAdsPath & ">" 
	Else
		sADsPath = "<LDAP://" & strAdsPath & ">" 		

	End If
	
	sAttribsToReturn = "name,adspath,pwdLastSet,whencreated," &_
	"userAccountControl,lastlogontimestamp,LastLogon,Description," & _ 
	"OperatingSystem,operatingSystemServicePack"
	
	sfilter = "(objectCategory=Computer)"
	sDepth = "subTree"
	  
	'Assemble the commandtext.
	strCommand = sADsPath & ";" & sfilter & ";" & sAttribsToReturn & ";" & sDepth
	ocommand.CommandText = strCommand
	'WScript.Echo strCommand

	  If (Err.Number <> 0) Then
	     MsgBox Err.Description,vbCritical + vbOKOnly,"Error" :	WScript.Quit
	  End If
	
	ocommand.Properties("Page Size") = 1000	'Get 1000 then continue.  Without it, stops at 1000
	'Execute the query.
	Set sqlRS = ocommand.Execute
	  If (Err.Number <> 0) Then
	     MsgBox Err.Description,vbCritical + vbOKOnly,"Error" :	WScript.Quit
	  End If

	' Navigate the record Set
	mdbRS.Open "SELECT * FROM ADPCs" ,  oConnMDB, adOpenStatic, adLockOptimistic	
	
	On Error Resume Next
	On Error GoTo 0
	Do Until sqlRS.EOF
		'WScript.Echo sqlRS("Name") & " AD data added to database"
		
		If  sqlrs.Fields("UserAccountControl").Value And DisabledFlag Then 
			bDisabled = True
		Else
			bDisabled = False
		End If 
		
		Dim DCLast, dPwdLastSet,ADLast, tArray, strDescription
		'find last logon to this DC, and replicated LastLogonTimeStamp
		'more recent of two is recorded as last.
		DCLast = integer8Date(sqlRS.Fields("LastLogon").value,lngBias)
		dPwdLastSet = Integer8Date(sqlRS.Fields("pwdLastSet").Value,lngBias)
		ADLast = Integer8Date(sqlRS.Fields("LastLogonTimeStamp").Value,lngBias)
		If DCLast > ADLast Then ADLast =DCLast
		PWage(dPwdLastSet)

		'Oddly, description can be an array...
		If IsArray(sqlRS.Fields("description").Value) Then 
			tArray = sqlRS.Fields("description").Value
			strDescription = escapesingles(tArray(0))
		ElseIf IsNull(sqlRS.Fields("description").Value) Then 
			strDescription = ""
		Else
			strDescription = EscapeSingles(sqlRS.Fields("description").Value)
		End If 
		
		mdbRS.AddNew	
		mdbRS("ADName") = ucase(sqlRS("Name"))	
		mdbRS("ADSPath") = sqlRS("adspath")
		mdbRS("PWDLastSet") = dPwdLastSet
		mdbRS("WhenCreated") = sqlRS("whencreated")
		mdbRS("LastLogon") = ADLast
		mdbRS("PWAge") = iPWAge		
		If Not isNull(strDescription) Then mdbRS("description") = strDescription
			mdbRS("Disabled") = bDisabled
			mdbRS("OperatingSystem") = sqlRS("OperatingSystem")
		If Not isnull(sqlRS("operatingSystemServicePack")) Then mdbRS("SP") = sqlRS("operatingSystemServicePack")
		mdbRS.Update 
		sqlRS.Movenext
	Loop
	
		On Error goto 0
	WScript.Echo "Done with AD Query" & VbCrLf & VbCrLf 
	
	sqlRS.Close
	mdbRS.Close
	ADCon.Close
End Sub


Sub Reports()
	'Name of log file.  Can open in Excel. delimiter is TAB
	logfile = desktop & LogPrefix &  "SMS_No_AD_Account.xls"	
	If fso.FileExists(logfile) then fso.DeleteFile(logfile)
	
	set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
	appendout.writeline "PCName" & vbtab & "Sitecode"
	
	WScript.echo "Reporting SMS with no matching computer account"
	WScript.Sleep 3
	
		strSql = "SELECT DISTINCT SiteCode, SMSName " &_
		" FROM SMSPCs LEFT JOIN ADPCs ON SMSPCs.SMSName = ADPCs.ADName " &_
		" WHERE " &  strFilter & "(ADPCs.ADName Is Null) " &_
		" Order by SiteCode, SMSName"
	
		'WScript.Echo strsql
	
		mdbRS.Open strsql, oConnMDB, adOpenStatic, adLockOptimistic
		mdbRS.MoveFirst
	
	Do Until mdbRS.EOF
	    EchoAndLog mdbRS("SMSName") & vbtab &  mdbRS("SiteCode")
	    mdbRS.MoveNext
	Loop
	
	mdbRS.Close
	set appendout = Nothing 

	SaveAsExcel logfile 

' next.....

	logfile = desktop & LogPrefix & "PCs_Not_In_SMS.xls"	
	If fso.FileExists(logfile) then fso.DeleteFile(logfile)

	set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
	appendout.writeline "PCName	OS	SP	LastLogon	PWAge	Description	ADSPath"
	
	WScript.echo "Reporting computer accounts with no matching SMS entry"
	WScript.Sleep 3

	strsql = "SELECT ADPCs.ADName, ADPCs.OperatingSystem, ADPCs.SP, ADPCs.LastLogon, ADPCs.PWage, ADPCs.Description, ADPCs.AdsPath " & _
	"FROM ADPCs LEFT JOIN SMSPCs ON ADPCs.ADName = SMSPCs.SMSName " & _
	"WHERE (((ADPCs.Disabled)=0) AND ((SMSPCs.SMSName) Is Null)) " & _
	"ORDER BY ADPCs.ADName;"
	
	mdbRS.Open strsql, oConnMDB, adOpenStatic, adLockOptimistic
	mdbRS.MoveFirst
	
	Do Until mdbRS.EOF
		WScript.Echo mdbRS("ADName")
	    appendout.WriteLine mdbRS("ADName") & vbTab &  mdbRS("OperatingSystem") & vbTab & _
	    	mdbRS("SP") & vbTab &  mdbRS("LastLogon") & vbTab &  mdbRS("PWage") & vbTab & _
	    	mdbRS("Description") & vbTab &  mdbRS("AdsPath")
	    	mdbRS.MoveNext
	Loop	
	mdbRS.Close
	appendout.Close
	
	SaveAsExcel logfile 
End Sub

Sub DelFromSMS()
	Dim sResource
	If Not bSMSDel Then Exit Sub 
    Set oSMSWMI = objLocator.ConnectServer(SMSDB, "root\SMS\site_" & strSite)

	strsql = "SELECT DISTINCT SMSPCs.SMSName, SMSPCs.MachineID, Left(UCase(SMSName),3) as First3 " & _
	"FROM SMSPCs LEFT JOIN ADPCs ON SMSPCs.SMSName = ADPCs.ADName " & _
	"WHERE " & strFilter & "(ADPCs.ADName Is Null) " & _
	"ORDER BY SMSPCs.SMSName;"
	
	mdbRS.Open strsql, oConnMDB, adOpenStatic, adLockOptimistic
	If mdbRS.EOF And mdbRS.BOF Then
		MsgBox "No SMS records found to delete",vbInformation + vbOKOnly,"Nothing to Delete"
		Exit Sub
	End If 
	
	mdbRS.MoveLast
	mdbRS.MoveFirst
	
	Dim iDelCount
	iDelCount = mdbRS.RecordCount
	
	retval = MsgBox("Confirm deletion of " & iDelCount &" records from SMS/SCCM database",vbYesNocancel+vbDefaultButton2 ,"Confirm")
	If retval = vbNo Then Exit Sub 
	If retval = vbCancel Then Quit

	WScript.Echo vbcrlf & vbcrlf & "Beginning deletion of records from SCCM Database"
	logfile = desktop & LogPrefix & "DeletedfromSMS.xls"	
	If fso.FileExists(logfile) then fso.DeleteFile(logfile)

	set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
	appendout.writeline "PCName" & vbTab & "Message"
	
	Do Until mdbRS.EOF
		Dim strcomputer, resID
		strComputer = mdbRS("SMSName")
		If pingreply(strcomputer) Then 
			EchoAndLog strcomputer & "	Replied to ping, not deleted from SMS/SCCM" 		
		Else
			resID = mdbRS("MachineID")
			On Error Resume Next
			Set sResource = oSMSWMI.Get("SMS_R_System='" & ResID & "'")
			sResource.Delete_         'Delete the resource
			On Error GoTo 0
			
			If Err = 0 Then 
			   	EchoAndLog strcomputer &  "	Record deleted from SMS/SCCM"
			Else
			    EchoAndLog strcomputer & "	Record NOT deleted from SMS/SCCM" 
			End If   
			
			Set sResource = Nothing
		End If 
	    mdbRS.MoveNext
	Loop
	
	mdbRS.Close
	appendout.Close	
	
	SaveAsExcel logfile 
End Sub 
 
Function PingReply(strcomputer) 
	Dim objScriptExec, strPingResults
	Dim objRE, match, matches, strOut 

	'RegEx pattern from Bill Stewart
	Set objRE = New RegExp
    objRE.Pattern = " [0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}"
	
	'Three lines from Steve Cathersalc 
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	strOut = lcase(objScriptExec.StdOut.Readall)

	If InStr(strOut,"could not find host") Then
		PingReply = False
		strPingStatus = "No Host Record"
		Exit Function
	End If  
	
	If InStr(strOut,"unreachable") Then 
		PingReply = False
		strPingStatus = "Unreachable"
	End If  
	
	If  InStr(strOut,"bytes=") = 0 Then 
		PingReply = False
		strPingStatus= "Offline"
	Else
		PingReply = True
		strPingStatus = "Online"
	End If  
	
	Set matches = objRE.Execute(strOut)   ' Execute search.

	If Matches.count = 1 Then 
	   For Each Match in Matches   ' Iterate Matches collection.
	     strIP = trim(Match.Value) 'Cleanup
	   Next
	Else
		strIP = ""
	End If 
End Function

Sub GetDom()
	OUSearchInit
	Dim iChoose
	strMyADSPath = MyPath
	iChoose = InputBox( _
	"This will let you navigate to select an OU.  Start Navigation with:" & String(4,VbCrLf) &_
	"1) " & strAdsPath & VbCrLf   & _
	"2) " & strMyADSPath & VbCrLf & _
	"3) Type a path (required for different domain)" & VbCrLf,"Root Path",0)
	
	Select Case cint(iChoose)
	Case 0
		Quit
	Case 1 
		SearchDom strAdsPath
	Case 2
		strAdsPath = MyPath
		SearchDom strAdsPath
	Case 3
		strAdsPath = InputBox ("Enter Path","Type Search Root",strAdsPath)
		SearchDom strAdsPath
	Case Else
		GetDom
	End Select 
End Sub 

Function GuessSite(server)
	'original by Michael Niehaus,  http://www.serverwatch.com/tutorials/article.php/2174271
	'some changes by Alan Kaplan
	
	Dim r,site, results
   ' Select the primary site
    Set results = oSMSWMI.ExecQuery("SELECT sitecode From SMS_ProviderLocation WHERE ProviderForLocalSite = true")

    ' Process the results
    For each r in results
        site = r.SiteCode  ' Get the 3-character site code
    Next
    
    GuessSite = site
End Function

Sub SearchDom(strAdsPath)
	Dim d ' Create dictionary
	Set d = CreateObject("Scripting.Dictionary")
	Dim i, message

	Dim oRS
	Dim iChoice
	i = 1
	'Create a query
	oCommand.CommandText = _
	    "SELECT Name, distinguishedname FROM 'GC://"& strAdsPath &"' WHERE objectClass='organizationalUnit'"  
	Set oRS = oCommand.Execute
		
	If oRS.EOF = True Then	'no more OUs under.  Exit
		Exit Sub
	End If 
	
	oRS.MoveFirst
	Do Until oRS.EOF
		'Add the name and the dn -- here ADSPath to dictionary.
	    d.Add i &") " &  oRS.Fields("Name").Value, oRS.Fields("distinguishedname").Value
	    oRS.MoveNext
	    i = i + 1 
	Loop
	
	iChoice = d.Keys              ' Get the keys.
	'OUName = d.Items
	
	message =""		'Build the menu
	
	For i = 0 To d.Count -1 ' Iterate the names 
	    message = message &   iChoice(i) & vbcrlf
	Next
	
	message = message & "99) Go up to parent path" & vbcrlf &_
	vbcrlf & 	"      --- Current Path ---- " & vbcrlf & _
	 "0) " & strAdsPath  
	
	iChoice = InputBox(message,"Enter Choice",0)
	
	If iChoice = "" Then Quit
	iChoice = CInt(iChoice)
	If iChoice = 0 Then Exit Sub
	
	If iChoice = 99 or iChoice > d.Count  Then 
		strAdsPath = ParentPath(strAdsPath)
	Else
		'okay.  This is a kludge, combining dictionary object
		'and arrays.  You could do this with a multidimensional array
		'or even a recordset. But it was fast and easy!
		Dim a
		a = d.Items
		strAdsPath = a(iChoice-1)
	End If
	 
	d.RemoveAll		'Clear the dictionary
	SearchDom strAdsPath 'recurse
End Sub

Function ParentPath(strOU) 'what is above
	Dim IADSCont
	Set IADSCont = GetObject("LDAP://" & strOU)
	ParentPath = mid(IADsCont.Parent,8)
End Function

Sub OUSearchInit()
	Const ADS_SCOPE_ONELEVEL = 1
	Dim root
	Dim oConn
	'Get the default ADsPath for the domain to search. 
	Set root = GetObject("LDAP://rootDSE")
	strAdsPath = root.Get("defaultNamingContext")
	
	'Connect to Active directory and search setup
	Set oConn = CreateObject("ADODB.Connection")
	Set oCommand =   CreateObject("ADODB.Command")
	oConn.Provider = "ADsDSOObject"
	oConn.Open "Active Directory Provider"
	Set oCommand.ActiveConnection = oConn
	oCommand.Properties("Page Size") = 1000
	'This is critical -  Pick something else and you get too much 
	oCommand.Properties("Searchscope") = ADS_SCOPE_ONELEVEL
End Sub

Function MyPath()  'Get path of current user
	Dim objEnv, strMyName
	Dim strDNSDom 
	Dim oTrans, IADsCont
	set objEnv = WshShell.Environment("process")
	strMyName = objEnv("UserDomain") & "\" & objEnv("UserName")
	strDNSDom = objEnv("UserDNSDomain")
	Set oTrans = CreateObject("NameTranslate")
	oTrans.Init 1, strDNSDom
	oTrans.Set 3,strMyName
	MyPath = oTrans.Get(1)
	MyPath = right(MyPath,Len(MyPath) - InStr(MyPath,"OU")+1)
	MyPath = ParentPath(MyPath)
End Function 

Sub SaveAsExcel(strFileName)
	Const xlnormal = -4143 
	Dim oXL, objRange
	If Not fso.FileExists(strFileName) Then Exit Sub 
	On Error Resume next
	Set oXL = CreateObject("Excel.Application")
	
	If Err <> 0 Then 'Excel not installed
		Err.Clear
		On Error GoTo 0

		'rename to .txt
		fso.MoveFile strFileName, replace(strFileName,".xls",".txt")
		Exit Sub
	End If 
	
	oXL.Visible = False
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	objRange.EntireColumn.Autofit()
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.ActiveWorkBook.Close
	oXL.Quit
	'WScript.Echo "Done"
End Sub 


Function PWage(intdate)
		  If intDate <> #1/1/1601# Then 
		  	iPWAge = round(Now - cdate(intDate),0)
		  Else
		  	iPWAge = 99999	'unknown
		  End If 
End Function 

Function Integer8Date(objDate, lngBias)
	' Function to convert Integer8 (64-bit) value to a date, adjusted for
	' local time zone bias. R. Mueller
	'http://www.rlmueller.net/Integer8Attributes.htm
  Dim lngAdjust, lngDate, lngHigh, lngLow
  
  	 If IsNull(objDate) Then 
	 	Integer8Date = #1/1/1601#
	    Exit Function
  End If
  
  lngAdjust = lngBias
  lngHigh = objDate.HighPart
  lngLow = objdate.LowPart
' Account for error in IADslargeInteger property methods.
  If lngLow < 0 Then
    lngHigh = lngHigh + 1
  End If
  If (lngHigh = 0) And (lngLow = 0) Then
    lngAdjust = 0
  End If
  lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
    + lngLow) / 600000000 - lngAdjust) / 1440
' Trap error if lngDate is ridiculously huge.

  On Error Resume Next
  Integer8Date = CDate(lngDate)
  If Err.Number <> 0 Then
    On Error GoTo 0
    Integer8Date = #1/1/1601#
  End If
  On Error GoTo 0
End Function


Sub GetZone()
	'Also R Muller
	' Obtain local time zone bias from machine registry.
	Dim lngBiasKey
	lngBiasKey = wshShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
	  & "TimeZoneInformation\ActiveTimeBias")
	If UCase(TypeName(lngBiasKey)) = "LONG" Then
	  lngBias = lngBiasKey
	ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
	  lngBias = 0
	  For k = 0 To UBound(lngBiasKey)
	    lngBias = lngBias + (lngBiasKey(k) * 256^k)
	  Next
	End If
End Sub 


Function EscapeSingles(strTest)
	If InStr(strTest,"'") Then	
		EscapeSingles = replace(strTest,"'","''") 'escape apostrophe
	Else
		EscapeSingles = strTest
	End If 
End Function 


Sub EchoAndLog(message)
	'Echo output and write to text log 
	Wscript.Echo message
	AppendOut.WriteLine message
End Sub  

Sub BailOnFailure(ErrText)    
    MsgBox strText, vbInformation, "Error"
    WScript.Quit
End Sub

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function

Sub Quit
	On Error Resume Next 
	If mdbrs.State = 1 Then mdbRS.Close
	Set OConnMDB = Nothing
	'Delete old Acess DB 
	If fso.FileExists(dbName) Then
		fso.DeleteFile dbName,true
	End If
	
	WScript.Quit
End Sub 


Function OSver()
	dim oWMI, colOS, objOS, strOS
	Set oWMI = GetObject("winmgmts:\\.\root\cimv2")
	Set ColOS = oWMI.ExecQuery("SELECT version FROM Win32_OperatingSystem")

	For Each ObjOS In ColOS
		 strOS = left(objos.version,3)
	Next
	OSver = strOS
End Function