'==========================================================================
' NAME: AD User Export.vbs
' Original 6/23/2010
' 3-27-13 modified to addsmart card, prompt about groups, select starting domain
' 3-28-13 Forced Cscript
' 4-1-13 Fixed navigate up, Restored Expiration date
'==========================================================================
Option Explicit
Const DisabledFlag = &H2
Const ExpiredFlag =  &H10000
Const SmartCardFlag =  &H40000
Const ForAppend = 8
Dim strOUDomain
Dim Con 		'As ADODB.Connection
Dim ocommand 	'As ADODB.Command
Dim message, intcount
Dim strou, siteou

Dim wshShell:Set wshShell = WScript.CreateObject("WScript.Shell")
Dim d,OUCN, sitecode, retval
Dim lngbias, iPWAge, RS, tArray
Dim strType, bdisabled,bNoExp, strSAMName, strDescription
Dim dExpDate, strOS, strADSPath,bSCRequired
Dim strArgs
Dim quote:quote=chr(34)
Dim logfile, appendout
Dim bGroups:bGroups = True 

If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	Dim i
	For i  = WScript.Arguments.Count -1 to  0 Step -1
		strArgs = WScript.Arguments(i) & Space(1) &  strArgs
	Next
	
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote & space(1) & strArgs, 1, true
    WScript.Quit            	'...and stop running as WScript
End If

Dim fso:Set fso = CreateObject("Scripting.FileSystemObject")
OUSearchInit 'Get top level 

message = "You will see a navigation menu for the selected domain's OU " & _
"structure.  You can move up or down the tree. " &VbCrLf  & VbCrLf & _
"Begin OU navigation in what domain?" 
strADSPath = InputBox(message,"Starting Path",strADSPath)
If strADSPath = "" Then WScript.Quit

retval = MsgBox("Included Group Information?",vbQuestion + vbYesNoCancel+vbdefaultbutton2,"Enumerate Groups?")
If retval = vbCancel Then WScript.Quit
If retval = vbNo Then bGroups = False

SearchDom strADSPath



'setup log

logfile  = wshShell.ExpandEnvironmentStrings("%USERPROFILE%")& "\Desktop\" & GenLogFilePath(strADSPath)
logfile = InputBox("Log output to this file","Log path",logfile)

If fso.FileExists(logfile) Then fso.DeleteFile logfile, True
Set appendout = fso.OpenTextFile(logfile, ForAppend, True)

message = "Name	DisplayName	Description	eMailAddress	" & _
"SmartCardRqd	NTName	UPN	disabled	" &  _
"WhenCreated	datePwdLastSet	Last Logon	PWAge	ExpDate	adspath" 
If bGroups Then message = message & vbTab & "User Groups"
Appendout.writeline  message

GetZone
GetInfo strADSPath

wshShell.Popup  "AD Data Export Complete.",8,"Done"
appendout.Close
SaveAsExcel(logfile)

Wscript.Quit(0)		'Script ends

'''''''''''''''''''''''''''''''''''''''
' Functions and subroutines
'''''''''''''''''''''''''''''''''''''''

Sub SearchDom(strADSPath)
	'basic menu to navigate through AD
	
	Dim oADTmp
 	Dim d ' Create dictionary
 	Set d = CreateObject("Scripting.Dictionary")
 	Dim i, message
 	Dim strQuery
 	Dim oRS
 	Dim iChoice
 	i = 1
	
	'Create a query
	Dim strCommand
	strCommand = "SELECT Name, CanonicalName,distinguishedname FROM 'GC://"& strADSPath & _
	"' WHERE objectClass='organizationalUnit'" & " or objectClass='domain'"
	oCommand.CommandText =strCommand
	'WScript.Echo strCommand
	
	Set oRS = oCommand.Execute
	
	If oRS.EOF = True Then	'no more OUs under.  Exit
		Exit Sub
	End If 
	
	oRS.MoveFirst
	'Get the domain of the OU we are working on 
	tarray = oRS.Fields("CanonicalName").value
	strOUDomain = tarray(0)
	tarray = Split(strOUDomain,"/")
	strOUDomain = tarray(0)

	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 & _
		"      --- Current Path ---- " & vbcrlf & _
	 " 0) " & strADSPath & vbcrlf & vbcrlf & _
	 "-1)  Move up to parent path"  
	
	iChoice = InputBox(message,"Enter Choice, Click [OK]",0)
	If iChoice = "" Then WScript.Quit
	If iChoice = 0 Then Exit Sub

	If iChoice = "-1" Then
		set oADTmp = GetObject("GC://" & strADSPath)
		strADSPath = mid(oADTmp.Parent,6)
		d.RemoveAll
		searchDom strADSPath
	End If 
	
	'okay.  This is a kludge. You could do this with a multidimensional array
	'or even a recordset. But it was fast and easy!
	On Error Resume Next ' ignore numbers not in the list
	Dim a,b
	a = d.Items
	b = d.Keys	'Cleaning up from menu stuff to get logfile
	logfile = b(iChoice-1)
	b = Split(logfile,")")
	logfile = Trim(b(1))
	strADSPath = a(iChoice-1)
	d.RemoveAll		'Clear the dictionary
	SearchDom strADSPath
	On Error goto 0
End Sub


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") = 100
	'This is critical -  Pick something else and you get too much 
	oCommand.Properties("Searchscope") = ADS_SCOPE_ONELEVEL
End Sub

Function strMyPath()  '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
	strMyPath = oTrans.Get(1)
	strMyPath = right(strMyPath,Len(strMyPath) - InStr(strMyPath,"OU")+1)
	strMyPath = ParentPath(strMyPath)
End Function 

Function DispFix(strText, MaxLen)
	If len(strText) <= MaxLen Then 
		DispFix = strText
		Exit Function 
	End If
	 
	Dim splitPos
	splitPos =  InStr( MaxLen-5, strText,",")
	DispFix = Left(strText,splitPos) & VbCrLf & Space(3) & _
	Mid(strText,splitPos+1)
End Function

Sub GetInfo(strAdsPath)
	Dim i, strQuery
	Dim domain, dPwdLastSet
	Dim DCLast, ADLast
	Dim strFilter
	strFilter = "(objectCategory=User)"
	
	strQuery = "<LDAP://" & strOUDomain &"/" & strADSPath  & ">;" & strFilter & _
	";Name,cn,pwdLastSet,whencreated,objectCategory," &_
	"useraccountcontrol,adspath,lastlogontimestamp,LastLogon,AccountExpires,description," & _
	"DisplayName,Mail,userPrincipalName,SamAccountName"
	strQuery = strQuery & ";subtree"
	oCommand.CommandText = strQuery
	oCommand.Properties("Page Size") = 100
	oCommand.Properties("Timeout") = 60
	oCommand.Properties("Cache Results") = False
	
	'Execute the query.
	Set rs = ocommand.Execute
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Execute"
	  End If
	intCount = 0
	' Navigate the record Set
	
	If rs.eof And rs.bof Then 
		MsgBox "No records found",vbCritical + vbOKOnly,"Error"
		Exit Sub 
	End If 
	
	rs.MoveFirst
	While Not rs.EOF
	
		If  rs.Fields("UserAccountControl").Value and SmartCardFlag Then 
			bSCRequired = True
		Else
			bSCRequired = False
		End If 

		If  rs.Fields("UserAccountControl").Value and DisabledFlag Then 
			bDisabled = True
		Else
			bDisabled = False
		End If 

		'find last logon to this DC, and replicated LastLogonTimeStamp
		'more recent of two is recorded as last.
		
		DCLast = integer8Date(rs.fields("LastLogon").value,lngBias)
		dPwdLastSet = Integer8Date(rs.Fields("pwdLastSet").Value,lngBias)
		ADLast = Integer8Date(rs.Fields("LastLogonTimeStamp").Value,lngBias)
		If DCLast > ADLast Then ADLast =DCLast

		dExpDate = integer8Date(rs.fields("AccountExpires").value,lngBias)
		PWage(dPwdLastSet)
		
		message = rs.Fields("Name").Value & vbTab & CV("DisplayName") & vbTab &_
		CV("Description") & vbTab & CV("Mail") & vbTab & bSCRequired & vbTab & rs.Fields("SamAccountName").value & vbTab & _
		CV("UserPrincipalName") & vbTab & bdisabled & vbTab & _ 
		rs.Fields("WhenCreated").Value& vbTab &  PrintDate(dPwdLastSet) & vbTab &  PrintDate(ADLast) & vbTab &  iPWAge & vbTab & _
		PrintDate(dExpDate) &  vbTab & rs.Fields("adspath").value
		
		If bGroups Then message = message & vbTab & UserGroups(rs.Fields("adspath").value)
		EchoAndLog message 
	   	rs.MoveNext
	Wend
End Sub

Function CV(strValueName) 'Clean value
		If IsArray(RS.Fields(strValueName).Value) Then 
			tArray = RS.Fields(strValueName).Value
			CV= tArray(0)
		ElseIf IsNull(RS.Fields(strValueName).Value) Then 
			CV = ""
		Else
			CV = RS.Fields(strValueName).Value
		End If 
		'get rid of spaces etc.
		cv= StripHigh(cv)
End Function 

Function UserGroups(adspath)
	WScript.Echo adspath
	Dim objUser, objGroup, strGroupList
	Dim arrGroupList
	Set objUser = GetObject(adsPath)
	For Each objGroup In objUser.Groups
		If strGroupList = "" Then
			strGroupList = objGroup.Name
		Else
			strGroupList = strGroupList & "," & objGroup.Name
		End If
	Next
	
	' Convert strGroupList to Array
	strGroupList=Replace(strGroupList,"CN=","")
	arrGroupList = Split(strGroupList,",")
	'Sort the durn thing
	sort(arrGroupList)
	' Now concatenate arrGroupList into a variable for display
	UserGroups = trim(Join(arrGroupList, ";"))
End Function 

Function Sort(arrSort)
	Dim i,j, temp
	for i = UBound(arrSort) - 1 To 0 Step -1
	    for j= 0 to i
	        if arrSort(j)>arrSort(j+1) Then
	            temp=arrSort(j+1)
	            arrSort(j+1)=arrSort(j)
	            arrSort(j)=temp
	        end If
	    Next
	Next 
	Sort = arrSort
End Function

Sub EchoAndLog (message)
'Echo output and write to log
	Wscript.Echo message
	AppendOut.WriteLine message
End Sub  
 
	
Sub SaveAsExcel(strFileName)
	Const xlnormal = -4143
	Const xlAscending = 1
	Const xlDescending = 2
	Const xlYes = 1
	const xlSortValues = 1
	Dim fso, oXL, objRange, objRange2
	Set fso = CreateObject("Scripting.FileSystemObject")
	If Not fso.FileExists(strFileName) Then WScript.Quit
	On Error Resume Next
	Set oXL = CreateObject("Excel.Application")
	
	If Err <> 0 Then 'Excel not installed
		Err.Clear
		On Error GoTo 0
		Exit Sub
	End If 

	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	Set objRange2 = oXL.Range("A2")

	objRange.Sort objRange2, xlAscending,,,,,, xlYes
	objRange.EntireColumn.Autofit()

	Dim oWS	
	Set oWS = oXL.Worksheets(1)
	oWS.Activate	
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.Visible = True 
End Sub 

Function StripHigh(strText)
	dim strStripped, strchar, i
 	 'Remove all non alphanumeric characters
     For i = 1 to len(strText)
         strchar = mid(strText,i,1)
         If isAlphaNum(strChar) Then
             strStripped = strStripped & strChar
		 End If
	 Next
	StripHigh = trim(strStripped)
End Function 

Function isAlphaNum(char)
	If Asc(char) >= 32 And Asc(char)<= 126 Then 
		isAlphaNum = True 
	Else
		isAlphaNum = False
	End If 
End Function

Function GenLogFilePath(sADSPath)
	Dim strTmp, tArray, i
	strTmp = CStr(Date) & "_" & sADSPath 
	tArray = array("/","DC=","OU=",","," ")
	For i = 0 To UBound(tArray)
		strTmp = Replace(strTmp,tArray(i),"_")
	Next
	strTmp = Replace(strTmp,"__","_")
	GenLogFilePath = strTmp & ".xls"
End Function 


Sub GetZone()
	'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 IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function

Function PrintDate(dDate)
	If IsEmpty(dDate) or isNull(dDate) Or cstr(dDate) = "1/1/1601" Then 
		PrintDate = ""
	Else
		PrintDate = CDate(dDate)
	End If 
End Function 


Sub BailOnFailure(ErrNum, ErrText)    
	message = "Error 0x" & Hex(ErrNum) & " " & ErrText
    MsgBox message, vbInformation, "ADSI Error"
    WScript.Quit
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 DiffADate(theDate) 
  	DiffADate = DateDiff("d", thedate, now)
End Function

Function Integer8Date(objDate, lngBias)
	' Function to convert Integer8 (64-bit) value to a date, adjusted for
	' local time zone bias.
	'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
	    Integer8Date = #1/1/1601#
	  End If
	  On Error GoTo 0

End Function