[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now

x
?
Solved

Help Updating a VB Script

Posted on 2011-09-12
5
Medium Priority
?
258 Views
Last Modified: 2012-08-14
I have the attached VB Script and it currently reads a spreadsheet that has usernames in one column and email address in three other columns and updates specific attributes in Active Directory.  Can someone help me strip out the code to update the attributes in this script and have the script only update the proxyAddresses attribute.  My spreadsheet of data looks like this.

Column A - User Name
Column B - Email@user.com, user@email.com, me@me.com

So the script needs to add the data in column B to the proxyAddresses attribute for the specific users.
'Define Constants
Const ADS_SCOPE_BASE = 0 'Search base object only
Const ADS_SCOPE_ONELEVEL = 1 'Search one level of immediate children
Const ADS_SCOPE_SUBTREE = 2 ' Search target object and all sub levels

'Set Variables
DQ = Chr(34) 'Double Quote

'Create Objects
Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Verifies script was run using Cscript, and if not relauches it using Cscript
If Not WScript.FullName = WScript.Path & "\cscript.exe" Then
	objShell.Popup "Relaunching script with Cscript in 5 seconds...", 5, _
	"Script Host Message", 48
	objShell.Run "cmd.exe /k " & WScript.Path & "\cscript.exe //NOLOGO " & _
	DQ & WScript.scriptFullName & DQ, 1, False
	WScript.Quit 0
End If

'Warn User
iWarn = MsgBox("This will make changes to AD." & VbCr & _
"Are you sure you want to do this?", 308, "ID 10 T Check")
'308 = Yes/No (4) + 'Exclaimation (48) + Default Button 2 (256)
If iWarn = vbNo Then
	WScript.Quit 0
End If

'Construct an ADsPath to the Current Domain with rootDSE
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsPath = "LDAP://" & objRootDSE.Get("defaultNamingContext")

'Connect to Active Directory
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

'Prompt for spreadsheet path and verify it exists
Do Until objFSO.FileExists(strExcelPath)
	strExcelPath = InputBox("Please enter the path to the Excel input file:", _
	"Excel File Path", "C:\Temp\UserList.xls")
	If strExcelPath = False Then
		WScript.Quit
	End If
Loop

'Open spreadsheet
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

'Start with row 2 of spreadsheet assuming first row has column headings
iRow = 2

'Read each row of the spreadsheet until a blank value is encountered in
'column 1
Do While objSheet.Cells(iRow, 1).Value <> ""
	strUsername = Trim(objSheet.Cells(iRow, 1).Value)
	strEmail = Trim(objSheet.Cells(iRow, 2).Value)
	strAttrib2 = Trim(objSheet.Cells(iRow, 3).Value)
	strAttrib3 = Trim(objSheet.Cells(iRow, 4).Value)
	
	'Search AD Domain to verify Pre 2000 username exists
	objCommand.CommandText = "SELECT distinguishedName, ADsPath FROM '" & strADsPath & _
	"' WHERE objectCategory='user' AND sAMAccountName='" & strUsername & "'"
	Set objRecordSet = objCommand.Execute
	If objRecordSet.EOF Then
		objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
		WScript.Echo "User " & strUsername & " not found"
		
	Else
		On Error Resume Next
		strUserADsPath = objRecordSet.Fields("ADsPath").Value
		Set objUserAccount = GetObject(strUserADsPath)
		
		If strEmail <> "" Then
			objUserAccount.Put "mail", strEmail
		End If
		
		If strAttrib2 <> "" Then
			objUserAccount.Put "extensionAttribute2", strAttrib2
		End If
		
		If strAttrib3 <> "" Then
			objUserAccount.Put "extensionAttribute3", strAttrib3
		End If
		
		objUserAccount.SetInfo 'Writes settings to AD
		
		If err.number = 0 Then
			objExcel.Cells(iRow, 1).Interior.ColorIndex = 4
			WScript.Echo strUsername & " updated successfully"
		Else
			objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
			WScript.Echo "Error updating " & strUsername
		End If
		
		Err.Clear
		On Error goto 0
	End If
	iRow = iRow+1
Loop

WScript.Echo
WScript.Echo "Script Finished"

'Save and Close Excel
objExcel.ActiveWorkbook.Save
objExcel.Workbooks.Close
objExcel.Quit

Open in new window

0
Comment
Question by:seaninman
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
5 Comments
 
LVL 14

Expert Comment

by:dlwyatt82
ID: 36524545
Do you want to append what's in the spreadsheet to the proxyAddresses attribute, or completely replace it?

Here's a modified version of your code that would add or replace the proxyAddresses attribute:

'Define Constants
Const ADS_SCOPE_BASE = 0 'Search base object only
Const ADS_SCOPE_ONELEVEL = 1 'Search one level of immediate children
Const ADS_SCOPE_SUBTREE = 2 ' Search target object and all sub levels

Const ADS_PROPERTY_UPDATE = 2

'Set Variables
DQ = Chr(34) 'Double Quote

'Create Objects
Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Verifies script was run using Cscript, and if not relauches it using Cscript
If Not WScript.FullName = WScript.Path & "\cscript.exe" Then
  objShell.Popup "Relaunching script with Cscript in 5 seconds...", 5, _
  "Script Host Message", 48
  objShell.Run "cmd.exe /k " & WScript.Path & "\cscript.exe //NOLOGO " & _
  DQ & WScript.scriptFullName & DQ, 1, False
  WScript.Quit 0
End If

'Warn User
iWarn = MsgBox("This will make changes to AD." & VbCr & _
"Are you sure you want to do this?", 308, "ID 10 T Check")
'308 = Yes/No (4) + 'Exclaimation (48) + Default Button 2 (256)
If iWarn = vbNo Then
  WScript.Quit 0
End If

'Construct an ADsPath to the Current Domain with rootDSE
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsPath = "LDAP://" & objRootDSE.Get("defaultNamingContext")

'Connect to Active Directory
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

'Prompt for spreadsheet path and verify it exists
Do Until objFSO.FileExists(strExcelPath)
  strExcelPath = InputBox("Please enter the path to the Excel input file:", _
  "Excel File Path", "C:\Temp\UserList.xls")
  If strExcelPath = False Then
    WScript.Quit
  End If
Loop

'Open spreadsheet
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

'Start with row 2 of spreadsheet assuming first row has column headings
iRow = 2

'Read each row of the spreadsheet until a blank value is encountered in
'column 1
Do While objSheet.Cells(iRow, 1).Value <> ""
  strUsername = Trim(objSheet.Cells(iRow, 1).Value)
  strEmail = Trim(objSheet.Cells(iRow, 2).Value)
  strAttrib2 = Trim(objSheet.Cells(iRow, 3).Value)
  strAttrib3 = Trim(objSheet.Cells(iRow, 4).Value)
  
  'Search AD Domain to verify Pre 2000 username exists
  objCommand.CommandText = "SELECT distinguishedName, ADsPath FROM '" & strADsPath & _
  "' WHERE objectCategory='user' AND sAMAccountName='" & strUsername & "'"
  Set objRecordSet = objCommand.Execute
  If objRecordSet.EOF Then
    objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
    WScript.Echo "User " & strUsername & " not found"
    
  Else
    On Error Resume Next
    strUserADsPath = objRecordSet.Fields("ADsPath").Value
    Set objUserAccount = GetObject(strUserADsPath)
    
    Dim arrAddresses()
    Dim intIndex
    
    intIndex = -1
    
    If strEmail <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = UCase(strEmail)
      Else
        arrAddresses(intIndex) = LCase(strEmail)
      End If
    End If
    
    If strAttrib2 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = UCase(strAttrib2)
      Else
        arrAddresses(intIndex) = LCase(strAttrib2)
      End If
    End If
    
    If strAttrib3 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = UCase(strAttrib3)
      Else
        arrAddresses(intIndex) = LCase(strAttrib3)
      End If
    End If
    
    If (intIndex >= 0) Then
      objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrAddresses
      objUserAccount.SetInfo 'Writes settings to AD
    End If
    
    If err.number = 0 Then
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 4
      WScript.Echo strUsername & " updated successfully"
    Else
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
      WScript.Echo "Error updating " & strUsername
    End If
    
    Err.Clear
    On Error goto 0
  End If
  iRow = iRow+1
Loop

WScript.Echo
WScript.Echo "Script Finished"

'Save and Close Excel
objExcel.ActiveWorkbook.Save
objExcel.Workbooks.Close
objExcel.Quit

Open in new window

0
 
LVL 14

Expert Comment

by:dlwyatt82
ID: 36524569
I found some reference material after posting this, and realized that I formatted the proxyAddresses field incorrectly.  Here's a quick modification to address that:

'Define Constants
Const ADS_SCOPE_BASE = 0 'Search base object only
Const ADS_SCOPE_ONELEVEL = 1 'Search one level of immediate children
Const ADS_SCOPE_SUBTREE = 2 ' Search target object and all sub levels

Const ADS_PROPERTY_UPDATE = 2

'Set Variables
DQ = Chr(34) 'Double Quote

'Create Objects
Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Verifies script was run using Cscript, and if not relauches it using Cscript
If Not WScript.FullName = WScript.Path & "\cscript.exe" Then
  objShell.Popup "Relaunching script with Cscript in 5 seconds...", 5, _
  "Script Host Message", 48
  objShell.Run "cmd.exe /k " & WScript.Path & "\cscript.exe //NOLOGO " & _
  DQ & WScript.scriptFullName & DQ, 1, False
  WScript.Quit 0
End If

'Warn User
iWarn = MsgBox("This will make changes to AD." & VbCr & _
"Are you sure you want to do this?", 308, "ID 10 T Check")
'308 = Yes/No (4) + 'Exclaimation (48) + Default Button 2 (256)
If iWarn = vbNo Then
  WScript.Quit 0
End If

'Construct an ADsPath to the Current Domain with rootDSE
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsPath = "LDAP://" & objRootDSE.Get("defaultNamingContext")

'Connect to Active Directory
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

'Prompt for spreadsheet path and verify it exists
Do Until objFSO.FileExists(strExcelPath)
  strExcelPath = InputBox("Please enter the path to the Excel input file:", _
  "Excel File Path", "C:\Temp\UserList.xls")
  If strExcelPath = False Then
    WScript.Quit
  End If
Loop

'Open spreadsheet
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

'Start with row 2 of spreadsheet assuming first row has column headings
iRow = 2

'Read each row of the spreadsheet until a blank value is encountered in
'column 1
Do While objSheet.Cells(iRow, 1).Value <> ""
  strUsername = Trim(objSheet.Cells(iRow, 1).Value)
  strEmail = Trim(objSheet.Cells(iRow, 2).Value)
  strAttrib2 = Trim(objSheet.Cells(iRow, 3).Value)
  strAttrib3 = Trim(objSheet.Cells(iRow, 4).Value)
  
  'Search AD Domain to verify Pre 2000 username exists
  objCommand.CommandText = "SELECT distinguishedName, ADsPath FROM '" & strADsPath & _
  "' WHERE objectCategory='user' AND sAMAccountName='" & strUsername & "'"
  Set objRecordSet = objCommand.Execute
  If objRecordSet.EOF Then
    objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
    WScript.Echo "User " & strUsername & " not found"
    
  Else
    On Error Resume Next
    strUserADsPath = objRecordSet.Fields("ADsPath").Value
    Set objUserAccount = GetObject(strUserADsPath)
    
    Dim arrAddresses()
    Dim intIndex
    
    intIndex = -1
    
    If strEmail <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strEmail
      Else
        arrAddresses(intIndex) = "smtp:" & strEmail
      End If
    End If
    
    If strAttrib2 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strAttrib2
      Else
        arrAddresses(intIndex) = "smtp:" & strAttrib2
      End If
    End If
    
    If strAttrib3 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strAttrib3
      Else
        arrAddresses(intIndex) = "smtp:" & strAttrib3
      End If
    End If
    
    If (intIndex >= 0) Then
      objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrAddresses
      objUserAccount.SetInfo 'Writes settings to AD
    End If
    
    If err.number = 0 Then
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 4
      WScript.Echo strUsername & " updated successfully"
    Else
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
      WScript.Echo "Error updating " & strUsername
    End If
    
    Err.Clear
    On Error goto 0
  End If
  iRow = iRow+1
Loop

WScript.Echo
WScript.Echo "Script Finished"

'Save and Close Excel
objExcel.ActiveWorkbook.Save
objExcel.Workbooks.Close
objExcel.Quit

Open in new window

0
 
LVL 4

Author Comment

by:seaninman
ID: 36524777
The script isn't working.  Is there some way we can add some error checking to see where it is failing at?
0
 
LVL 14

Expert Comment

by:dlwyatt82
ID: 36525283
It already has some error checking.  What output are you getting when you run the script (both in the Excel sheet, which has some color changes, and also on the command prompt)?
0
 
LVL 14

Accepted Solution

by:
dlwyatt82 earned 2000 total points
ID: 36525299
Oh, nevermind.  I can see what the problem most likely is.  Line 122 (objUser.PutEx  ....) should be objUserAccount.PutEx .

'Define Constants
Const ADS_SCOPE_BASE = 0 'Search base object only
Const ADS_SCOPE_ONELEVEL = 1 'Search one level of immediate children
Const ADS_SCOPE_SUBTREE = 2 ' Search target object and all sub levels

Const ADS_PROPERTY_UPDATE = 2

'Set Variables
DQ = Chr(34) 'Double Quote

'Create Objects
Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Verifies script was run using Cscript, and if not relauches it using Cscript
If Not WScript.FullName = WScript.Path & "\cscript.exe" Then
  objShell.Popup "Relaunching script with Cscript in 5 seconds...", 5, _
  "Script Host Message", 48
  objShell.Run "cmd.exe /k " & WScript.Path & "\cscript.exe //NOLOGO " & _
  DQ & WScript.scriptFullName & DQ, 1, False
  WScript.Quit 0
End If

'Warn User
iWarn = MsgBox("This will make changes to AD." & VbCr & _
"Are you sure you want to do this?", 308, "ID 10 T Check")
'308 = Yes/No (4) + 'Exclaimation (48) + Default Button 2 (256)
If iWarn = vbNo Then
  WScript.Quit 0
End If

'Construct an ADsPath to the Current Domain with rootDSE
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsPath = "LDAP://" & objRootDSE.Get("defaultNamingContext")

'Connect to Active Directory
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

'Prompt for spreadsheet path and verify it exists
Do Until objFSO.FileExists(strExcelPath)
  strExcelPath = InputBox("Please enter the path to the Excel input file:", _
  "Excel File Path", "C:\Temp\UserList.xls")
  If strExcelPath = False Then
    WScript.Quit
  End If
Loop

'Open spreadsheet
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

'Start with row 2 of spreadsheet assuming first row has column headings
iRow = 2

'Read each row of the spreadsheet until a blank value is encountered in
'column 1
Do While objSheet.Cells(iRow, 1).Value <> ""
  strUsername = Trim(objSheet.Cells(iRow, 1).Value)
  strEmail = Trim(objSheet.Cells(iRow, 2).Value)
  strAttrib2 = Trim(objSheet.Cells(iRow, 3).Value)
  strAttrib3 = Trim(objSheet.Cells(iRow, 4).Value)
  
  'Search AD Domain to verify Pre 2000 username exists
  objCommand.CommandText = "SELECT distinguishedName, ADsPath FROM '" & strADsPath & _
  "' WHERE objectCategory='user' AND sAMAccountName='" & strUsername & "'"
  Set objRecordSet = objCommand.Execute
  If objRecordSet.EOF Then
    objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
    WScript.Echo "User " & strUsername & " not found"
    
  Else
    On Error Resume Next
    strUserADsPath = objRecordSet.Fields("ADsPath").Value
    Set objUserAccount = GetObject(strUserADsPath)
    
    Dim arrAddresses()
    Dim intIndex
    
    intIndex = -1
    
    If strEmail <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strEmail
      Else
        arrAddresses(intIndex) = "smtp:" & strEmail
      End If
    End If
    
    If strAttrib2 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strAttrib2
      Else
        arrAddresses(intIndex) = "smtp:" & strAttrib2
      End If
    End If
    
    If strAttrib3 <> "" Then
      intIndex = intIndex + 1
      ReDim Preserve arrAddresses(intIndex)
      
      If (intIndex = 0) Then
        arrAddresses(intIndex) = "SMTP:" & strAttrib3
      Else
        arrAddresses(intIndex) = "smtp:" & strAttrib3
      End If
    End If
    
    If (intIndex >= 0) Then
      objUserAccount.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrAddresses
      objUserAccount.SetInfo 'Writes settings to AD
    End If
    
    If err.number = 0 Then
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 4
      WScript.Echo strUsername & " updated successfully"
    Else
      objExcel.Cells(iRow, 1).Interior.ColorIndex = 3
      WScript.Echo "Error updating " & strUsername
    End If
    
    Err.Clear
    On Error goto 0
  End If
  iRow = iRow+1
Loop

WScript.Echo
WScript.Echo "Script Finished"

'Save and Close Excel
objExcel.ActiveWorkbook.Save
objExcel.Workbooks.Close
objExcel.Quit

Open in new window

0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When it comes to writing scripts for a Client/Server computing environment it is essential to consider some way of enabling the authentication functionality within a script. This sort of consideration mainly comes into the picture when we are dealin…
This is pretty cool.  The purpose of this VB Script is to help you document where JAR (Java ARchive) files and specifically java class files are located so that you can address issues seen with a client or that you can speak intelligently with a dev…
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
In this video, Percona Director of Solution Engineering Jon Tobin discusses the function and features of Percona Server for MongoDB. How Percona can help Percona can help you determine if Percona Server for MongoDB is the right solution for …

650 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question