VBScript - Execute script for each value of array - vbscript

I want to change the code below, so that it executes the sas guide project (.egp) and changes the parameter value according to the values of the array. (The idea is to open the project, run to the value of the array (0), close the project; open the project, run to the value array (1); ... until the array (n)).
But it executes only for the first value of the array, not the sequence for the other values. What's the mistake?
I added the line (for t = 0 to UBound (id)) and put (Next) before app.Quit
Dim t
Dim id
id=Array("111111111","22222222","33333333")
'-----------------------------------
' The name and location of the project file that will be opened and run by this script.
prjName = "C:\SAS\EG\Samples\XXXXX.egp" 'Project Name
for t = 0 to UBound(id)
And at the end of the code
Next
app.Quit
The full code
Option Explicit
'----------------------------------------------------------------
'AutomationPrompts.vbs
'This example program demonstrates how to use the 4.2 SAS Enterprise Guide
'automation interface to access and modify the prompts for a project and a stored
'process within that project. The project is opened and the project prompt names
'and values are displayed to the user. Subsequently, the stored processes within
'the project are opened and their prompt names and values are then displayed.
'
'The prompt value for the stored process is changed to 'M' (for male), the project
'is saved then run.
'
'The project is called AutomationwithPrompts.egp and the prjName variable should be
'modified to reflect the location of this proejct on the machine that is running
'this script.
'----------------------------------------------------------------
'--------------
'Declare the variables that will be used in the program
'--------------
Dim app
Dim prjName
Dim prjObject
Dim parmList
Dim parm
Dim spList
Dim sp
Dim spParamList
Dim spParam
Dim spParamName
Dim spParamValue
Dim n
Dim i
Dim t
Dim id
id=Array("111111111","22222222","33333333")
'-----------------------------------
' The name and location of the project file that will be opened and run by this script.
prjName = "C:\SAS\EG\Samples\XXXXX.egp" 'Project Name
for t = 0 to UBound(id)
' Start the app and open the project
Set app = CreateObject("SASEGObjectModel.Application.8.1")
Set prjObject = app.Open(prjName,"")
'---------------------------------
'Begin processing the project
'---------------------------------
' Discover the parameters for the project
Set parmList = prjObject.Parameters
Wscript.Echo "Project has " & parmList.Count & " parameters."
' Get the default value from the first parameter
Set parm = parmList.Item(0)
WScript.Echo parm.Name & " parameter has default value of " & parm.DefaultValue
' Change the value of the parameter to 'M' and display the new value.
parm.Value = id(t)
WScript.Echo parm.Name & " parameter has been set to value of " & parm.Value
'-------------------------------
'Begin processing the stored process
'-------------------------------
Set spList = prjObject.StoredProcessCollection
' Get the number of parameters for the store process
Wscript.Echo "StoredProcess has " & spList.Count & " parameters."
' Cycle through the list of stored processes and the parameters for each of them.
for n=0 to (spList.Count - 1)
Set sp = spList.Item(n)
' Get the list of parameters
Set spParamList = sp.Parameters
' Process each stored process parameter
for i=0 to (spParamList.Count - 1)
Set spParam = spParamList.Item(i)
' Get the name and default value for the parameter
spParamName = spParam.Name
spParamValue = spParam.DefaultValue
' Display the parameter information to the user
WScript.Echo spParamName & " parameter has default value of " & spParamValue
' Change the value of the parameter
spParam.Value = id(t)
' Display the modified value
WScript.Echo spParamName & " parameter has been set to value of " & spParam.Value
' Save the project with the updated stored process
prjObject.Save
Next
Next
' Run the new project
prjObject.Run
' Make sure the project is saved after it has been run.
prjObject.Save
' Close the project and application.
prjObject.Close
Next
app.Quit

I got it, the final code is below.
Option Explicit
'--------------
Dim app
Dim prjName
Dim prjObject
Dim parmList
Dim parm
Dim n
Dim i
Dim t
Dim id
id=Array("111111111","22222222","33333333")
'-----------------------------------
' The name and location of the project file that will be opened and run by this script.
prjName = "C:\SAS\EG\Samples\XXXXX.egp" 'Project Name
' Start the app and open the project
Set app = CreateObject("SASEGObjectModel.Application.8.1")
Set prjObject = app.Open(prjName,"")
'---------------------------------
'Begin processing the project
'---------------------------------
for t = 0 to UBound(id)
' Discover the parameters for the project
Set parmList = prjObject.Parameters
Wscript.Echo "Project has " & parmList.Count & " parameters."
' Get the default value from the first parameter
Set parm = parmList.Item(0)
WScript.Echo parm.Name & " parameter has default value of " & parm.DefaultValue
' Change the value of the parameter and display the new value.
parm.Value = id(t)
WScript.Echo parm.Name & " parameter has been set to value of " & parm.Value
' Run the new project
prjObject.Run
WScript.Sleep 5000
Next
' Make sure the project is saved after it has been run.
prjObject.Save
' Close the project and application.
prjObject.Close
app.Quit

Related

Using vbscript to save OpenOffice/Spreadsheet csv file [duplicate]

I'm trying to write a script for a while now but it seems that one part of it just does not work.
Situation: I need a VB script that can use any LibreOffice (/ OpenOffice) Calc (3.5.4 in my case) installation on any Windows XP or 7 system for export of xls to csv (as many csv files as there are sheets in the xls). It has to be VBS and LibreOffice in this case. No macro installed, everything controlled externally by vbscript.
So, first step was to use the macro recorder in order to get the right filter settings.
StarBasic macro:
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args1(2) as new com.sun.star.beans.PropertyValue
args1(0).Name = "URL"
args1(0).Value = "file:///C:/Users/lutz/Desktop/test.csv"
args1(1).Name = "FilterName"
args1(1).Value = "Text - txt - csv (StarCalc)"
args1(2).Name = "FilterOptions"
args1(2).Value = "9,0,76,1,,0,false,true,true"
dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1())
This macro (in LibreOffice) writes a CSV of the current sheet (after LO telling me that only the current sheet will be saved), encoding UTF-8, field separator Tab, no text separator. This works.
I tried to get this to work in my vbs but it absolutely did not. So I searched a lot in OpenOffice and LibreOffice forums, here at stackoverflow, etc. and used another method.
Problem: Everytime it saves the file(s) it saves them as ODS, no matter which filter or filter options I use. It always saves to zipped OpenDocument. I tried numerous Filters, even PDF. It seems that it works with pdf when I only use the FilterName property but somehow it doesn't work anymore. And I don't know why.
The code:
' Scripting object
Dim wshshell
' File system object
Dim objFSO
' OpenOffice / LibreOffice Service Manager
Dim objServiceManager
' OpenOffice / LibreOffice Desktop
Dim objDesktop
' Runcommand, if script does not run with Cscript
Dim runcommand
Dim Path
Dim Savepath
Dim Filename
Dim url
Dim args0(0)
Dim args1(3)
' Create File system object
Set wshshell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If files present, run Calc
If objFSO.GetFolder(".").Files.Count>0 then
Set objServiceManager = WScript.CreateObject("com.sun.star.ServiceManager")
' Create Desktop
Set objDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
else
' If no files in directory
wscript.echo "No files found!"
wscript.quit
End If
on error resume next
bError=False
For each File in objFSO.GetFolder(".").Files
if lcase(right(File.Name,3))="xls" then
' Access file
url = ConvertToURL(File.Path)
objDesktop = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
Set args0(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set objDocument = objDesktop.loadComponentFromURL(url, "_blank", 0, args0 )
' Read filenames without extension or path
Path = ConvertToURL( File.ParentFolder ) & "/"
Filename = objFSO.GetBaseName( File.Path )
Savepath = ConvertToURL( File.ParentFolder )
' set arguments
Set args1(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(1) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(2) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
Set args1(0) = MakePropertyValue( "FilterName", sFilterName )
Set args1(1) = MakePropertyValue( "FilterOptions", sFilterOptions )
Set args1(2) = MakePropertyValue( "Overwrite", sOverwrite )
' Save every sheet in separate csv file
objSheets = objDocument.Sheets
For i = 0 to objDocument.Sheets.getcount -1
objSheet = objDocument.Sheets.getByIndex(i)
Call objDocument.CurrentController.setActiveSheet(objSheet)
Call objDocument.storeToURL( ConvertToURL( File.ParentFolder & "\" & Filename & "_" & objDocument.sheets.getByIndex(i).Name & ".csv" ), args1 )
Next
' Close document
objDocument.close(True)
Set objDocument = Nothing
Path = ""
Savepath = ""
Filename = ""
Else
End If
Next
' Close / terminate LibreOffice
objDesktop.terminate
Set objDesktop = nothing
Set objServiceManager = nothing
The function ConvertToUrl is not listed here. It is a vbscript function that converts Windows paths to URL paths (file:/// etc.). It is tested and works.
What I also tried:
Saving in ods first (StoreAsUrl) then try to save in different format.
Use MakePropertyValue( "SelectionOnly", true )
None of that worked nor did it combined. I used http://extensions.services.openoffice.org/de/project/OOcalc_multi_sheets_export as a source of inspiration. But it is a macro, not direct access from an external vb script.
It seems that the problem is a general one with StoreToUrl or the properties / arguments:
Even FilterName "writer_pdf" or "Calc MS Excel 2007 XML" don't work. Problem is: I don't know what's the culprit here. The settings that the macro recorder uses are the same and if one uses the macro directly in LibreOffice it works.
Maybe someone knows what needs to get changed in the code or how I can get the dispatcher used in the macro to work.
Thank you for your help in advance!
Ok, I found the solution after days of research and tiny little information scattered everywhere. I hope that this code will serve someone well:
' Variables
Dim wshshell ' Scripting object
Dim oFSO ' Filesystem object
Dim runcommand ' Runcommand, if not run in Cscript
Dim oSM ' OpenOffice / LibreOffice Service Manager
Dim oDesk ' OpenOffice / LibreOffice Desktop
Dim oCRef ' OpenOffice / LibreOffice Core Reflections
Dim sFileName ' Filename without extension
Dim sLoadUrl ' Url for file loading
Dim sSaveUrl ' Url for file writing
Dim args0(0) ' Load arguments
' Create file system object
Set wshshell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If there are files, start Calc
If oFSO.GetFolder(".").Files.Count>0 then
' If no LibreOffice open -> run
Set oSM = WScript.CreateObject("com.sun.star.ServiceManager")
' Create desktop
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Set oCRef = oSM.createInstance( "com.sun.star.reflection.CoreReflection" )
else
' If no files in directory
wscript.quit
End If
' Error handling
on error resume next
' CSV settings for saving of file(s)
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
' load component for file access
oDesk = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
' load argument "hidden"
Set args0(0) = oSM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args0(0) = MakePropertyValue("Hidden", True)
For each oFile in oFSO.GetFolder(".").Files
if lcase(right(oFile.Name,3))="xls" then
' open file
sLoadUrl = ConvertToURL(oFile.Path)
Set oDoc = oDesk.loadComponentFromURL(sLoadUrl, "_blank", 0, args0 )
' read filename without extension or path
sFileName = oFSO.GetBaseName( oFile.Path )
' save sheets in CSVs
For i = 0 to oDoc.Sheets.getcount -1
oActSheet = oDoc.CurrentController.setActiveSheet( oDoc.Sheets.getByIndex(i) )
sSaveUrl = ConvertToURL( oFile.ParentFolder & "\" & sFileName & "_" & oDoc.sheets.getByIndex(i).Name & ".csv" )
saveCSV oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite
Next
' Close document
oDoc.close(True)
Set oDoc = Nothing
Set oActSheet = Nothing
sFileName = ""
sLoadUrl = ""
sSaveUrl = ""
Else
End If
Next
' Close LibreOffice
oDesk.terminate
Set oDesk = nothing
Set oSM = nothing
Function ConvertToURL(sFileName)
' Convert Windows pathnames to url
Dim sTmpFile
If Left(sFileName, 7) = "file://" Then
ConvertToURL = sFileName
Exit Function
End If
ConvertToURL = "file:///"
sTmpFile = oFSO.GetAbsolutePathName(sFileName)
' replace any "\" by "/"
sTmpFile = Replace(sTmpFile,"\","/")
' replace any "%" by "%25"
sTmpFile = Replace(sTmpFile,"%","%25")
' replace any " " by "%20"
sTmpFile = Replace(sTmpFile," ","%20")
ConvertToURL = ConvertToURL & sTmpFile
End Function
Function saveCSV( oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite )
' Saves the open document resp. active sheet in a single file
Dim aProps( 2 ), oProp0, oProp1, oProp2, vRet
' Set filter name and write into property array
Set oProp0 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp0.Name = "FilterName"
oProp0.Value = sFilterName
Set aProps( 0 ) = oProp0
' Set filter options and write into property array
Set oProp1 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp1.Name = "FilterOptions"
oProp1.Value = sFilterOptions
Set aProps( 1 ) = oProp1
' Set file overwrite and write into property array
Set oProp2 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp2.Name = "Overwrite"
oProp2.Value = sOverwrite
Set aProps( 2 ) = oProp2
' Save
vRet = oDoc.storeToURL( sSaveUrl, aProps )
End Function
I hope that at least this small contribution from me helps others.

VBScript error 5 trying to compute sha512 with 'System.Security.Cryptography.SHA512Managed'

I am trying to write a piece of code in VBScript to compute the
SHA512 value for a given file. According to MSFT documentation
the ComputeHash method of the SHA512Managed object requires a
Byte array as input. So I used ADODB to read the input file which
SHA512 value is to be computed (Because, AFAIK, there is no way
to build a Byte array in VBScript). However I get a runtime error 5,
'Invalid procedure call or argument' when calling the method. The
variable bar in the code below is of type Byte() - VBScript says.
Could anyone tell me what is going wrong ?
Code :
Option Explicit
'
'
'
Dim scs, ado
Dim bar, hsh
Set scs = CreateObject("System.Security.Cryptography.SHA512Managed")
Set ado = CreateObject("ADODB.Stream")
ado.type = 1 ' TypeBinary
ado.open
ado.LoadFromFile WScript.ScriptFullName
bar = ado.Read
ado.Close
MsgBox TypeName(bar) & "/" & LenB(bar) & "/" & Len(bar),,"Box 1"
' Displays : "Byte()/876/438"
On Error Resume Next
' Attempt 1
Set hsh = scs.ComputeHash(bar)
MsgBox Hex(Err.Number) & "/" & Err.Description,,"Set hsh = "
' Displays : "5/Invalid procedure call or argument"
' Attempt 2
hsh = scs.ComputeHash(bar)
MsgBox Hex(Err.Number) & "/" & Err.Description,,"hsh = "
' Displays : "5/Invalid procedure call or argument"
MsgBox TypeName(scs),,"scs" ' Displays : "SHA512Managed"
Set ado = Nothing
Set scs = Nothing
WScript.Quit
Use
hsh = scs.ComputeHash_2((bar))
(no set, _2 suffix not to pick the other ComputeHash method, pass by value ())
see here.

How to provide hostname and credentials to "LDAP://"?

I need to have an Active Directory Shadow Groups (aka Active Directory Dynamic Group), based on several DN's.
I've searched high and low for a simple tool that would allow me to do this, and finally found Dan Holme's excellent script (quoted below) at http://kb.caresys.com.cn/4052785/need-script-add-all-accounts-active-directory-security-group (and a few other places)
I also found several PowerShell scripts, but they all appear to have much harder dependencies and I need a tool that's as stand-alone as possible. They also all have the same problem as I'm faced with here.
The Group_Shadow.vbs script performs exactly what I need with one exception:
I need to be able to specify the AD's Host, port number and credentials (login and password).
The script assumes that "LDAP://" is pointing to the correct AD, and I guess the AD Credentials are derived from the user running the script?
I did find a hint about how to set the host name and password, by changing the "LDAP://" string into "LDAP://LDAP_HOST:LDAP_PORT/".
That seems pretty easy to implement - but there were a few comments stating it didn't work...
I also found a hint about setting the credentials:
Dim LDAP ' As IADsOpenDSObject
Set LDAP = GetObject("LDAP:")
Set obj = LDAP.OpenDSObject("LDAP://", "domain\name", "password", ADS_USE_ENCRYPTION OR ADS_SECURE_AUTHENTICATION)
This appear to be the hard part (being totally novice in both the VBScript and Active Directory world), and I simply can't figure out how to combine to two.
I hope the community can help me out, either by assisting fixing this script or by pointing to a different solution.
Thanks in advance!
The Script:
'==========================================================================
'
' VBScript Source File -- Created with SAPIEN Technologies PrimalScript 2007
'
' NAME: Group_Shadow.vbs
'
' AUTHOR: Dan Holme , Intelliem
' DATE : 12/12/2007
'
' USAGE:
' cscript.exe Group_Shadow.vbs
'
' Dynamically updates the membership of a group
' to match the objects returned from an Active Directory query
'
' See the Windows Administration Resource Kit for documentation
'
' Neither Microsoft nor Intelliem guarantee the performance
' of scripts, scripting examples or tools.
'
' See www.intelliem.com/resourcekit for updates to this script
'
' (c) 2007 Intelliem, Inc
'==========================================================================
Option Explicit
Dim sDomainDN
Dim sGroupSAMAccountName
Dim aSearchOUs
Dim sQuery
'==========================================================================
' CONFIGURATION BLOCK
' Domain's DN
sDomainDN = "dc=domain,dc=local"
' sAMAccountName of shadow group
sGroupSAMAccountName = "Security Group"
' An array of one or more OUs to search
aSearchOUs = Array("ou=Something,dc=domain,dc=local")
' LDAP query that will be run in each OU
sQuery = " (&(objectCategory=computer)(name=GA*));distinguishedName;subtree"
'==========================================================================
' Create dictionaries
Dim dResults
Set dResults = CreateObject("Scripting.Dictionary")
dResults.CompareMode = vbTextCompare ' Case INsensitive
Dim dTargetMembership
Set dTargetMembership = CreateObject("Scripting.Dictionary")
dTargetMembership.CompareMode = vbTextCompare ' Case INsensitive
Dim dCurrentMembership
Set dCurrentMembership = CreateObject("Scripting.Dictionary")
dCurrentMembership.CompareMode = vbTextCompare ' Case INsensitive
Dim dMembershipChanges
Set dMembershipChanges = CreateObject("Scripting.Dictionary")
dMembershipChanges.CompareMode = vbTextCompare ' Case INsensitive
' Perform LDAP searches, adding to final list stored in dTargetMembership
Dim sSearchOU
Dim sLDAPQuery
For Each sSearchOU In aSearchOUs
sLDAPQuery = "<LDAP://" & sSearchOU & ">;" & sQuery
Set dResults = AD_Search_Dictionary(sLDAPQuery)
Call DictionaryAppend(dResults, dTargetMembership)
Next
' Locate group
Dim sGroupADsPath
Dim oGroup
sGroupADsPath = ADObject_Find_Generic(sGroupSAMAccountName, sDomainDN)
If sGroupADsPath = "" Then
' Error handling: group not found
WScript.Quit
End If
Set oGroup = GetObject(sGroupADsPath)
' Get members and store in dictionary
Dim aMembers
aMembers = oGroup.GetEx("member")
Set dCurrentMembership = ArrayToDictionary(aMembers)
' Calculate the "delta" between the current and desired state
Set dMembershipChanges = Dictionary_Transform(dCurrentMembership, dTargetMembership)
' Make the membership changes based on the transform dictionary's instructions
Dim sMember
For Each sMember In dMembershipChanges
If UCase(dMembershipChanges.Item(sMember)) = "ADD" Then
oGroup.Add "LDAP://" & sMember
End If
If UCase(dMembershipChanges.Item(sMember)) = "DELETE" Then
oGroup.Remove "LDAP://" & sMember
End If
Next
WScript.Quit
' ======================
' FUNCTIONS FROM LIBRARY
' ======================
' #region Dictionary routines
Function ArrayToDictionary(ByRef aArray)
' Converts a one-dimensional array into a dictionary.
' Assumes elements in array are unique
Dim dDic
Dim aElement
Set dDic = CreateObject("Scripting.Dictionary")
dDic.CompareMode = vbTextCompare ' Case INsensitive
On Error Resume Next ' trap duplicate array elements
For Each aElement In aArray
dDic.Add aElement, 0
Next
On Error GoTo 0
Set ArrayToDictionary = dDic
End Function
Sub DictionaryAppend(ByRef dNewElements, ByRef dDictionary)
' Appends the elements of dNewElements to dDictionary
Dim sKey
On Error Resume Next ' trap duplicate array elements
For Each sKey In dNewElements.keys
dDictionary.Add sKey, dNewElements.Item(sKey)
Next
On Error GoTo 0
End Sub
Function Dictionary_Transform(ByVal dOriginal, ByVal dFinal)
' Retunrs a dictionary with a list of update operations required
' so that dOriginal is transformed to dFinal
Dim dTransform, sKey
Set dTransform = CreateObject("Scripting.Dictionary")
dTransform.CompareMode = vbTextCompare ' Case INsensitive
For Each sKey In dFinal.Keys
If Not dOriginal.Exists(sKey) Then
dTransform.Add sKey, "ADD"
End If
Next
For Each sKey In dOriginal.Keys
If Not dFinal.Exists(sKey) Then
dTransform.Add sKey, "DELETE"
End If
Next
Set Dictionary_Transform = dTransform
End Function
' #endregion
' #region Active Directory object find routines
Function ADObject_Find_Generic(ByVal sObject, ByVal sSearchDN)
' Version 071130
' Takes any input (name, DN, or ADsPath) of a user, computer, or group, and
' returns the ADsPath of the object as a way of validating that the object exists
'
' INPUTS: sObject DN or ADsPath to an object
' sAMAccountName (pre-Windows 2000 logon name) of a user or group
' computer name of a computer
' sSearchDN the DN within which to search (often, the DN of the domain, e.g. dc=contoso, dc=com)
'
' RETURNS: ADObject_Find_Generic ADsPath (LDAP://...) of the object
' blank if object was not found
'
' NOTES: ASSUMPTION: computers, users & groups have unique names. See note inline.
'
' REQUIRES AD_Search_Array routine
' AD_Search_RS routine
' ADObject_Validate routine
Dim aResults, sLDAPQuery
Select Case ADObject_NameType(sObject)
Case ""
ADObject_Find_Generic = ""
Case "adspath"
ADObject_Find_Generic = ADObject_Validate(sObject)
Case "distinguishedname"
ADObject_Find_Generic = ADObject_Validate("LDAP://" & sObject)
Case "name"
' Assumption: No computer has the same name as a user's or group's sAMAccountName
' otherwise, this query will return more than one result
sLDAPQuery = "<LDAP://" & sSearchDN & ">;" & _
"(|(samAccountName=" & sObject & ")(samAccountName=" & sObject & "$));" & _
"aDSPath;subtree"
aResults = AD_Search_Array (sLDAPQuery)
If Ubound(aResults) = -1 Then
ADObject_Find_Generic = ""
Else
ADObject_Find_Generic = aResults(0)
End If
End Select
End Function
Function ADObject_NameType(ByVal sObjectName)
' Version 071204
' Evaluates sObjectName to determine what type of name it is
' Returns ADObject_NameType adspath
' distinguishedname
' name
' blank if sObjectName = ""
Dim sNameType
If Len(sObjectName) = 0 Then
sNameType = ""
ElseIf Len(sObjectName) < 3 Then
' can't be a DN or an ADsPath - must be a name
sNameType = "name"
ElseIf Ucase(Left(sObjectName,3)) = "CN=" Then
' is a DN
sNameType = "distinguishedname"
ElseIf Len(sObjectName) < 8 Then
' too short to be an ADsPath and isn't a DN, so it must be a name
sNameType = "name"
ElseIf UCase(Left(sObjectName, 7)) = "LDAP://" Then
' is already an ADsPath
sNameType = "adspath"
Else
' must be a name
sNameType = "name"
End If
ADObject_NameType = sNameType
End Function
Function ADObject_Validate(ByVal sObjectADsPath)
' Version 071122
' Returns ADsPath of object as a way of validating that the object exists
'
' INPUTS: sObjectADsPath ADsPath of object to test
' RETURNS: ADObject_Validate Path of object (if it exists) or blank
Dim oObject
On Error Resume Next
Set oObject = GetObject(sObjectADsPath)
If Err.Number <> 0 Then
ADObject_Validate = ""
Err
Turns out there are two answers to take note of in regard to "LDAP://" credentials.
First, specifically to the script I posted, I simply had to open my eyes!
Almost the last line of the script there were already options to add the credentials:
oConnection.Open "", vbNullString, vbNullString
Simply had to be correctly populated:
oConnection.Open "", "username", "password"
Second, a more general description was already provided by #Harvey Kwok in this SO answer: Secure LDAP object manipulation with VBscript using alternate credentials

Create a text file with the logged in user as its filename

I have this script that is creating and updating a text file called Machine.txt and populates it with a list of lines which have this format (username, time and date when the script ran).
I’m running this at logon.
What I want to do is to create a new text file for each user who logs in.
Example, if user is called fred I want the script to create fred.txt.
Any ideas?
Script been used is shown below i have replaced file location and name with "filepath and name"
thnak you for any help you can provide.
Set WSHShell = WScript.CreateObject ("WScript.Shell")
Set WSHNetwork = WScript.CreateObject ("WScript.Network")
Set WSHSysEnv = WSHShell.Environment ("PROCESS")
On Error Resume Next
' Check what OS is being used
Dim valOS
valOS = WSHShell.RegRead ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName")
Dim valPath, valLocation
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objEnv = WshShell.Environment("Process")
valMachine = objEnv("COMPUTERNAME")
valDate = date
valTime = time
' This section of the script look for a hidden file on a users private share. This file is used to store a list of
' machines that a client has logged onto and the date and time that they logged on
Set oFSO = CreateObject ("Scripting.FileSystemObject")
If oFSO.FileExists ("filepath and name") Then ' If this file exists open the file for appending
Set oAppend = oFSO.OpenTextFile ("filepath and name",8) ' Open the text file for appending
oAppend.Writeline valMachine & "," & valDate & "," & valTime ' Write the machine name, date and time the the user logged onto the client
oAppend.close ' Close the text file connection
valPath = ""
valDate = ""
valTime = ""
Else
Set oStream = oFSO.CreateTextFile ("filepath and name") ' Create the file
Set objFile = oFSO.GetFile ("filepath and name") ' Attach to the file
objFile.Attributes = 2 ' Change the file attribute to hidden
oStream.Writeline valMachine & "," & valDate & "," & valTime ' Write the machine name, date and time the the user logged onto the client
oStream.close ' Close the text file connection
valPath = "" ' Clear the valPath variable
valDate = "" ' Clear the valDate variable
valTime = "" ' Clear the valTime variable
End If
wscript.quit
Try this:
Dim objNetwork
Dim userName
Set objNetwork = CreateObject("WScript.Network")
userName = objNetwork.UserName
Assign userName as your file name with a .txt extension

How to Retrieve a File's "Product Version" in VBScript

I have a VBScript that checks for the existence of a file in a directory on a remote machine. I am looking to retrieve the "Product Version" for said file (NOT "File Version"), but I can't seem to figure out how to do that in VBScript.
I'm currently using Scripting.FileSystemObject to check for the existence of the file.
Thanks.
I use a function that is slightly modified from the previous example. The function takes the path and file name and returns the "Product Version"
Function GetProductVersion (sFilePath, sProgram)
Dim FSO,objShell, objFolder, objFolderItem, i
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(sFilePath & "\" & sProgram) Then
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(sFilePath)
Set objFolderItem = objFolder.ParseName(sProgram)
Dim arrHeaders(300)
For i = 0 To 300
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
'WScript.Echo i &"- " & arrHeaders(i) & ": " & objFolder.GetDetailsOf(objFolderItem, i)
If lcase(arrHeaders(i))= "product version" Then
GetProductVersion= objFolder.GetDetailsOf(objFolderItem, i)
Exit For
End If
Next
End If
End Function
I've found that the position of the attributes has occasionally changes (not sure why) in XP and Vista so I look for the "product version" attribute and exit the loop once it's found. The commented out line will show all the attributes and a value if available
You can use the Shell.Namespace to get the extended properties on a file, one of which is the Product Version. The GetDetailsOf function should work. You can test with the following code to get an idea:
Dim fillAttributes(300)
Set shell = CreateObject("Shell.Application")
Set folder = shell.Namespace("C:\Windows")
Set file = folder.ParseName("notepad.exe")
For i = 0 to 299
Wscript.Echo i & vbtab & fillAttributes(i) _
& ": " & folder.GetDetailsOf(file, i)
Next
One thing to be aware of:
The extended properties of a file differs between versions of Windows. Hence, the product version index numbers changes based on the version of Windows you are using. You can use the code above to determine what they are. From my testing, I believe they are as follows:
Window XP - 39
Windows Vista - 252
Windows 7 - 268
Windows 2008 R2 SP1 - 271
Windows 2012 R2 - 285
You may also find the following post helpful.
The product version can be retrieved directly with the ExtendedProperty method.
function GetProductVersion(Path)
dim shell, file
set shell = CreateObject("Shell.Application")
const ssfDesktop = 0
set file = shell.Namespace(ssfDesktop).ParseName(Path)
if not (file is nothing) then
GetProductVersion = _
file.ExtendedProperty("System.Software.ProductVersion")
end if
end function
By contrast with a couple of older answers,
This does not require looping over an unknown or arbitrary number of columns with GetDetailsOf.
This uses the canonical name of the property, not the display name. One can also use the FMTID and PID: "{0CEF7D53-FA64-11D1-A203-0000F81FEDEE} 8".
This avoids the need to split the path into directory and name, by starting at the root (desktop) namespace.
' must explicitly declare all variables
Option Explicit
' declare global variables
Dim aFileFullPath, aDetail
' set global variables
aFileFullPath = "C:\Windows\Notepad.exe"
aDetail = "Product Version"
' display a message with file location and file detail
WScript.Echo ("File location: " & vbTab & aFileFullPath & vbNewLine & _
aDetail & ": " & vbTab & fGetFileDetail(aFileFullPath, aDetail))
' make global variable happy. set them free
Set aFileFullPath = Nothing
Set aDetail = Nothing
' get file detail function. created by Stefan Arhip on 20111026 1000
Function fGetFileDetail(aFileFullPath, aDetail)
' declare local variables
Dim pvShell, pvFileSystemObject, pvFolderName, pvFileName, pvFolder, pvFile, i
' set object to work with files
Set pvFileSystemObject = CreateObject("Scripting.FileSystemObject")
' check if aFileFullPath provided exists
If pvFileSystemObject.FileExists(aFileFullPath) Then
' extract only folder & file from aFileFullPath
pvFolderName = pvFileSystemObject.GetFile(aFileFullPath).ParentFolder
pvFileName = pvFileSystemObject.GetFile(aFileFullPath).Name
' set object to work with file details
Set pvShell = CreateObject("Shell.Application")
Set pvFolder = pvShell.Namespace(pvFolderName)
Set pvFile = pvFolder.ParseName(pvFileName)
' in case detail is not detected...
fGetFileDetail = "Detail not detected"
' parse 400 details for given file
For i = 0 To 399
' if desired detail name is found, set function result to detail value
If uCase(pvFolder.GetDetailsOf(pvFolder.Items, i)) = uCase(aDetail) Then
fGetFileDetail = pvFolder.GetDetailsOf(pvFile, i)
End If
Next
' if aFileFullPath provided do not exists
Else
fGetFileDetail = "File not found"
End If
' make local variable happy. set them free
Set pvShell = Nothing
Set pvFileSystemObject = Nothing
Set pvFolderName = Nothing
Set pvFileName = Nothing
Set pvFolder = Nothing
Set pvFile = Nothing
Set i = Nothing
End Function
Wscript.Echo CreateObject("Scripting.FileSystemObject").GetFileVersion("C:\Windows\notepad.exe")

Resources