Solved

Help Updating a VB Script

Posted on 2011-09-12
5
247 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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Script to copy or move mouse-selected collection of files plus targets referenced by shortcuts (.lnk) The purpose of this article is to help illuminate the real challenges and options available (where they may exist) for utilizing simple scriptin…
Welcome, welcome!  If you are new to the series and haven't been following along, please take a brief moment to review the first three installments: Part 1 (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/A_266-VBScri…
Illustrator's Shape Builder tool will let you combine shapes visually and interactively. This video shows the Mac version, but the tool works the same way in Windows. To follow along with this video, you can draw your own shapes or download the file…
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…

747 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

12 Experts available now in Live!

Get 1:1 Help Now