[VBScript] Boosting myself to HIGH process priority

The script gets its own name, then looks through the Win32_Processes for a match with CSCRIPT.EXE and a CommandLine containing that name. Any matches (should be only one, but could be more) are boosted to HIGH process priority.

This demonstrates WMI calls from both VBScript and JScript. Note the need to explicitly define an Enumerator in the JScript version.

Option Explicit

Dim sName
Dim sComputer
Dim oWMI
Dim cProcesses
Dim oProcess

Const HIGH = 256
sComputer = "."
Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
sName = WScript.ScriptName

Set cProcesses = oWMI.ExecQuery("Select * from Win32_Process Where Name = 'cscript.exe' And CommandLine LIKE '%" & sName & "%'")
For Each oProcess In cProcesses
  oProcess.SetPriority(HIGH) 
  WScript.Echo "Boosted myself"
Next

And in JScript

var HIGH = 256;
var sComputer = ".";
var sName = WScript.ScriptName;    

var query = GetObject("winmgmts:\\\\" + sComputer + "\\root\\cimv2")
    .ExecQuery("Select * from Win32_Process " + 
    "Where Name = 'cscript.exe' And CommandLine LIKE '%" + sName + "%'")

// Enumerate WMI objects
var cProcesses = new Enumerator(query);

for ( ; !cProcesses.atEnd(); cProcesses.moveNext()) { 
    var oProcess = cProcesses.item()
    oProcess.Priority = HIGH
    WScript.Echo( "Boosted myself")
}

© Copyright Bruce M. Axtens, 2014

[Perl/PDK/PerlCtrl] Returning an array of arrays for VB6/VBScript

For the last few weeks I've been trying to get used to working with the Perl Development Kit (PDK 7.1) from ActiveState, particularly PerlCtrl.

One of the challenges I've been facing lately is how to return an array of arrays. That is, returning something that in VB6 or VBScript might be represented as Array( Item, Array( Item, Item ), Item ).

Kudos to Perl Monks, who have provided a function which converts a Perl array to a VB array. Interestingly, it also copes with said converted array being embedded in another array and with that array being converted as well. (Bodes well for other projects.)

So what we have below is some Perl code, a PerlCtrl wrapper around a WMI call to list System Services. The wrapper returns a two element array, the first element being an array of all the services which are running, and the second an array of all the services which have been stopped.

Note that without 'use Win32::OLE qw(in);' you can't access the elements of the $colItems collection, as it enables the use of 'in' in the foreach. Similarly, you need Win32::OLE::Variant for all the Variant() calls.

Please don't ask me to explain what's going on in the convertArrayToVBArray sub, because I have no idea. Anyone know?

package ServicesList; use strict; use warnings; use Win32::OLE qw(in); use Win32::OLE::Variant; sub convertArrayToVBArray { my $array_ref = $_[0]; my $ary = Variant( VT_ARRAY|VT_VARIANT, $#{$array_ref}+1); $ary->Put(\@{$array_ref}); return $ary; } sub GetServices { my @stoppedServices; my @runningServices; my $strComputer = '.'; my $objWMIService = Win32::OLE->GetObject('winmgmts:\\\\' . $strComputer . '\\root\\cimv2'); my $colItems = $objWMIService->ExecQuery('Select * from Win32_Service'); foreach my $objItem (in $colItems) { if ( $objItem->State eq "Stopped" ) { push @stoppedServices, $objItem->DisplayName; } else { push @runningServices, $objItem->DisplayName; } } @stoppedServices = sort @stoppedServices; @runningServices = sort @runningServices; my $running = convertArrayToVBArray( \@runningServices ); my $stopped = convertArrayToVBArray( \@stoppedServices ); my @serviceList = ( $running, $stopped ); my $services = convertArrayToVBArray( \@serviceList ); return $services; } 1; =pod =begin PerlCtrl %TypeLib = ( PackageName => 'ServicesList', TypeLibGUID => '{B20BBC2D-30C6-4DED-ADF2-BADFD66FA221}', # do NOT edit this line ControlGUID => '{B6398FF7-F2BC-42D7-A094-04F53A65941E}', # do NOT edit this line either DispInterfaceIID=> '{9322D169-82A6-46BC-B927-BBAE6E0AC7E9}', # or this one ControlName => 'ServicesList', ControlVer => 1, # increment if new object with same ProgID # create new GUIDs as well ProgID => 'ServicesList.sl', DefaultMethod => '', Methods => { GetServices => { DocString => "Returns array containing two arrays, running services and stopped services respectively.", HelpContext => 101, RetType => VT_ARRAY|VT_VARIANT, TotalParams => 0, NumOptionalParams => 0, ParamList => [], }, }, # end of 'Methods' Properties => { }, # end of 'Properties' ); # end of %TypeLib =end PerlCtrl =cut

The second bit of code is a VBScript testing the COM DLL. It's a assumed that you've run the above code through PerlCtrl, generated a DLL and registered it with RegSvr32.

set o = WScript.CreateObject("ServicesList.sl") a = o.GetServices For Each sServiceName in a(0) wscript.echo "'" & sServiceName & "' running" Next wscript.echo For Each sServiceName in a(1) wscript.echo "'" & sServiceName & "' stopped" Next

I'm having a lot of fun with Perl. I've been able to take a lot of Perl functionality (Tree::Nary, Data::Trie, Lingua::EN::Inflect, Algorithm::LCSS, Algorithm::Knapsack, Algorithm::BinPack, Algorithm::Bucketizer, Algorithm::Permute, Algorithm::SetCovering, String::LCSS and Statistics::Benford) and turn it into something that VB6 and VBScript can use. I'm impressed. Would that every scripting language had this kind of power.

© Copyright Bruce M. Axtens, 2008

[Visual Basic 6] Boost again, but as a binary

As nice as the VBScript version of BOOST is, some people prefer a compiled binary. So, here's the VB6 version.

But first, credit where credit is due:
* Ultimate Packer for eXecutables which compresses binaries;
* Euphoria programming language website for the SETSUBSYS tool which I use to turn a GUI applications into a console ones;
* Experts Exchange for their ParseCommandLineValue function; and
* vb.mvps.org for their sample on how to make console applications

Okay, now to the code. The algorithm is very similar to the VBScript project, but there are some new things.

First the constants:

Option Explicit Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6

Here are two functions vital to making the application function appropriately in a command line environment. The first discovers the handle for StdOut. The second writes to a file handle, in this case the handle for StdOut.

After the function declarations is a user-defined wrapper. Interesting how the output of the WriteFile function is transmitted to the return value of the wrapper (the last argument in the call is the name of the wrapper function -- I'd never seen that before.)

'http://vb.mvps.org/samples/project.asp?id=console Private Declare Function GetStdOutHandle Lib "kernel32" _ Alias "GetStdHandle" _ (Optional ByVal HandleType As Long = -11) As Long Private Declare Function WriteFile Lib "kernel32" _ (ByVal hFile As Long, _ ByVal lpBuffer As String, _ ByVal cToWrite As Long, _ ByRef cWritten As Long, _ Optional ByVal lpOverlapped As Long) As Long 'To keep things simple, wrap these two APIs in a single helper function like so: Private Function ConsoleWrite(sText As String) As Long WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite End Function

This is the SetPriority function pulled straight out of the VBScript project. Notice I haven't even been polite enough to VB6 to specify sProcess As String and nPriority As Integer. I haven't typed any of the variables local to the function either. It doesn't matter: VB6 types them all as Variant and takes care of my carelessness (and I have put them in since.)

Function SetPriority(sProcess, nPriority) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) bDone = True Next SetPriority = bDone End Function

Next comes the Experts Exchange code for parsing the command line.

'http://www.experts-exchange.com/Programming/Programming_Languages/Q_20832956.html#9992009 Public Function ParseCommandLineValue(ByVal sCommandLine As String, ByVal sKey As String) As String Dim lPosFrom As Integer Dim lPosLen As Integer Dim sValue As String 'Initialize ParseCommandLineValue = "" If Trim(sKey) = "" Then Err.Raise vbObjectError, "Invalid key" End If 'Get Datasource lPosFrom = InStr(1, sCommandLine, sKey, vbTextCompare) If lPosFrom > 0 Then 'Find the position of the Value after length of the Key lPosFrom = lPosFrom + Len(sKey) 'Get value sValue = Mid(sCommandLine, lPosFrom) 'till end 'Find where next value starts lPosLen = InStr(lPosFrom, sCommandLine, "/") If lPosLen > 0 Then 'last value of the command line lPosLen = lPosLen - lPosFrom Else 'more values after this one lPosLen = Len(sValue) End If 'Return sValue = Mid(sCommandLine, lPosFrom, lPosLen) ParseCommandLineValue = sValue End If End Function

Now the Main. For ease of access to the relevant values for the SetPriority function, I've used a Collection. I could have used VBScript's Dictionary (by adding a reference to SCRRUN.DLL in the Projects menu) but the Collection works well enough.

Sub Main() 'http://vb.mvps.org/samples/project.asp?id=console Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim cPriorities As New Collection cPriorities.Add LOW_PRIORITY, "1" cPriorities.Add BELOWNORMAL_PRIORITY, "2" cPriorities.Add NORMAL_PRIORITY, "3" cPriorities.Add ABOVENORMAL_PRIORITY, "4" cPriorities.Add HIGH_PRIORITY, "5" cPriorities.Add REALTIME_PRIORITY, "6"

Now we parse the commandline and output a message about syntax if things aren't correctly specified there.

sCommand = Command() sProcess = Trim(ParseCommandLineValue(sCommand, "/process:")) sLevel = Trim(ParseCommandLineValue(sCommand, "/level:")) If sProcess = "" Or sLevel = "" Then ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost /process:{processname} /level:{runlevel}" & vbNewLine & _ "Run levels:" & vbNewLine & _ vbTab & "1 = LOW_PRIORITY" & vbNewLine & _ vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _ vbTab & "6 = REALTIME_PRIORITY" & vbNewLine) End End If

Assuming that the commandline is okay, we then attempt to figure out the runlevel value from the user-supplied specification, and show an appropriate error if it doesn't make sense.

On Error Resume Next nLevel = cPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite ("Invalid selection of runlevel.") End End If On Error GoTo 0

And, finally, where it is all made to happen. If everything's set up right and there is in fact a process running that matches what's stored in sProcess, then it gets boosted and the user is informed. If there's no match, the message says that the process wasn't boosted.

ConsoleWrite (sProcess & IIF(SetPriority(sProcess, nLevel), _ " boosted", " not boosted") & " to priority " & sLevel & _ " (" & nLevel & ").") End Sub

Having compiled the code to an .EXE, I used the setsubsys tool to change the binary from a GUI app to a console app

setsubsys boost.exe /C

I also compressed it using UPX,

upx -9 boost.exe

taking a 24576 byte application and leaving me with an 8192 byte one.

If anyone's interested in downloading the BOOST binary (which now contains a KILL_PROCESS 'level'), please leave a comment to that effect and I'll put up a download link.

By the way, if you think my code sucks, say so. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

[VBScript] Boost - changing process priority using WMI

I have little sh script on my iBook which changes the priority of a given process so that the OS services it more frequently, giving the impression of faster execution. Below is a re-implementation in VBScript of a similar tool for Windows. First a few constants and the arrays that handle the commandline options.

Option Explicit Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6 Dim aNames Dim aValues aNames = Array( "LOW", "BELOWNORMAL", "NORMAL", "ABOVENORMAL", "HIGH", "REALTIME" ) aValues = Array( LOW_PRIORITY, BELOWNORMAL_PRIORITY, NORMAL_PRIORITY, ABOVENORMAL_PRIORITY, HIGH_PRIORITY, REALTIME_PRIORITY )

Next, the real meat of this tool: the Windows Management Interface (WMI) call which takes a string and a numeric defining the process name and the priority level.

Function SetPriority( sProcess, nPriority ) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess in cProcesses oProcess.SetPriority( nPriority ) bDone = True Next SetPriority = bDone End Function

Next a few less inspiring routines: IIF (available in VB but not in VBScript), ArrayOffset, and HelpText.

Function IIF( bCondition, vTrue, vFalse ) Dim vResult If bCondition = True Then vResult = vTrue Else vResult = vFalse End If IIF = vResult End Function Function ArrayOffset( sItem, aList ) Dim i Dim u Dim nResult nResult = -1 For i = 0 To UBound( aList ) If sItem = aList( i ) Then nResult = i Exit For End If Next ArrayOffset = nResult End Function Sub HelpText WScript.Echo "Syntax:" WScript.Echo vbTab & "Boost {appName} /L:{priority}" WScript.Echo vbTab & "priority: LOW | BELOWNORMAL | NORMAL | ABOVENORMAL | HIGH | REALTIME" WScript.Echo WScript.Echo vbTab & "E.g. boost cscript.exe /l:realtime" End Sub

Finally the main routine, which uses Named and Unnamed Arguments to handle command line parameters. The name of the process is pulled out of the command line using an Unnamed Argument, and the text representation of the priority is pulled out using a Named Argument ("L"). If the priority is acceptable the name and priority are passed to the SetPriority routine.

If WScript.Arguments.Unnamed.Count = 0 Or WScript.Arguments.Named.Count = 0 Then HelpText WScript.Quit End If Dim sApp, sPrio, nOffs sApp = WScript.Arguments( 0 ) sPrio = WScript.Arguments.Named.Item("L") nOffs = ArrayOffset( UCase( sPrio ), aNames ) If nOffs = -1 Then WScript.Echo "The",sPrio,"priority cannot be assigned to",sApp HelpText Else WScript.Echo sApp, _ IIF( SetPriority( sApp, aValues( nOffs ) ), _ "boosted to " & aNames( nOffs ) & " priority", _ "not boosted" ) End If

A further refinement of this tool might be to provide for one other possibility for /L: 'KILL' or 'TERMINATE'. By way of comparison here's the original sh script.

#!/bin/sh ps axxw | grep $1 | grep -v grep | grep -v boost sudo renice -20 `ps axww | grep $1 | grep -v grep | grep -v boost | awk '{print $1}'`

[VBScript] When did I log on/off?

The Australian federal government has brought in new laws which seem to require a return to the old days of clocking in at the beginning of the working day and clocking out at the end. As a contractor I don't think I'm going to notice a big difference ... if I want to get paid for the hours I work, then I fill out my timesheet appropriately.

If you aren't in the habit of keeping this kind of information, don't worry too much: Windows keeps a track of your login and logout in one of its Event Logs. Getting that information is fairly easy, if you know what you're looking for. Otherwise its like the proverbial needle in the haystack.

The script outputs into an Excel spreadsheet, the date of each logon in a separate column containing time of logon and logoff. Please note that the script was designed to query someone else's machine, and will likely need modification if you are trying to get your own data out of your own event log.

Here's the code.

As is often the case in my scripts, the preamble loads external code libraries. The former is a the standard library and the latter (see the end of the posting) a symbol table class, based on the Scripting.Dictionary object.

option explicit

Function GetEnv( strEnvVar )
    Dim oProcessEnvironment
    Dim sResult
    With CreateObject( "WScript.Shell" )
        GetEnv = .Environment( "PROCESS" )( UCase( strEnvVar ) )
    End With
End Function

Sub Include( scriptName )
    Dim sScript
    Dim oStream
    'on error resume next
    err.clear
    With CreateObject( "Scripting.FileSystemobject" )
        Set oStream = .OpenTextFile( scriptName )
    End With
    If Err.Number > 0 Then
        MsgBox "Could not open " & scriptName
        WScript.Quit
    End If
    Err.Clear
    sScript = oStream.ReadAll()
    oStream.Close
    ExecuteGlobal sScript
    If Err.Number <> 0 Then
        Die "Error in loaded script"
    End If
    On Error Goto 0
End Sub

Include "C:\Script\StandardLibrary.vbs"
Include "C:\Script\ClassSymTab.vbs"

Dim V
Set V = New Symtab

Next comes code to split up the event log's timestamp, followed by the routine to store logon date and logon and logoff times into spreadsheet cells.

function timesplit( sDateTime )
    timesplit = Left( sDateTime, 4 ) & "-" & Mid( sDateTime, 5, 2) & _
        "-" & Mid( sDateTime, 7, 2 ) & " " & Mid( sDateTime, 9, 2 ) & _
        ":" & Mid( sDateTime, 11, 2 ) & ":" & Mid( sDateTime, 13, 2 )
end function

Dim nECol
nEcol = 2

sub Excellent( dOn, dOff )
    oSheet.Cells( 1, nECol ).Value = DateValue( dOn )
    oSheet.Cells( 1, nECol ).Font.Bold = True
    oSheet.Cells( 2, nECol ).Value = TimeValue( dOn )
    oSheet.Cells( 3, nECol ).Value = TimeValue( dOff )
    oSheet.Columns(nECol).EntireColumn.AutoFit
    nECol = nECol + 1
end sub

Next comes the variable declarations. In retrospect the variables sComputer and sUser could have been Const rather than Dim. For that matter they could have been taken from the command line. Note the double backslash in the uUser variable: this is needed for where it occurs in the WMI call.

Const MAX_INSTANCE = 365

dim sComputer
Dim sUser
Dim oWMIService
dim cEvents
dim oEvent
Dim dLastDate
Dim aResults
Dim aRes
Dim n
Dim dLogin, dLogout
Dim aDates
Dim bFirst
Dim nInstance

sComputer = "THEMACHINE"
sUser = "THEDOMAIN\\theuser"

This is the core of the script: pointing WMI at sComputer and executing an SQL query against Win32_NTLogEvent. It asks for everything from the 'Security' Logfile where the EventCode matches a logon or a logoff and where the User matches sUser.

Set oWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
        sComputer & "\root\cimv2")
Set cEvents = oWMIService.ExecQuery _
    ("Select * from Win32_NTLogEvent " _
        & "Where Logfile = 'Security' And _
        (EventCode=528 Or EventCode=538) And _
        User='" & sUser & "'")

Then the script starts to do things with the list of events now stored in cEvents. First a Dictionary is loaded with logons as (zero, comma, TimeSplit of datestamp) and logoffs as (one, comma, TimeSplit of datestamp). The reason for this is that there may be more than one logon and logoff event for a given user during a working day. By storing the logon and logoff times in this way, the first "0" reference can be assumed to be the first logon off the day, and the last "1" can be assumed to be the last logoff of the day.

dLastDate = dbDate( Cdate( 0 ) )

For Each oEvent in cEvents
    V.Store IIF( oEvent.EventCode = 528, 0, 1 ) & "," & TimeSplit( oEvent.TimeWritten ), vbNullString
Next

From the Dictionary wrapper class the keys are extracted. A check is put in here to make sure that there are records to be reported.

aResults = V.Keys()
'MsgBox Join( aResults, vbNewLine )
If UBound( aResults ) < 0 Then
    MsgBox "No records found"
    WScript.Quit
End If

Next comes the Excel interactions. The ExcelStart and ExcelNewSheet macros are listed at the bottom of this posting.

Dim oRange
Dim oSelection

ExcelStart False
ExcelNewSheet

oSheet.Cells( 2, 1 ).Value = "Logon"
oSheet.Cells( 3, 1 ).Value = "Logoff"
Set oRange = oSheet.Range( "A2", "A3" )
oRange.Font.Bold = True

What follows is the guts of the Excel reporting. Despite the possibility of incorrect recording, the assumption is that the report will contain the first logon and the last logoff. If a logon occurs after the last logoff, it is discarded. The script is unable to cope with the situation where someone logs on today and logs off tomorrow.

Note that a check is made not to report more dates than MAX_INSTANCE, a limit that has not yet been encountered. AMax and AMin are listed at the bottom of the posting.

aRes = Split( aResults( 0 ), "," )
dLastDate = DateValue( aRes( 1 ) )
ReDim aDates( -1 )
n = 1
bFirst = True
nInstance = 0
Do While True
    aRes = Split( aResults( n ), "," )
    If DateValue( aRes( 1 ) ) <> dLastDate And bFirst = False Then
        dLogin = AMin( aDates )
        dLogout = AMax( aDates )
        Excellent dLogin, dLogout
        nInstance = nInstance + 1
        If nInstance >= MAX_INSTANCE Then
            Exit Do
        End If
        ReDim aDates( -1 )
        dLastDate = DateValue( aRes( 1 ) )
    Else
        bFirst = False
        AAdd aDates, aRes( 1 )
        n = n + 1
        IF n > UBound( aResults ) Then
            Exit Do
        End If
    End If
Loop

Set oWMIService = Nothing
Set cEvents = Nothing

Excel is left running with the results of the report. It's up to the user to save it, print it or whatever. To finish, the macros ExcelStart, ExcelNewSheet, AMax and AMin, and the ClassSymTab class as promised.

Dim oExcel

Sub ExcelStart( bHidden )
    Set oExcel = CreateObject("Excel.Application")
    If bHidden = True Then
        oExcel.Visible = False
        oExcel.Interactive = False
    Else
        oExcel.Visible = True
        oExcel.Interactive = True
    End If
End Sub

Dim oWorkbook
Dim oSheet

Sub ExcelNewSheet()
    Set oWorkbook = oExcel.Workbooks.Add()
    Set oSheet = oWorkbook.ActiveSheet
End Sub

Function AMax( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp > vResult Then
            vResult = vTemp
        End If
    Next
    AMax = vResult
End Function

Function AMin ( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp < vResult Then
            vResult = vTemp
        End If
    Next
    AMin = vResult
End Function

Class symtab
    private oHash
    private sSystemPrefix

    Private Sub Class_Initialize()
        Set oHash = CreateObject( "Scripting.Dictionary" )
        sSystemPrefix = "$"
    End Sub

    Private Sub Class_Terminate()
        Set oHash = Nothing
    End Sub

    Public Sub Store( sName, vValue )
        If oHash.Exists( sName ) Then
            oHash( sName ) = vValue
        Else
            oHash.Add sName, vValue
        End If
    End Sub

    Public Function Recall( sName )
        If oHash.Exists( sName ) Then
            Recall = oHash( sName )
        Else
            Recall = Null
        End If
    End Function

    Public Function Keys()
        Keys = oHash.Keys
    End Function
    
    Public Function SymList()
        Dim nCount
        Dim aResult
        Dim aKeys
        Dim aItems
        Dim i

        nCount = oHash.Count
        'WScript.Echo nCount
        ReDim aResult( nCount - 1 )
        aKeys = oHash.Keys
        aItems = oHash.Items

        For i = 0 To nCount - 1
            'aResult( 0, i ) = aKeys( i )
            'aResult( 1, i ) = aItems( i )
            aResult( i ) = aKeys( i ) & "^" & aItems( i )
        Next
        'WScript.Echo UBound( aResult )
        SymList = aResult
    End Function

    Public Function SymListText()
        Dim aList
        Dim sItem
        Dim i
        Dim sResult
        aList = SymList()
        For i = 0 To UBound( aList )
            sItem = Replace( aList( i ), "^", "=" )
            sResult = sResult & sItem & vbNewLine
        Next
        SymListText = sResult
    End Function

    Public Function IsSym( sName )
        IsSym = oHash.Exists( sName )
    End Function

    Public Sub StoreDup( sName, xValue )
        Dim i
        Dim sNewName
        sNewName = sName
        i = 1
        If IsSym( sNewName ) Then
            Do
                sNewName = sName & "$" & i
                If oHash.Exists( sNewName ) = False Then
                    Exit Do
                End If
                i = i + 1
            Loop
        End If

        'WScript.Echo "StoreDup", sNewName, xValue
        Store sNewName, xValue
    End Sub

    Public Sub Parse( sData, sSep )
        Dim aData
        Dim i
        Dim sLine
        Dim aLine
        Dim sKey
        Dim sValue

        aData = Split( sData, vbNewLine )
        For i  = 0 To UBound( aData )
            sLine = aData( i )
            IF sLine <> vbNullString Then
                aLine = Split( sLine, sSep )
                sKey = aLine( 0 )
                sValue = aLine( 1 )
                sKey = UCase( RTrim( RemoveSpaces( sKey ) ) )
                sValue = RTrim( sValue )
                Store sKey, sValue
            End If
        Next
    End Sub

    Public Sub Remove( sData )
        IF oHash.Exists( sData ) Then
            oHash.Remove sData
        End If
    End Sub

    Public Sub Clear()
        Dim aList
        Dim i
        Dim sLine
        Dim aLine
        aList = SymList()
        For i = 0 To UBound( aList )
            sLine = aList( i )
            aLine = Split( sLine, "^" )
            If BeginsWith( aLine( 0 ), sSystemPrefix, False ) = False Then
                Remove aLine( 0 )
            End If
        Next
    End Sub
End Class

[VBScript] Threads ... thin ones

The following is an attempt at threads in VBScript. The code owes a lot to Greg Chapman of MouseTrax Computing Solutions. There are two scripts, the first calling the second (in many instances). The means for communicating between the two is via the Volatile environment. When the script runs, Outlook flickers (don't know why).

There are comments, but the basic idea is to keep a watch over how many instances of cscript.exe there are running and while there's only so many, add more. Use the Volatile environment for semaphores and make sure there's enough delay in there to get stuff to and from Volatile (which is actually in Registry and not blazingly fast).

First the controller. '~ get list of pcs '~ for each pc in list '~ while threadcount <= max '~ launch thread with i, <pc> '~ for i = 0 to max '~ if var thread.i.status in volatile = "completed" then '~ load up text in thread.i.name.txt to database '~ 'remove thread.i.status and thread.i.name from volatile env '~ remove thread.i.name.txt '~ end if '~ wend '~ next '~ for i = 0 to max '~ remove thread.i.name from volatile '~ remove thread.i.status from volatile '~ next '~ threadcode: '~ get thread number from arguments (i) '~ get pc from arguments '~ put "running" into thread.i.status in volatile env '~ get owner of explorer.exe '~ store in <pc>.txt file '~ put path of <pc>.txt file into thread.i.name of volative env '~ put "completed" into thread.i.status '~ exit Option Explicit Dim oFSO Set oFSO = CreateObject( "Scripting.FileSystemobject" ) Dim oShell Set oShell = CreateObject( "WScript.Shell" ) Dim oVolatile Set oVolatile = oShell.Environment("VOLATILE") Const THREADS_MAX = 7 Dim i For i = 0 To THREADS_MAX oVolatile( "Thread." & i & ".status" ) = "" Next Dim aReport Dim nAvailable Dim aComputers Dim j Dim sFile Dim sData Dim nMaxComp Dim sStatus Dim sName ReDim aReport( 0 ) aComputers = GetDomainComputers( "THEDOMAIN" ) nMaxComp = UBound( aComputers ) i = 0 Do While True If ThreadCount() <= THREADS_MAX Then nAvailable = AvailableThread( THREADS_MAX ) '~ WScript.Echo "next available slot " & nAvailable IF nAvailable = -1 Then 'Error Condition. Crash out. '~ WScript.Echo "nAvailable = -1 but ThreadCount says " & ThreadCount() & " against a max of " & THREADS_MAX ProcessCompletions Else '~ WSCript.Echo "Launching " & nAvailable & " on " & aComputers( i ) WScript.Echo aComputers( i ) & " @ " & nAvailable LaunchThread nAvailable, aComputers( i ) WScript.Sleep 1000 i = i + 1 End If Else ProcessCompletions End If If i > nMaxComp Then Exit Do End If Loop WriteFile2 oFSO.GetParentFolderName( WScript.ScriptFullName ) & "\Report.txt", Join( aReport, vbNewLine ), WF_CREATE Sub ProcessCompletions Dim j Dim sName Dim sStatus Dim sFile Dim sData For j = 0 To THREADS_MAX sName = "Thread." & j & ".name" sStatus = "Thread." & j & ".status" If oVolatile( sStatus ) = "completed" Then '~ WScript.Echo "Thread " & j & " completed." sFile = oVolatile( sName ) '~ WScript.Echo "Trying to read " & sFile On Error Resume Next sData = ReadFile( sFile ) If Err.Number <> 0 Then sData = "Could not open " & sFile End If Err.Clear On Error Goto 0 AAdd aReport, sData ' put into database later On Error Resume Next oFSO.DeleteFile( sFile ) Err.Clear On Error GoTo 0 oVolatile( "Thread." & j & ".status" ) = "" End If Next End Sub 'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html '---------------------------------------------------------------- ' Function: GetDomainComputers ' Description: Returns a listing of NT Computer Accounts for a ' given domain ' Parameters: ByVal strDomain - Name of an NT Domain to retrieve ' the list of Computer from. ' Returns: Variant array of NT Computer names for the ' specified domain. '---------------------------------------------------------------- Public Function GetDomainComputers(ByVal strDomain) Dim objIADsContainer ' ActiveDs.IADsDomain - ' Container object Dim objIADsComputer ' ActiveDs.IADsComputer Dim vReturn ' Variant ' connect to the computer. Set objIADsContainer = GetObject("WinNT://" & strDomain) ' set the filter to retrieve only objects of class Computer objIADsContainer.Filter = Array("Computer") ReDim vReturn(0) For Each objIADsComputer In objIADsContainer If Trim(vReturn(0)) <> "" Then ReDim Preserve vReturn(UBound(vReturn) + 1) End If vReturn(UBound(vReturn)) = objIADsComputer.Name Next GetDomainComputers = vReturn Set objIADsComputer = Nothing Set objIADsContainer = Nothing End Function Function ThreadCount() Dim cProcs, oProc Dim nCount Set cProcs = GetObject( "winmgmts:{ImpersonationLevel = Impersonate}\\.").InstancesOf( "Win32_Process" ) nCount = 0 For Each oProc in cProcs If LCase( oProc.Caption ) = "cscript.exe" Then nCount = nCount + 1 End If Next '~ WScript.Echo "ThreadCount is " & nCount Set cProcs = Nothing ThreadCount = nCount End Function Function AvailableThread( nMax ) Dim i Dim sThread Dim nAvailable Dim sValue nAvailable = -1 For i = 0 To nMax sThread = "Thread." & i & ".status" sValue = oVolatile( sThread ) If sValue = vbNullString Then nAvailable = i Exit For End If Next AvailableThread = nAvailable End Function Sub LaunchThread( nThread, sPC ) Dim sCmd sCmd = "cscript.exe " & dq( oFSO.GetParentFolderName( WScript.ScriptFullName ) ) & "\db_build_thread.vbs" & " " & nThread & " " & sPC oShell.Run sCmd,0,False End Sub Function DQ( sText ) DQ = Chr( 34 ) & sText & Chr( 34 ) End Function Function ReadFile( FileName) Dim oStream Dim sData sData = VBNullString Set oStream = oFSO.OpenTextFile(FileName) sData = oStream.ReadAll oStream.Close ReadFile = sData End Function Function AAdd( ByRef aToThis, ByVal xAddThis ) Dim nPos nPos = UBound( aToThis ) + 1 '~ WScript.Echo nPos ReDim Preserve aToThis( nPos ) aToThis( nPos ) = xAddThis AAdd = nPos End Function Const WF_APPEND = 1 Const WF_CREATE = 2 Const WF_FOR_APPENDING = 8 Const WF_FOR_WRITING = 2 Const WF_CREATE_NONEXISTING = True Sub WriteFile2( sFilename, sContents, nMode ) Dim oStream If nMode = WF_APPEND Then Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_APPENDING, WF_CREATE_NONEXISTING ) ElseIf nMode = WF_CREATE Then Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_WRITING, WF_CREATE_NONEXISTING ) Else Die "Mode incorrectly set for WriteFile2" End If oStream.Write sContents oStream.Close End Sub Then the controlled. '~ threadcode: '~ get thread number from arguments (i) '~ get pc from arguments '~ put "running" into thread.i.status in volatile env '~ get owner of explorer.exe '~ store in <pc>.txt file '~ put path of <pc>.txt file into thread.i.name of volative env '~ put "completed" into thread.i.status '~ exit 'objects and vars Dim oFSO Set oFSO = CreateObject( "Scripting.FileSystemobject" ) Dim oShell Set oShell = CreateObject( "WScript.Shell" ) Dim oNetwork Set oNetwork = CreateObject("WScript.Network") Dim oVolatile Set oVolatile = oShell.Environment("VOLATILE") Const WF_APPEND = 1 Const WF_CREATE = 2 Const WF_FOR_APPENDING = 8 Const WF_FOR_WRITING = 2 Const WF_CREATE_NONEXISTING = True Sub WriteFile2( sFilename, sContents, nMode ) Dim oStream If nMode = WF_APPEND Then Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_APPENDING, WF_CREATE_NONEXISTING ) ElseIf nMode = WF_CREATE Then Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_WRITING, WF_CREATE_NONEXISTING ) Else Die "Mode incorrectly set for WriteFile2" End If oStream.Write sContents oStream.Close End Sub Function GetDomainUser( sComputer ) Dim cProc Dim oProcess Dim sUser, sDomain Dim sResult Dim oWMI sResult = "<not switched on>" If ResolveIP( sComputer ) <> Empty Then On Error Resume Next Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\CIMV2") If Err.Number = 0 Then 'Get currently logged on user and update CurrentUser element. 'This bit of code is "cheating" slightly in that all it's doing is getting the owner of the explorer.exe process. Seeing as explorer.exe 'only runs if a user is logged on it is a reliable (but sneaky) way of getting the logged-on user. It does, however, mean that even if a 'user is logged on locally or the account is a generic account, it will retrieve the correct values (WMI cannot do this). Set cProc = oWMI.ExecQuery("Select Name from Win32_Process Where Name='explorer.exe' and SessionID=0") If cProc.Count > 0 Then For Each oProcess In cProc oProcess.GetOwner sUser, sDomain sResult = sDomain & "\" & sUser Next Else sResult = "<not logged on>" End If Err.Clear On Error Goto 0 End If End If GetDomainUser = sResult End Function Function ResolveIP( sName ) Dim sHost Dim sTarget Dim cPingResults Dim oPingResult Dim sResult sResult = "" sHost = oNetwork.ComputerName sTarget = sName Set cPingResults = GetObject("winmgmts:{impersonationLevel=impersonate}//" & _ sHost & "/root/cimv2"). ExecQuery("SELECT * FROM Win32_PingStatus " & _ "WHERE Address = '" + sTarget + "'") For Each oPingResult In cPingResults If oPingResult.StatusCode = 0 Then sResult = oPingResult.ProtocolAddress End If Next ResolveIP = sResult End Function Dim oArgs Set oArgs = WScript.Arguments.Unnamed Dim nThreadNumber Dim sPC If oArgs.Count < 1 Then WScript.Echo WScript.ScriptName & " <threadnumber> <pc>" WScript.Quit End If nThreadNumber = oArgs( 0 ) sPC = oArgs( 1 ) 'WScript.Echo nThreadNumber, sPC Dim sOutput oVolatile( "Thread." & nThreadNumber & ".status" ) = "running" sOutput = oFSO.GetParentFolderName( WScript.ScriptFullName ) & "\" & sPC & ".txt" '~ WScript.Echo sOutput oVolatile( "Thread." & nThreadNumber & ".name" ) = sOutput Dim sDomUser sDomUser = GetDomainUser( sPC ) WriteFile2 sOutput, sPC & vbTab & sDomUser, WF_CREATE oVolatile( "Thread." & nThreadNumber & ".status" ) = "completed" There are quite a few extra useful routines in all that code, including an AADD(), and assorted WMI related routines.

I'm in the process of putting the thread functionality inside a Class so that I can change how things are done without causing drastic rewrites of the original VBScripts. I'm not entirely pleased with the Volatile environment and may end up playing with something else that can be used as a shared storage area between many programs ... like subdirectory structures.