Solved

Help Updating a VB Script

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

PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

Question has a verified solution.

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

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…
Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
This Micro Tutorial will give you a basic overview how to record your screen with Microsoft Expression Encoder. This program is still free and open for the public to download. This will be demonstrated using Microsoft Expression Encoder 4.

832 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