Passing objects as arguments in VBScript - performance

I'm working on a project to capture various disk performance metrics using VBScript and would like to use a sub procedure with an object as an argument. In the following code samples the object I'm referring to is objitem.AvgDiskQueueLength which will provide a value for the disk queue length. I haven't found a way to make it work since it is recognized as a string and then doesn't capture the value. My goal is to make it easy for anyone to change the counters that are to be captured by only having to make a change in one location(the procedure call argument). The way I'm going about this may not be the best but I'm open to suggestions. The sub procedure call is below.
PerfCounter "Average Disk Queue Length", "disk_queueLength", "objItem.AvgDiskQueueLength"
The following code is the sub procedure.
Sub PerfCounter(CounterDescription, CounterLabel, CounterObject)
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PerfFormattedData_PerfDisk_PhysicalDisk",,48)
args_index = args_index + 1
arrCriteria = split(command_line_args(args_index),",")
strDriveLetter = UCase(arrCriteria(0))
intCriticalThreshold = arrCriteria(1)
intWarningThreshold = arrCriteria(2)
For Each objItem in colItems
With objItem
WScript.Echo "objitem.name = " & objitem.name
If InStr(objItem.Name, strDriveLetter & ":") > 0 Then
intChrLocation = InStr(objItem.Name, strDriveletter)
strInstanceName = Mid(objItem.Name, intChrLocation, 1)
End If
If strDriveLetter = strInstanceName AND InStr(objItem.Name, strDriveLetter & ":") > 0 Then
If intActiveNode = 1 OR Len(intActiveNode) < 1 Then
WScript.Echo "CounterDescription = " & CounterDescription
WScript.Echo "CounterLabel = " & CounterLabel
WScript.Echo "CounterObject = " & CounterObject
If CInt(CounterOjbect) => CInt(intCriticalThreshold) Then
arrStatus(i) = "CRITICAL: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 2
arrExitCode(i) = intExitCode
ElseIf CInt(CounterOjbect) => CInt(intWarningThreshold) AND CInt(CounterObject) < CInt(intCriticalThreshold) Then
arrStatus(i) = "WARNING: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 1
arrExitCode(i) = intExitCode
Else
arrStatus(i) = "OK: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 0
arrExitCode(i) = intExitCode
End If
Else
PassiveNode CounterDescription, CounterLabel
End If
End If
End With
Next
i = i + 1
ReDim Preserve arrStatus(i)
ReDim Preserve arrTrendData(i)
ReDim Preserve arrExitCode(i)
End Sub

Why cant you do this...
PerfCounter "Average Disk Queue Length", "disk_queueLength", objItem.AvgDiskQueueLength

To pass an object you have to pass an object, not a string. To make this method work as expected you would have to have the object prior to the procedure call, but in your code example it looks like you are trying to pass an object that you don't have. A working example:
Set objFSO = CreateObject("Scripting.FileSystemObject")
UseFileSystemObject objFSO
Sub UseFileSystemObject( objfso)
'Now I can use the FileSystemObject in this procedure.
End Sub
But calling the UseFileSystemObject procedure like this will not work,
UseFileSystemObject "objFSO"
because you are passing in a string not an object.
The only way I can think of to accomplish what you want is to use a select statement to write the appropriate attribute of the object, something like this.
Call PerfCounter "Average Disk Queue Length", "disk_queueLength", "AvgDiskQueueLength"
Sub PerfCounter(CounterDescription, CounterLabel, CounterObjectAttribute)
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PerfFormattedData_PerfDisk_PhysicalDisk",,48)
For Each objItem in colItems
Select Case CounterObjectAttribute
Case "ObjectAttribute1"
Case "ObjectAttribute2"
Case "AvgDiskQueueLength"
Wscript.Echo objItem.AvgDiskQueueLength
End Select
Next
End Sub
So in the select you would have to add a case for each attribute that can be used, but it would allow you to pass a string into the procedure. I might be way off on this, but I don't know how you can pass an object if you don't have the object first.

Related

Write console output into a file

I'm attempting to list a Lenovo computer BIOS settings with a VBScript and write the result into a file. I've came to a point where I can write the stuff into a text file, however it writes in only the first setting (record). How do I write all the settings into one file - one by one?
On Error Resume Next
Dim colItems, fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set f = fso.CreateTextFile("bios-settings" & ".txt", True)
strComputer = "LOCALHOST"
strOptions
Set objWMIService = GetObject("WinMgmts:" _
&"{ImpersonationLevel=Impersonate}!\\" & strComputer & "\root\wmi")
Set colItems = objWMIService.ExecQuery("Select * from Lenovo_BiosSetting")
For Each objItem In colItems
If Len(objItem.CurrentSetting) > 0 Then
Setting = ObjItem.CurrentSetting
StrItem = Left(ObjItem.CurrentSetting, InStr(ObjItem.CurrentSetting, ",") - 1)
StrValue = Mid(ObjItem.CurrentSetting, InStr(ObjItem.CurrentSetting, ",") + 1, 256)
Set selItems = objWMIService.ExecQuery("Select * from Lenovo_GetBiosSelections")
For Each objItem2 In selItems
objItem2.GetBiosSelections StrItem + ";", strOptions
Next
f.WriteLine StrItem
f.WriteLine " current setting = " + StrValue
f.WriteLine " possible settings = " + strOptions
f.WriteLine
End If
f.Close
Next
This is the part where the actual writing to the file is carried out:
f.WriteLine StrItem
f.WriteLine " current setting = " + StrValue
f.WriteLine " possible settings = " + strOptions
f.WriteLine
It writes the BIOS setting name (StrItem), current setting value (StrValue) and possible setting values (strOptions).
The first thing you need to do is remove the
on error resume next
from your script. This should only be used in specific circumstances to do error handling, not as a way to cut corners for lazy developers.
If you do so you will get an error complaining about not being able to write to a closed file.
That then leads to the actual error, you are closing the file after the first write.
Move the line
f.Close
outside of your for each loop and it will probably work a lot better.

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

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.

vbscript+function calling function - return value

I have a vbscript that calls a second vbscript and runs a function. This second function returns a value. But I can't figure out how to get this value, as the result of the first function returns the status code.
original call: fileCASTRING(12345678)
vbscript 1
function fileCASTRING(varRAW)
lresult = CreateObject("WScript.Shell").Run ("c:\windows\syswow64\cscript.exe C:\ERMXData\Config\query-castring.vbs " & varRAW,0,true)
fileCASTRING=1
end function
query-castring.vbs
doctype=WScript.Arguments.Item(0)
Dim strCon
strCon = "DSN=*****; " & _
"uid=*****;pwd=*****;"
Dim oCon: Set oCon = WScript.CreateObject("ADODB.Connection")
Dim oRs: Set oRs = WScript.CreateObject("ADODB.Recordset")
oCon.Open strCon
Set oRs = oCon.Execute("select ESBLINK_ADMR_CODE from ESBLINK where ESBLINK_DTYP_CODE like '%" + doctype + "%'"")
queryB=oRs.Fields(0).Value
oCon.Close
Set oRs = Nothing
Set oCon = Nothing
I have to do it like this because the program that runs vbscript 1 runs in 64 bit mode and the code in query-castring.vbs needs to run in 32bit mode in order for it to work. How can I get the queryB value back to the original caller? I am trying to not have to write the value to a file.
The only easy way to communicate between two command line processes is via StdOut.
(Be aware the code is not tested but should get you into the right direction.)
VBScript 1
Option Explicit
' ...
Function fileCASTRING(varRAW)
Dim program, script, cmdline, output
program = "c:\windows\syswow64\cscript.exe /nologo"
script = "C:\ERMXData\Config\query-castring.vbs"
cmdLine = program & " " script & " """ & varRAW & """"
output = ""
With CreateObject("WScript.Shell").Exec(cmdLine)
While Not .StdOut.AtEndOfStream
output = output & .StdOut.ReadAll
Wend
End With
fileCASTRING = output
End Function
see the documentation of the WshScriptExec object
query-castring.vbs
Option Explicit
Dim doctype: doctype = WScript.Arguments.Item(0)
Dim strCon: strCon = "DSN=*****;uid=*****;pwd=*****;"
Dim strSql: "select ESBLINK_ADMR_CODE from ESBLINK where ESBLINK_DTYP_CODE like '%' + ? + '%'"
Dim oCon: Set oCon = WScript.CreateObject("ADODB.Connection")
Dim oCmd: Set oCmd = WScript.CreateObject("ADODB.Command")
oCon.Open strCon
With WScript.CreateObject("ADODB.Command")
Set .ActiveConnection = oCon
.CommandText = strSql
.Parameters.Add(.CreateParameter)
.Parameters(0).Value = doctype
With .Execute
If Not .EOF Then
WScript.Echo .Fields("ESBLINK_ADMR_CODE").Value
End If
End With
End With
oCon.Close
See the documentation of the ADODB Command and Parameter objects. Don't build SQL from strings.
Also, look into "integrated security" connection strings - do not store plain text passwords in in code files. ADODB can easily use the security context of the account that runs the script, if you tell it to.
VBScript 1
Function getADMRCODE(varRAW)
Dim program, script, cmdline, output
program = "c:\windows\syswow64\cscript.exe /nologo"
script = "C:\ERMXData\Config\common_app\queries\admrcode.vbs"
cmdLine = program & " " & script & " """ & varRAW & """"
output = ""
With CreateObject("WScript.Shell").Exec(cmdLine)
While Not .StdOut.AtEndOfStream
output = output & .StdOut.ReadAll
Wend
End With
getADMRCODE = output
End Function
query-castring.vbs
Dim doctype: doctype = WScript.Arguments.Item(0)
Dim strCon
strCon = "DSN=*****; " & _
"uid=*****;pwd=*****;"
Dim oCon: Set oCon = WScript.CreateObject("ADODB.Connection")
Dim oRs: Set oRs = WScript.CreateObject("ADODB.Recordset")
oCon.Open strCon
Set oRs = oCon.Execute("select ESBLINK_ADMR_CODE from ESBLINK where ESBLINK_DTYP_CODE LIKE '%" + doctype + "%'")
WScript.Echo oRs.Fields(0).Value
oCon.Close
Set oRs = Nothing
Set oCon = Nothing

Trying to use Shell object and FileSystemObject in VBScript for file manipulation

I am trying to recursively loop through hundreds of directories, and thousands of JPG files to gather sort the files in new folders by date. So far, I am able to individually GetDetailsOf the files using the Shell NameSpace object, and I am also able to recursively loop through directories using the FileSystemObject. However, when I try to put them together in functions, etc, I am getting nothing back when I try to get the DateTaken attribute from the photo.
Here is my code so far:
sFolderPathspec = "C:\LocationOfFiles"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(sFolderPathspec)
Dim arrFiles()
getInfo(objDir)
Sub getInfo(pCurrentDir)
fileCount = 0
For Each strFileName In pCurrentDir.Files
fileCount = fileCount + 1
Next
ReDim arrFiles(fileCount,2)
i=0
For Each aItem In pCurrentDir.Files
wscript.Echo aItem.Name
arrFiles(i,0) = aItem.Name
strFileName = aItem.Name
strDir = pCurrentDir.Path
wscript.echo strDir
dateVar = GetDatePictureTaken(strFileName, strDir)
'dateVar = Temp2 & "_" & Temp3 & "_" & Temp1
arrFiles(i,1) = dateVar
WScript.echo i & "." & "M:" & monthVar & " Y:" & yearVar
WScript.echo i & "." & strFileName & " : " & arrFiles(i,1) & " : " & dateVar
i=i+1
Next
For Each aItem In pCurrentDir.SubFolders
'wscript.Echo aItem.Name & " passing recursively"
getInfo(aItem)
Next
End Sub
Function GetDatePictureTaken(strFileName, strDir)
Set objShell = CreateObject ("Shell.Application")
Set objCurrFolder = objShell.Namespace(strDir)
'wscript.Echo cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = CleanNonDisplayableCharacters(strFileNameDate)
arrDate = split(strFileNameDate, "/")
'''FAILS HERE WITH A SUBSCRIPT OUT OF RANGE ERROR SINCE IT GETS NULL VALUES BACK FROM THE GET DETAILS OF FUNCTION'''
monthVar = arrDate(0)
yearVar = arrDate(1)
dayVar = arrDate(2)
GetDatePictureTaken = monthVar & "\" & dayVar & "\" & yearVar
End Function
Function CleanNonDisplayableCharacters(strInput)
strTemp = ""
For i = 1 to len(strInput)
strChar = Mid(strInput,i,1)
If Asc(strChar) < 126 and not Asc(strChar) = 63 Then
strTemp = strTemp & strChar
End If
Next
CleanNonDisplayableCharacters = strTemp
End Function
The "Subscript out of range" error when accessing arrDate(0) is caused by arrDate being empty (UBound(arrDate) == -1). As a Split on a non-empty string will return an array, even if the separator is not found, and an attempt to Split Null will raise an "Invalid use of Null" error, we can be sure that strFileNameDate is "".
Possible reason for that:
The index of "Date Picture Taken" is 25 (XP) and not 12 (Win 7) - or whatever came to Mr. Gates' mind for Win 8.
The DPT property is not filled in.
Your cleaning function messed it up.
You have to test for strFileNameDate containing a valid date and decide where to put the files without a valid DPT.
P.S. Instead of doing the recursive loopings, you should consider to use
dir /s/b path\*.jpg > pictures.txt
and to process that file.

Resources