'==========================================================================
' NAME: Add SIP to MailEnabled Users in OU.vbs
' 2-20-12.  
' based on UserSummary.vbs which goes back to 1-23-06
' Alan dot kaplan at va dot gov 
' A cut and paste mess (still)
'==========================================================================
Option Explicit
'On Error Resume Next
Dim i, message, sADSPath
Const ADS_SCOPE_ONELEVEL = 1
Dim root
Dim oConn, oCommand
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim Con 	'As ADODB.Connection
Dim gc 		'As IADs
Dim result, strText
Dim TopOU, strou, siteou,sdomain, rserver, displayon
Dim fso,ofolders, isnew,wsfile
Dim  RS
Set wshShell = WScript.CreateObject("WScript.Shell")
dim quote,title,path,newpath
Dim d,OUCN, sitecode, strUName, strAdsPath
Dim objUser
quote=chr(34)
Set d = CreateObject("Scripting.Dictionary")
Dim strInfo
Dim bDebug:bDebug = True 
Dim NTDom, objTrans
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1

'Get the default ADsPath for the domain to search. 
Set root = GetObject("LDAP://rootDSE")
sADSPath = root.Get("defaultNamingContext")

' Use the NameTranslate object to find the NetBIOS domain name from the
' DNS domain name. (http://www.rlmueller.net/NameTranslateFAQ.htm#How%20do%20I%20find%20the%20NetBIOS%20name%20of%20the%20domain)
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, sADSPath
NTDom = objTrans.Get(ADS_NAME_TYPE_NT4)
' Remove trailing backslash.
NTDom = Left(NTDom, Len(NTDom) - 1)

'Connect to Activer 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

Dim sMyPath
sMyPath = strMyPath()

message = "This adds SIP info for enabled users with mail in an OU, and writes a log file." & vbNewLine & vbNewLine  & _
"Start navigation with what OU?"

sADSPath = InputBox(message,"Starting Path",sMyPath)
If sADSPath = "" Then WScript.Quit
SearchDom sADSPath


sADSPath = strAdsPath

' Create FileSystemObject object to access file system.
Set fso = WScript.CreateObject("Scripting.FileSystemObject")


'get path name, ending in \
Dim desktoppath, logfile, appendout
desktoppath = wshShell.ExpandEnvironmentStrings("%USERPROFILE%")& "\Desktop\"

logfile = desktoppath & left(WScript.ScriptName,Len(WScript.ScriptName)-3)& "xls"

Dim strOUName, tArray
tarray = Split(sADSPath,",")
If instr(tarray(0),"=") > 0 Then 
	strOUName = replace(tarray(0),"=","_")
End If

logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & strOUName & "_Notes_Log.xls"
logfile = InputBox("Log File", "Log File Path",logfile)
If logfile = "" Then WScript.Quit

Dim retval 
If fso.FileExists(logfile) Then fso.DeleteFile logfile,True

'setup log
Const ForAppend = 8
set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
appendout.WriteLine "Name	description	sAMAccountName	whenCreated	adspath	Remarks"

ADOQuery

'Show done
appendout.Close

SaveAsExcel logfile

wshShell.Popup "Done. Logfile is " & vbNewLine & logfile,20,"Script Complete" 

'''''''''''''''''''''''''''''''''''''''
' subroutines
'''''''''''''''''''''''''''''''''''''''

Sub SearchDom(sADSPath)
	Dim oRS
	Dim iChoice
	i = 1
	'Create a query
	Dim strCommand 
	strCommand = "SELECT Name, distinguishedname FROM 'GC://"& sADSPath & _
	"' WHERE objectClass='organizationalUnit'" & " or objectClass='domain'"
	oCommand.CommandText =strCommand
	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.
	
	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) " & sADSPath & VbCrLf  
	
	iChoice = InputBox(message,"Select OU",0)
	If iChoice = "" Then WScript.Quit
	If iChoice = "0" Then 
		strAdsPath = sADSPath
		Exit Sub
	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!
	
	Dim a,b
	a = d.Items
	b = d.Keys	'Cleaning up from menu stuff to get logfile
	'On Error Resume Next	'ignore invalid entries
	logfile = b(iChoice-1)
	b = Split(logfile,")")
	logfile = Trim(b(1))
	sADSPath = a(iChoice-1)
	d.RemoveAll		'Clear the dictionary
	'On Error GoTo 0
	searchDom sADSPath
	strAdsPath = sADSPath
End Sub



Sub ADOQuery()
	WScript.Echo sADSPath
	WScript.Echo "Executing AD query, please wait...."
	dim i
	Dim domain,sfilter, sAttribsToReturn, sDepth
	  Set domain = GetObject("LDAP://" & sADSPath)
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on GetObject for domain"
	  End If
	
	'Build the ADsPath element of the commandtext
	sADsPath = "<LDAP://" & sADSPath & ">"
	'set filter for enabled user accounts with mail and no SIP only 
	sfilter = "(&(&(&(&(objectCategory=person)(objectClass=user)" &_
	"(mailNickName=*)" & _
	"(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
	"(!(userAccountControl:1.2.840.113556.1.4.803:=65536)(!msRTCSIP-PrimaryUserAddress=*))))))"

	
	'Build the returned attributes element of the commandtext.
	'name is netbios name distinguishedname is path
	sAttribsToReturn = "name,description,sAMAccountName,whenCreated,adspath"


	'Build the depth element of the commandtext.
	sDepth = "subTree"
	 
	'Assemble the commandtext.
	ocommand.CommandText = sADsPath & ";" & sfilter & ";" & sAttribsToReturn & ";" & sDepth
	'WScript.Echo oCommand.CommandText
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on CommandText"
	  End If

	ocommand.Properties("Page Size") = 500
	oCommand.Properties("Sort on") = "samAccountName"
	oCommand.Properties("Cache results") = False
	
	'Execute the query.
	Set RS = ocommand.Execute
	If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Execute"
	End If
	
	'WScript.Echo RS.recordcount & " users found"
	' Navigate the record Set
	rs.MoveFirst
	
	While Not rs.EOF
		WScript.Echo rs.Fields("Name").Value	
		'GetInfo	
		rs.MoveNext
	Wend
End Sub









Sub EchoAndLog(message)
	WScript.Echo message
	appendout.WriteLine message
End Sub

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



Sub BailOnFailure(ErrNum, ErrText)    strText = "Error 0x" & Hex(ErrNum) & " " & ErrText
    MsgBox strText, vbInformation, "ADSI Error"
    WScript.Quit
End Sub


Sub EchoAndLog (message)
'Echo output and write to Log
	Wscript.Echo message
	AppendOut.WriteLine message
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
	Dim tpath
	tPath = oTrans.Get(1)
	tPath = right(tPath,Len(tPath) - InStr(tPath,"OU")+1)
	strMyPath = ParentPath(tPath)
End Function 

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

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

	
Sub SaveAsExcel(strFileName)

	Const xlnormal = -4143 
	Dim fso, oXL, objRange
	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 

	WScript.Echo "Converting Log to Excel ..."	
	'oXL.Visible = True
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	objRange.EntireColumn.Autofit()

	Dim oWS	
	Set oWS = oXL.Worksheets(1)
	oWS.Activate
	'oWS.Name = sdomain
	
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.ActiveWorkBook.Close
	oXL.Quit
	WScript.Echo "Done"
End Sub 

Function EnableSip()
	Dim whenChanged
	Dim strDescription
	
	If IsArray(rs.Fields("description").Value) Then 
		tArray = rs.Fields("Description").Value
		strDescription = tArray(0)
	Else
		strDescription= (rs.Fields("Description").Value)
	End If 
	
	strUName = rs.Fields("Name").Value		
	message =  strUName & vbTab &  rs.Fields("sAMAccountName").Value & vbTab
	message = message & strDescription &  vbTab
	message = message & rs.Fields("WhenCreated").Value & vbTab 
	message = message & rs.Fields("adspath").value
	
	Set objUser = GetObject(rs.Fields("adspath").value)

	objUser.put "msRTCSIP-UserEnabled", True 
	objUser.put "msRTCSIP-OptionFlags", 256 ' set this value to a bitmask representing which OCS features you want to enable/disable 
	objUser.put "msRTCSIP-PrimaryUserAddress",  "sip:" & objUser.userPrincipalName	' set this to the primary URI (typically the same as the users email address) 
	objUser.put "msRTCSIP-PrimaryHomeServer", strPool ' set this to the distinguished name of the OCS front-end 
	if not bDebug Then objUser.setinfo

	'Add sip:address@dom.com info to list of addresses in ProxyAddresses
	'mostly from http://www.msexchange.org/articles/Scripting-Exchange-VBScript-ADSI-Part2.html
	Dim objRecip
	Dim sAddress, vProxyAddresses, nProxyAddresses
	Dim i
	
	Set objRecip = objUser
    sAddress ="sip:" & objUser.userPrincipalName
    dim bIsFound: bIsFound = False
    vProxyAddresses = objRecip.ProxyAddresses
    nProxyAddresses = UBound(vProxyAddresses)
    i = 0
    Do While i <= nProxyAddresses
          If vProxyAddresses(i) = sAddress  Then
             bIsFound = True
                Exit Do
          End If
          i = i + 1
    Loop
    If Not bIsFound Then
           ReDim Preserve vProxyAddresses(nProxyAddresses + 1)
           vProxyAddresses(nProxyAddresses + 1) = sAddress
           objRecip.ProxyAddresses = vProxyAddresses
    End If
    
    if not bDebug then objUser.SetInfo
    
   	If Err <> 0 Then 
   		message = message & vbTab & "Success"
   	Else
   		message  message & vbTab & "Failed. " & Err.Description
   	End If 
	echoandLog message
	Err.Clear
	'On Error GoTo 0
    
End Function