'Alan Kaplan 7-29-2008
Option Explicit
Dim root, strADSPath, strDomainName
Dim fso, oRS, oFile
Dim wshNetwork
Dim oConn, oCommand
Dim strComputer, strCommand, message
Dim wshShell
Dim bUser, strUser
Dim d ' Create dictionary
Set d = CreateObject("Scripting.Dictionary")

Set wshShell = WScript.CreateObject("WScript.Shell")

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

OUSearchInit

Dim iChoice

message = "This script will create an RDP Connection for each " & _
"server in this path" & VbCrLf & VbCrLf  & _
"Start with what OU?" & vbcrlf  & vbcrlf &_
"1) " & strAdsPath & VbCrLf  & _
"2) " & strMyPath & VbCrLf

iChoice = InputBox (message,"Starting OU",0)

If iChoice = 0 Then WScript.Quit

If  iChoice = 2 Then 
	strADSPath = strMyPath
End If 

SearchDom strADSPath

set fso = CreateObject ("Scripting.FileSystemObject")
Set wshNetwork = WScript.CreateObject("WScript.Network")
strDomainName = wshNetwork.userDomain 

strDomainName = InputBox("All the servers are in what NT domain?","NT Domain",strDomainName)
If strDomainName = "" Then WScript.Quit

bUser = MsgBox("Do you want to insert a default user name into the files?",vbYesNoCancel+vbQuestion,"Add Name")

Select Case bUser
	Case vbYes 
		bUser = True
		strUser = InputBox("Enter the user name for the RDP files","User Name",wshNetwork.UserName)
		If strUser = "" Then WScript.quit
	Case vbNo  
		bUser = False
	Case Else  
		WScript.Quit
End Select


'get path name, ending in \
Dim scriptpath, strRDPFolder
scriptpath = Left(Wscript.ScriptFullName, InStrRev(Wscript.ScriptFullName, "\"))
strRDPFolder = scriptpath & "RDPFolder"
If Not fso.FolderExists(strRDPfolder) Then	fso.CreateFolder(strRDPFolder)

strCommand = "SELECT Name FROM 'LDAP://" & strADSPath &"' WHERE objectCategory = 'COMPUTER' and OperatingSystem='*Server*'"
oCommand.CommandText = strCommand

oCommand.Properties("searchscope") = 2
oCommand.Properties("Page Size") = 1000
Set oRS = oCommand.Execute

'The file write is based on a script by Andy Grogan
'http://telnetport25.wordpress.com/2007/07/25/generating-rdp-files-using-vbscript/
While Not oRS.EOF
	strComputer = oRS.Fields("Name")
	Set oFile = fso.CreateTextFile(strRDPFolder & "\" & strComputer & ".rdp", TRUE,TRUE)
	'AK: Look at an RDP file in notepad if you want to make changes
	oFile.Write "screen mode id:i:2" & VbCrLf 'Full screen
	oFile.Write "desktopwidth:i:1280" & VbCrLf
	oFile.Write "desktopheight:i:1024" & VbCrLf
	oFile.Write "session bpp:i:32" & vbcrlf
	oFile.Write "winposstr:s:0,1,9,302,809,923" & vbcrlf
	oFile.Write "full address:s:" & strComputer & vbcrlf
	oFile.Write "compression:i:1" & vbcrlf
	oFile.Write "keyboardhook:i:2" & vbcrlf
	oFile.Write "audiomode:i:2" & VbCrLf
	oFile.Write "redirectprinters:i:0" & VbCrLf	'no to printers
	oFile.Write "redirectcomports:i:0" & VbCrLf	'no to com ports
	oFile.Write "redirectsmartcards:i:1" & vbcrlf
	oFile.Write "redirectclipboard:i:1" & vbcrlf
	oFile.Write "redirectposdevices:i:0" & vbcrlf
	oFile.Write "drivestoredirect:s:" & vbcrlf
	oFile.Write "displayconnectionbar:i:1" & vbcrlf
	oFile.Write "autoreconnection enabled:i:1" & vbcrlf
	oFile.Write "prompt for credentials:i:0" & VbCrLf
	oFile.Write "negotiate security layer:i:1" & vbcrlf
	oFile.Write "remoteapplicationmode:i:0" & vbcrlf
	oFile.Write "domain:s:" & strDomainName & vbcrlf
	oFile.Write "alternate shell:s:" & vbcrlf
	oFile.Write "shell working directory:s:" & vbcrlf
	oFile.Write "disable wallpaper:i:0" & vbcrlf
	oFile.Write "disable full window drag:i:0" & vbcrlf
	oFile.Write "allow desktop composition:i:1" & vbcrlf
	oFile.Write "allow font smoothing:i:1" & vbcrlf
	oFile.Write "disable menu anims:i:0" & vbcrlf
	oFile.Write "disable themes:i:0" & VbCrLf
	oFile.Write "disable cursor setting:i:0" & vbcrlf
	oFile.Write "bitmapcachepersistenable:i:1" & vbcrlf
	oFile.Write "gatewayhostname:s:" & vbcrlf
	oFile.Write "gatewayusagemethod:i:0" & vbcrlf
	oFile.Write "gatewaycredentialssource:i:4" & vbcrlf
	oFile.Write "gatewayprofileusagemethod:i:0" & vbcrlf
	oFile.Write "EnableCredSSPSupport:i:0" & VbCrLf
	
	If bUser = True Then 
		oFile.Write "username:s:"& strUser & VbCrLf
		oFile.Write "authentication level:i:0" & VbCrLf
		oFile.Write "promptcredentialonce:i:1" & VbCrLf
	End If 
	
	oFile.close
	WScript.Echo "Created RDP file for " & strComputer
	Set oFile = Nothing
	oRS.MoveNext
Wend

message = "The script has completed - " & oRS.RecordCount & " RDP Files created in " & _
" the RDPFolder on your desktop."
MsgBox message, vbOKonly + vbInformation,"Done"
Set wshNetwork = Nothing

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


Sub SearchDom(strADSPath)
	'basic menu to navigate through AD
	Dim oRS, i, strChoice
	Dim iChoice, oADTmp, retval
	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 & _
		"      --- Current Path ---- " & vbcrlf & _
	 " 0) " & strADSPath & vbcrlf & vbcrlf & _
	 "-1)  Move up to parent path"  
	
	retval = InputBox(message,"Enter Choice and Click [OK]",0)
	If retval = "" Then WScript.Quit
	If retval = "0" Then Exit Sub
	If retval = "-1" Then
		Set oADTmp = GetObject("LDAP://" & strADSPath)
		strADSPath = mid(oADTmp.Parent,8)
		SearchDom strADSPath
	End If 
	
	strChoice = ichoice(retval-1)
	strChoice = Replace(strChoice,cstr(retval)& ") ","")
	
	'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(retval-1)
	b = Split(logfile,")")
	logfile = Trim(b(1))
	strADSPath = a(retval-1)
	d.RemoveAll		'Clear the dictionary
	SearchDom strADSPath
	On Error goto 0
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 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