Solved

Help Updating a VB Script

Posted on 2011-09-12
5
248 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
  • 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 500 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This tutorial gives a high-level tour of the interface of Marketo (a marketing automation tool to help businesses track and engage prospective customers and drive them to purchase). You will see the main areas including Marketing Activities, Design …
With the power of JIRA, there's an unlimited number of ways you can customize it, use it and benefit from it. With that in mind, there's bound to be things that I wasn't able to cover in this course. With this summary we'll look at some places to go…

895 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now