Invalid Parameter error when setting a registry multiStringValue using vbscript - vbscript

This is in reference to an existing question I previously asked but same conditions are not working when doing another sub. All variables below are defined correct and as strings. I am getting error when setting values on this line:
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
The code is below;
return = objReg.getMultiStringValue (HKCU,IE_Main,mStrSecStartPages,multiStringValues)
'If values found in Secondary Start Pages
If return=0 Then
ReDim allURLs(0)
'Read all values and only store non intranet values to array
For Each itemname In multiStringValues
If itemname <> strFunctionIntranet1 And itemname <> strFunctionIntranet2 And itemname <> strFunctionIntranet3 And itemname <> strFunctionIntranet4 Then
ReDim Preserve allURLs(UBound(allURLs)+1)
allURLs(UBound(allURLs)) = itemname
End If
Next
'Remove current key holding existing values
objReg.DeleteValue HKCU,IE_Main,mStrSecStartPages
'Set new values based on values read and user's intranet
if UBound(allURLs)>=0 Then
wscript.echo "in setting"
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
End If
wscript.echo "out setting"
End If

Problem is even if there isn't any values in the REG_MULTI_SZ value you will still get an empty Array returned, which means when you then loop through the array and dynamically expand it using
ReDim Preserve allURLs(UBound(allURLs)+1)
You will always have a blank element in the first position in the array which when passed to
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
if it isn't the only element you will get
SWbemObjectEx: Invalid parameter
Here is some testing I did to prove this
Option Explicit
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oReg
Dim strKeyPath, strValueName, arrStringValues
Dim strComputer: strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Internet Explorer\Main"
strValueName = "Default_Secondary_Page_URL"
Dim rtn
rtn = oReg.GetMultiStringValue(HKEY_LOCAL_MACHINE, strKeyPath, strValueName, arrStringValues)
Dim i
If rtn = 0 Then
If IsArray(arrStringValues) Then
For i = 0 To UBound(arrStringValues)
WScript.Echo "arrStringValues(" & i & ") = " & arrStringValues(i)
Next
Else
WScript.Echo "Not Array"
End If
Else
WScript.Echo "Failed to GetMultiStringValue - Return (" & rtn & ")"
End If
rtn = oReg.SetMultiStringValue(HKEY_LOCAL_MACHINE,strKeyPath,strValueName,arrStringValues)
WScript.Echo "SetMultiStringValue - Return (" & rtn & ")"
Output:
arrStringValues(0) =
SetMultiStringValue - Return (0)
Adding the following line to create two blank elements under the IsArray() check
ReDim Preserve arrStringValues(UBound(arrStringValues) + 1)
Output:
arrStringValues(0) =
arrStringValues(1) =
test36.vbs(31, 1) SWbemObjectEx: Invalid parameter
So SetMultiSringValue() will accept an Array that contains an empty element if it is the only element in the array, the minute you try to add more you will get the error as described above.
In relation to the original code
To stop creating the extra blank element at the beginning you could switch to using a For instead of a For Each that way you can tell the loop to only call
ReDim Preserve allURLs(UBound(allURLs)+1)
when the index of the Array is greater then 0
For i = 0 To UBound(multiStringValues)
itemname = multiStringValues(i)
If itemname <> strFunctionIntranet1 And itemname <> strFunctionIntranet2 And itemname <> strFunctionIntranet3 And itemname <> strFunctionIntranet4 Then
'Only expand if we have more then 1 value in multiStringValues
If i > 0 Then ReDim Preserve allURLs(UBound(allURLs)+1)
allURLs(UBound(allURLs)) = itemname
End If
Next
You can do this with a For Each of course but you would have to track the Array index manually using another variable, which in my opinion when you have For already seems pointless.

Related

replacing XML values in For-Each and returning in function

The script I have here is attempting to do recurse through an XML file, storing each RegEx match (stored in a search array) into 2 result arrays; 1 for start date, 1 for end date.
Ubounds of both arrays are checked for equality then the text is passed to a function that uses XMLDOM to find the End_Date node in each parent node, then passes that text to another function, adding 30 days and then passing it back, replacing the previous value. Then it's supposed to write back the contents to the file and save it.
I've got a few problems here. 1. I can't get the +30 day value to be passed back to anything past the first parent node--memory space seems to retain the +30 day value from previous For-Each iteration. 2. I can't write anything back to the file.
I was initially writing for text files, but the format changed to XML as the requirements changed on our project.
I'd love to be able to do this all in XMLDOM in vbscript and just use functions to do specific data changes. But my main concern is my sloppy script not doing the basics.
Can anyone help me by pointing out the flaws in the loops I'm running? I've hit a wall and just can't seem to make any more progress!
Here's the XML file I'm reading(shortened to 2 Ad nodes w/ a ton of child nodes removed):
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot>
<ADS_CREATE_TIME>2016-06-07T01:35:39</ADS_CREATE_TIME>
<Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad>
</XMLFeederRoot>
Here's the script:
'Setting the Regular Expression object and setting occurrences to all in strings searched.
Set objRegEx= CreateObject("VBScript.RegExp")
objRegEx.Global= True
set Shell= createobject("wscript.shell")
Dim FSO, FLD, FIL, TS, strDate, strEDat, i, d, c
Dim strFolder, strContent, strPath
Const ForReading= 1, ForWriting= 2
strFolder= "C:\Scripts\Run"
Set FSO= CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
set FLD= FSO.GetFolder(strFolder)
'loop through the folder and get the files
For Each Fil In FLD.Files
'Open the file to read
Set TS= FSO.OpenTextFile(fil.Path, ForReading)
'Read the contents into a variable
strContent= TS.ReadAll
'Close the file
TS.Close
reDim arrMR(1,1)
arrMR(0,0)= "(\s+)(<Start_Date>(.*?)<\/Start_Date>)"
arrMR(1,0)= "(\s+)(<End_Date>(.*?)<\/End_Date>)"
For i= 0 to Ubound(arrMR)
objRegEx.Pattern= arrMR(i,0)
Set objMatches= objRegEx.Execute(strContent)
d=0
For Each objMatch in objMatches
If i= 0 Then
If d>0 Then
reDim Preserve arrStart(d)
Else
reDim arrStart(d)
End If
arrStart(d)= objMatches.Item(d).SubMatches(2)
'Wscript.Echo arrStart(d)
ElseIf i<> 0 Then
If d>0 Then
reDim Preserve arrEnd(d)
ReDim Preserve arrMatch1(d)
Else
reDim arrEnd(d)
ReDim arrMatch1(d)
End If
arrEnd(d)= objMatches.Item(d).SubMatches(2)
arrMatch1(d)= objMatches.Item(d).SubMatches(1)
End If
If objRegEx.Pattern<> arrMR(0,0) Then
If (ubound(arrStart)= ubound(arrEnd)) Then
'Wscript.Echo "Ubounds Match"
Parse strContent
strContent= Parse(strContent)
Else
'Wscript.Echo "Start & End Dates do not match"
End If
End If
d= d+ 1 'increment to next match
Next
Next
'Close the file
TS.Close
'Open the file to overwrite the contents
Set TS= FSO.OpenTextFile(fil.Path, ForWriting)
'Write the contents back
TS.Write strContent
'Close the current file
TS.Close
Next
'Clean up
Set TS= Nothing
Set FLD= Nothing
Set FSO= Nothing
Function Parse(ParseContent)
'Dim sFSpec : sFSpec = FSO.GetAbsolutePathName("C:\Users\j.levine\Desktop\XML Feeder Scripts\Test_Files\monvid.txt")
Dim oXML : Set oXML = CreateObject("Msxml2.DOMDocument.6.0")
Dim strXMLSDat, strXMLarrStartD, XMLEDat
oXML.setProperty "SelectionLanguage", "XPath"
oXML.async = False
oXML.loadXML(ParseContent)
If 0 = oXML.parseError Then
Dim sXPath3 : sXPath3 = "//XMLFeederRoot/Ad[End_Date=Start_Date]"
Dim ndlFnd : Set ndlFnd = oXML.selectNodes(sXPath3)
If 0 = ndlFnd.length Then
WScript.Echo sXPath, "not found"
ElseIf 0<> ndlFnd.length Then
'WScript.Echo "found", ndlFnd.length, "nodes for", sXPath
Dim ndCur, oldNode
For Each ndCur In ndlFnd
oldNode = oXML.selectsinglenode("//End_Date").text
oldNode= XMLSplitArray(oldNode) 'Pass current Date into Array and add 30 days & return as node text
Set newNode= oXML.selectSingleNode("//End_Date")
newNode.text= oldNode
WScript.Echo ndCur.xml
Next
'WScript.Echo "We have nothing to replace"
End If
Else
WScript.Echo oXML.parseError.reason
End If
Parse= ParseContent
End Function
Function XMLSplitArray(strval1)
dim XmlSA, XmlSA2, XMLEDat
XmlSA = split(strval1, "-")
XmlSA(2) = Left(XmlSA(2), 2)
strXMLDate = XmlSA(1) & "/" & XmlSA(2) & "/" & XmlSA(0)
strXMLDate30 = DateAdd("d", 30, strXMLDate)
XmlSA2 = split(strXMLDate30, "/")
'Add zero to the left
XmlSA2(0)= Right("0" & XmlSA2(0), 2)
XmlSA2(1)= Right("0" & XmlSA2(1), 2)
XmlSA2(1) = XmlSA2(1) & "T00:00:00"
XMLEDat = XmlSA2(2) & "-" & XmlSA2(0) & "-" & XmlSA2(1)
XMLSplitArray= XMLEDat
End Function
Thomas was right w/ the KISS method. I took a big step back, and started over.
Here's what I've come up with. It does what I need regarding the Date+30 and writing back to a file. I think this method is cleaner and will allow me to run my other text massaging through functions.
My questions about this new script are:
1. can this be done without having to write to a new file? Keeping to 1 file is easier.
2. Can I avoid cloning the node and deleting the original one and directly change the original node's value?
3. I seem to be missing how to get that last node <Status> onto it's own line.
Script:
Dim xmlDoc: Set xmlDoc = CreateObject("Msxml2.DOMDocument")
xmlDoc.Async = False
xmlDoc.load "C:\Scripts\Run\MonVid-SHORT.xml"
Dim xmldoc2: set xmldoc2 = CreateObject("Msxml2.DOMDocument")
Dim strSkeleton : strSkeleton= "<?xml version=""1.0"" encoding=""utf-8""?>" & _
"<XMLFeederRoot>" & _
"</XMLFeederRoot>"
xmldoc2.loadXML(strSkeleton)
xmldoc2.save "C:\Scripts\Copy\New_MonVid-Short.xml"
xmlDoc2.async = False
xmlDoc2.load "C:\Scripts\Copy\New_MonVid-Short.xml"
Dim sXPath : sXPath = "/XMLFeederRoot/Ad[Start_Date=End_Date]"
For Each n In XMLDoc.SelectNodes(sXpath)
set l = n.cloneNode(True)
q= l.selectSingleNode("/End_Date").text
strSDat=SplitArray(q)
l.removeChild(l.childNodes.item(2))
set Stat= l.selectSingleNode("/Status")
set Parent= Stat.parentNode
set EDate= xmlDoc2.createElement("End_Date")
EDate.appendChild xmlDoc2.createTextNode(strSDat)
Parent.insertBefore EDate, Stat
xmldoc2.documentElement.appendChild parent
Next
xmlDoc2.save xmldoc2.url
Function SplitArray(strval1)
dim SplitArray1, SplitArray2, strSDat
splitArray1 = split(strval1, "-")
splitArray1(2) = left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function
Output File:
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot><Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad>
</XMLFeederRoot>
Since Text and XML files don't use file locks by default just overwrite the original file using xmlDoc.Save monvidPath.
Sub setAdEndDate(monvidPath)
Const sXPath = "/XMLFeederRoot/Ad/End_Date"
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.Async = "False"
xmlDoc.Load(monvidPath)
Set colNodes=xmlDoc.selectNodes(sXPath)
For Each n In colNodes
n.Text = SplitArray(n.Text)
Next
xmlDoc.Save monvidPath
End Sub
Function SplitArray(strval1)
Dim SplitArray1, SplitArray2, strSDat
splitArray1 = Split(strval1, "-")
splitArray1(2) = Left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = Split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function

add multiple multi string values to registry using array

Code is cleaned and changed from previous post since old logics had various errors that have been corrected and narrowed down to one error in one condition that I cant find an answer to. Currently getting error when my url is being read as only value and throwing Subscript Out of range error even though array is initialized. Other conditions when user has preset items or no key at all works perfectly. Thanks.
option explicit
'on error resume next
Dim ObjName,oADSysInfo,strComputer
Dim objReg,IE_Main,mstrValName,strFunctionIntranet,strNYHomepage,multiStringValues(),allURLs(),itemname,a,return
Set oADSysInfo = CreateObject("ADSystemInfo")
Set ObjName = GetObject("LDAP://" & oADSysInfo.UserName)
strComputer = "."
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
Const HKCU = &H80000001
IE_Main = "Software\Microsoft\Internet Explorer\Main"
mstrValName = "Secondary Start Pages"
strNYHomepage = "http://www.google.com"
strFunctionIntranet = "www.mycompany.com"
SetHomePage
Sub SetHomepage
objReg.setStringValue HKCU,IE_Main,"Start Page",strNYHomepage
'Reading MultiStringValue of "Secondary Start Pages" for HKCU and continuing if it has something preset.
return = objReg.getMultiStringValue (HKCU,IE_Main,mstrValName,multiStringValues)
If return=0 Then
a=0
'Reading all items currently set to make sure users retain their existing URLs.
For Each itemname In multiStringValues
'Only continue if any of the existing URLs DO NOT MATCH what we are enforcing as the URL.
If itemname <> strFunctionIntranet Then
WScript.Echo itemname
WScript.Echo "itemname is NOT equal intranet"
a = a + 1
ReDim Preserve allURLs(a)
allURLs(a) = itemname
'a = a + 1
End If
Next
objReg.DeleteValue HKCU,IE_Main,mstrValName
'Enforce our URL to always be the first item.
allURLs(0)=strFunctionIntranet
'Set the new MultiStringValue registry key back.
objReg.setMultiStringValue HKCU,IE_Main,mstrValName,allURLs
WScript.echo "finished setting all secondary tabs... "
Else
strFunctionIntranet = Array(strFunctionIntranet)
objReg.setMultiStringValue HKCU,IE_Main,mstrValName,strFunctionIntranet
End If
End Sub
Wscript.Quit
Your array contains an empty element, because you create it one field too big.
Change this line:
ReDim Preserve allURLs(a+1)
into this:
ReDim Preserve allURLs(a)

VBScript - Retrieving a user's nested groups and getting rid of repetitions

For my work, I have to write a script in VBScript that retrieves a list of ALL groups a user belongs to, including nested groups, and take out nested groups that would be repeated throughout the list (as well as indent nested groups, further indent nested groups of nested groups, etc.)
I found a script that fetches the entire list of groups a user belongs to by Monimoy Sanyal on gallery.technet.microsoft.com, and tried to adapt it to my needs. Here is the script as edited by me:
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppend = 8
Dim ObjUser, ObjRootDSE, ObjConn, ObjRS
Dim GroupCollection, ObjGroup
Dim StrUserName, StrDomName, StrSQL
Dim GroupsList
Dim WriteFile
GroupsList = ""
Set ObjRootDSE = GetObject("LDAP://RootDSE")
StrDomName = Trim(ObjRootDSE.Get("DefaultNamingContext"))
Set ObjRootDSE = Nothing
StrUserName = InputBox("Enter user login", "Info needed", "")
StrSQL = "Select ADsPath From 'LDAP://" & StrDomName & "' Where ObjectCategory = 'User' AND SAMAccountName = '" & StrUserName & "'"
Set ObjConn = CreateObject("ADODB.Connection")
ObjConn.Provider = "ADsDSOObject": ObjConn.Open "Active Directory Provider"
Set ObjRS = CreateObject("ADODB.Recordset")
ObjRS.Open StrSQL, ObjConn
If Not ObjRS.EOF Then
ObjRS.MoveLast: ObjRS.MoveFirst
Set ObjUser = GetObject (Trim(ObjRS.Fields("ADsPath").Value))
Set GroupCollection = ObjUser.Groups
WScript.Echo "Looking for groups " & StrUserName & " is member of. This may take some time..."
'Groups with direct membership, and calling recursive function for nested groups
For Each ObjGroup In GroupCollection
GroupsList = GroupsList + ObjGroup.CN + VbCrLf
CheckForNestedGroup ObjGroup
Next
Set ObjGroup = Nothing: Set GroupCollection = Nothing: Set ObjUser = Nothing
'Writing list in a file named Groups <username>.txt
Set WriteFile = WScript.CreateObject("WScript.Shell")
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("Groups " & StrUserName & ".txt", ForWriting,true)
f.write(GroupsList)
f.Close
WScript.Echo "You can find the list in the Groups " &StrUserName & ".txt file that has just been created."
Else
WScript.Echo "Couldn't find user " & StrUserName & " in AD."
End If
ObjRS.Close: Set ObjRS = Nothing
ObjConn.Close: Set ObjConn = Nothing
'Recursive fucntion
Private Sub CheckForNestedGroup(ObjThisGroupNestingCheck)
On Error Resume Next
Dim AllMembersCollection, StrMember, StrADsPath, ObjThisIsNestedGroup
AllMembersCollection = ObjThisGroupNestingCheck.GetEx("MemberOf")
For Each StrMember in AllMembersCollection
StrADsPath = "LDAP://" & StrMember
Set ObjThisIsNestedGroup = GetObject(StrADsPath)
'Not include a group in the list if it is already in the list (does not work for some reason?)
If InStr(GroupsList, ObjThisIsNestedGroup.CN) = 0 Then
GroupsList = GroupsList + vbTab + ObjThisIsNestedGroup.CN + VbCrLf
End If
'Recursion to look for nested groups and nested groups of nested groups and nested groups of nested groups of nested groups and...
CheckForNestedGroup ObjThisIsNestedGroup
Next
Set ObjThisIsNestedGroup = Nothing: Set StrMember = Nothing: Set AllMembersCollection = Nothing
End Sub
Rather than display a popup for EACH group found like the original script did, I store the entire list in a String (GroupsList = GroupsList + ObjGroup.CN + VbCrLf for direct groups, GroupsList = GroupsList + vbTab + ObjThisIsNestedGroup.CN + VbCrLf for nested groups in the recursive function,) and once the script is done looking for groups, it saves the String in a file. (f.write(GroupsList))
My problem is, despite the If "InStr(GroupsList, ObjThisIsNestedGroup.CN) = 0 in the recursive function, I still find myself with tons of repetitions throughout the results (our AD is kind of bloated with groups, it is a huge structure with many nested groups and nested groups in other nested groups, etc.) and the check doesn't seem to notice that ObjThisIsNestedGroup.CN is already found in GroupsList.
And I have no idea how to implement the indentation properly.
Any ideas? I'm rather new at scripting, so forgive me if the answer is obvious.
Add the groups as keys to a Dictionary, so the list contains only unique names, and Join() the Keys array for output:
Set GroupsList = CreateObject("Scripting.Dictionary")
GroupsList.CompareMode = vbTextCompare 'make keys case-insensitive
...
GroupsList(ObjGroup.CN) = True
...
f.Write Join(GroupsList.Keys, vbNewLine)
I found the solution for both problems. Well, the first problem I'm not sure how I fixed since I only reverted the code after making a modification and then it was magically working.
For the increasing indentation, I declared a global variable named RecurCount that I increment every time I call the recursive procedure, and decrease after the procedure. Then, within the procedure, I added a For i = 0 to RecurCount that adds a varying number of vbTabs depending on RecurCount.
Here's the working procedure:
Private Sub CheckForNestedGroup(ObjThisGroupNestingCheck)
On Error Resume Next
Dim AllMembersCollection, StrMember, StrADsPath, ObjThisIsNestedGroup, TabAdd, i
AllMembersCollection = ObjThisGroupNestingCheck.GetEx("MemberOf")
For Each StrMember in AllMembersCollection
If StrMember <> "" Then
StrADsPath = "LDAP://" & StrMember
Set ObjThisIsNestedGroup = GetObject(StrADsPath)
'If InStr(GroupsList, ObjThisIsNestedGroup.CN) = 0 Then (Uncomment this If and indent lines below to remove groups already in the list)
TabAdd = ""
For i = 0 to Recurcount
TabAdd = TabAdd & vbTab
Next
GroupsList = GroupsList & TabAdd & " " & ObjThisIsNestedGroup.CN & VbCrLf
'End If
'Recursion to include nested groups of nested groups
Recurcount = Recurcount + 1
CheckForNestedGroup ObjThisIsNestedGroup
Recurcount = Recurcount - 1
End If
Next
Set ObjThisIsNestedGroup = Nothing: Set StrMember = Nothing: Set AllMembersCollection = Nothing
End Sub
Don't forget to Dim Recurcount in the main script, and to make it 0 right before calling CheckForNestedGroup for the first time.

Output array to MsgBox

I do PowerShell not VBScript, so I am a little lost. I am trying to list all mapped drives (drive letter and share path) in a MsgBox. I get a type mismatch error when running the script. If I change "Dim myArray()" to "Dim myArray" I get only one item from the variable.
Set objNetwork = WScript.CreateObject("WScript.Network")
Set colDrives = objNetwork.EnumNetworkDrives
Dim myArray()
For i = 0 to colDrives.Count-1 Step 2
myArray = colDrives.Item(i) & vbTab & colDrives.Item (i + 1)
Next
MsgBox(myArray)
How can I get the data saved to an array, then output to a MsgBox?
The reason why your code doesn't work is because you're creating fixed-size array without an actual size (Dim myArray()), and then try to assign values to that array. In VBScript you must assign values to array positions (myArray(pos) = val), and you cannot append to the built-in arrays (at least not without some additional work).
The most straightforward approach in your case would be the method #Bond suggested. However, you can do this with arrays if you want. You just need a resizable array like this:
ReDim myArray(-1) 'empty array
For i = 0 to colDrives.Count-1 Step 2
ReDim Preserve myArray(UBound(myArray)+1)
myArray(UBound(myArray)) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray, vbNewLine)
or (using an ArrayList), like this:
Set myArray = CreateObject("System.Collections.ArrayList")
For i = 0 to colDrives.Count-1 Step 2
myArray.Add colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray.ToArray, vbNewLine)
Since the size of the array can already be determined before entering the loop you could also dimension the array with the proper size right away to avoid repeated redimensioning (which tends to perform poorly for VBScript built-in arrays):
ReDim myArray(colDrives.Count \ 2 - 1)
For i = 0 to colDrives.Count-1 Step 2
myArray(i\2) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray, vbNewLine)
Another option would be using a Dictionary:
Set myArray = CreateObject("Scripting.Dictionary")
For i = 0 to colDrives.Count-1 Step 2
myArray(colDrives.Item(i)) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray.Items, vbNewLine)
You can use a string and keep appending (&) to it.
Dim s
For i = 0 To colDrives.Count-1 Step 2
s = s & colDrives.Item(i) & vbTab & colDrives.Item (i + 1) & vbCrLf
Next
MsgBox s

VBS Script for modifying multi-value Active Directory display specifier

Following the howto Extending the Active Directory Schema To Track Custom Info I'm able to setup a single-value schema attribute that is easily changeable via a context menu in ADUC. Multi-value schema attributes get considerably more complicated. Say (for the sake of argument) my value is "Projects" and each user may be a list as many projects as necessary.
Following is a sad little script that will set Project to a single value:
Dim oproject
Dim oUser1
Dim temp1
Set oproject = Wscript.Arguments
Set oUser1 = GetObject(oproject(0))
temp1 = InputBox("Project: " & oUser1.project & vbCRLF & vbCRLF & "Project")
if temp1 <> "" then oUser1.Put "project",temp1
oUser1.SetInfo
Set oUser1 = Nothing
Set oproject = Nothing
Set temp1 = Nothing
WScript.Quit
How can I modify this to allow, assign, and modify multiple values?
I gave up on an elegant UI and just went with the semicolon delimited list. Here's the code if anyone cares:
Dim objProject
Dim objUser
Dim temp1, title, message, default
Dim projects
title = "Projects"
Set objProject = Wscript.Arguments
Set objUser = GetObject(objProject(0))
'Find our current projects
projects = objUser.projects
If Not isArray(projects) Then
projects = Array(projects)
End If
'Setup our message box
message = "Semicolon-delimited list of Projects"
default = arrayToStr(projects)
temp1 = InputBox(message, title, default)
'catch cancels
if IsEmpty(temp1) Then
WScript.Quit
End If
' update our data
projects = strToArray(temp1)
objUser.Put "projects",projects
objUser.SetInfo
'Clean up and quit
Set projects = Nothing
Set objUser = Nothing
Set objProject = Nothing
Set temp1 = Nothing
Set title = Nothing
Set message = Nothing
Set default = Nothing
WScript.Quit
'Functions
Function strToArray(s)
Dim a
Dim token
' discard blank entries
For Each token in split(s, ";")
token = trim(token)
If token <> "" Then
If isEmpty(a) Then
a = token
Else
a = a & ";" & token
End If
End If
Next
' return array
strToArray = split(a, ";")
End Function
Function arrayToStr(a)
Dim s
Dim token
For Each token in a
If isEmpty(s) Then
s = token
Else
s = s & ";" & token
End If
Next
' return string
arrayToStr = s
End Function

Resources