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)
Related
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.
Can anyone help me to get All Attributes of given user in given group from active-directory using Vb Script .
On Error Resume Next
Set objGroup = GetObject _
("LDAP://CN=Domain Admins,CN=Users,DC=IMTS,DC=TEST")
objGroup.GetInfo
arrMemberOf = objGroup.GetEx("member")
WScript.Echo "Members:"
For Each strMember in arrMemberOf
WScript.echo strMember.distinguishedName
Next
This is giving me only users in group but i want all attributes on given user
eg:
Account_Expires:
Account_Name_History:
CS_PolicyName:
Admin_Count:
Admin_Description:
Admin_DisplayName:
AllowedAttributes:
AllowedAttributesEffective:
Allowed_Child_Classes:
AllowedChildClassesEffective:
AltSecurityIdentities:
AttributeCertificateAttribute:
Audio:
Bad_Password_Time:
Bad_Pwd_Count:
Bridge_head_ServerListBL:
BusinessCategory:
C:
canonicalName:
carLicense:
co:
So on
Thanks
note: Sorry, I'm not in an environment where I could test it and all this answer is just a memory exercise. I hope it can help
You could try to query the LDAP schema for the User class
Set oSchema = GetObject("LDAP://schema/user")
Then, you can iterate over the MandatoryProperties and OptionalProperties collections storing the retrieved values to later check your users for these attributes
Set oAttributesList = WScript.CreateObject("Scripting.Dictionary")
For Each strAttribute In oSchema.MandatoryProperties
oAttributesList.Add strAttribute, ""
Next
For Each strAttribute In oSchema.OptionalProperties
oAttributesList.Add strAttribute, ""
Next
And once you have the full list, you could use GetEx to retrieve (as an array) the value of each of the attributes for each of the users
Set objGroup = GetObject _
("LDAP://CN=Domain Admins,CN=Users,DC=IMTS,DC=TEST")
objGroup.GetInfo
arrMemberOf = objGroup.GetEx("member")
WScript.Echo "Members:"
For Each strMember in arrMemberOf
Set oMember = GetObject("LDAP://" & strMember)
For Each strAttribute in oAttributesList.Keys
WScript.Echo strAttribute
aData = oMember.GetEx(strAttribute)
For i = 0 to UBound(aData)
WScript.Echo "....: " & aData(i)
Next
WScript.Echo ""
Next
Next
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.
I have cut down the script to be as simple as possible. The issue is inserting an image in a table for Outlook 2013. This script works with older versions.
1 table, 1 row, 2 columns and using the AddPicture in a cell kills the script!
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
Full script below. Any work arounds would be appreciated.
'-------------
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strMail = objuser.mail
strLogo = "c:\1.jpg"
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objRange = objDoc.Range()
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
objTable.Cell(1, 2).select
objSelection.TypeParagraph()
objSelection.TypeText strName
objSelection.Font.Bold = false
objSelection.TypeParagraph()
objSelection.TypeText strMail
objSignatureEntries.Add "Signature", objRange
objSignatureObject.NewMessageSignature = "Signature"
objSignatureObject.ReplyMessageSignature = "Signature"
objDoc.Saved = True
objWord.Quit
'----------------
Your error is obvious:
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
this cannot work because you try to assign to .Text something that is not a string. Moreover: This has never worked, you just never noticed.
.AddPicture() already does all you want, just select the right spot in the document before:
objTable.Cell(1, 1).Select
objSelection.InlineShapes.AddPicture(strLogo)
Apart from this your script violates a few basic rules.
Always use Option Explicit. No exceptions, no "but", no arguments with "quick" or "only".
Never use On Error Resume Next as a global setting.
Write functions/subs to wrap up steps that can fail. On Error Resume Next has function scope, you can switch it on in a function to guard a line that can throw an error and it will be reset when the function ends.
If you can't/don't want to create an extra function, use On Error Goto 0 to end the effect of On Error Resume Next as soon as possible, but not before you've checked the Err variable to handle the error yourself.
Write functions/subs to structure your code.
A matter of preference, but I like to use With blocks.
Another matter of preference, but Hungarian notation makes no sense. By convention I use PascalCase for objects and camelCase for primitive values (strings, numbers, dates), along with speaking variable names.
Here's an improved version:
Option Explicit
Dim User, logo
Set User = GetCurrentUser
logo = "C:\1.jpg"
If Not User Is Nothing Then
CreateEmailSignature User, logo
Else
WScript.Echo "Could not retrieve user from AD."
End If
'------------------------------------------------------------------------------
Function GetCurrentUser()
Set GetCurrentUser = Nothing
On Error Resume Next
Set GetCurrentUser = GetObject("LDAP://" & CreateObject("ADSystemInfo").UserName)
End Function
'------------------------------------------------------------------------------
Sub CreateEmailSignature(ADUser, logoPath)
Dim Doc, Table
With CreateObject("Word.Application")
Set Doc = .Documents.Add
Set Table = Doc.Tables.Add(Doc.Range, 1, 2)
Table.Cell(1, 1).Select
InsertPictureFromFile .Selection, logoPath
Table.Cell(1, 2).Select
.Selection.TypeParagraph
.Selection.TypeText ADUser.FullName
.Selection.Font.Bold = False
.Selection.TypeParagraph
.Selection.TypeText ADUser.Mail
With .EmailOptions.EmailSignature
.EmailSignatureEntries.Add "Signature", Doc.Range
.NewMessageSignature = "Signature"
.ReplyMessageSignature = "Signature"
End With
Doc.Close False
.Quit False
End With
End Sub
'------------------------------------------------------------------------------
Sub InsertPictureFromFile(Selection, picturePath)
On Error Resume Next
Selection.InlineShapes.AddPicture picturePath
End Sub
'------------------------------------------------------------------------------
I found out that it is a 64 bit Office issue.
I have reinstalled on multiple pc's using 32 bit Office 2013 and everything works as it should.
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