[Visual BASIC 6] BOOST (v2)

I revisited BOOST this week. A friend had pointed out to me some time back that /P: and /L: were a bit of a pain when one wanted to speed something up quickly, or kill it quickly. So this version changes the command line handling.

This version also demonstrates how to kill a process. In fact it kills every process of the same name. I wish I'd had this a couple of years ago when I was doing stuff with Excel -- I'd end up with multiple Excel sessions which I would then have to kill off one-by-one through the Task Manager. (I eventually ended up installing Cygwin so that I could script the process.)

If you remember the original VBScript of BOOST and the first VB6 version, you'll see some similarities.

I've given up on using setsubsys in favour of using VBAdvance (which is now freeware) to handle the compile-to-console-app process. I'm still compressing the app using UPX.

First a few constants and the declarations, found on vb.mvps.org, for doing console I/O.

Option Explicit Const KILL_PROCESS = 0 '0 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 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

Next, a few supporting functions. First off the rank, is an invocation syntax display. Notice that priority can now be specified either by a number (0 to kill, 1-6 for low to realtime) or by name (kill, low, belownormal, normal, abovenormal, high, realtime).

Sub Syntax() ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost {processname} {runlevel}" & vbNewLine & _ "Run level as number:" & vbNewLine & _ vbTab & "0 = KILL_PROCESS" & 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 & vbNewLine & vbNewLine & _ "Run level as text:" & vbNewLine & _ vbTab & "kill = KILL_PROCESS" & vbNewLine & _ vbTab & "low = LOW_PRIORITY" & vbNewLine & _ vbTab & "belownormal = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "normal = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "abovenormal = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "high = HIGH_PRIORITY" & vbNewLine & _ vbTab & "realtime = REALTIME_PRIORITY" & vbNewLine) End Sub

Second, the command line parser. This splits on space and tab and is based on code found at microsoft.public.vb.winapi

Function GetCommandLine(Optional MaxArgs) As Variant 'Declare variables. Dim C As String Dim CmdLine As String Dim CmdLnLen As Integer Dim InArg As Boolean Dim i As Integer Dim NumArgs As Integer Dim ArgArray As Variant 'See if MaxArgs was provided. If IsMissing(MaxArgs) Then MaxArgs = 10 'Make array of the correct size. ReDim ArgArray(MaxArgs - 1) NumArgs = 0: InArg = False 'Get command line arguments. CmdLine = Command() CmdLnLen = Len(CmdLine) 'Go thru command line one character 'at a time. For i = 1 To CmdLnLen C = Mid(CmdLine, i, 1) 'Test for space or tab. If (C <> " " And C <> vbTab) Then 'Neither space nor tab. 'Test if already in argument. If Not InArg Then 'New argument begins. 'Test for too many arguments. If NumArgs = MaxArgs Then Exit For NumArgs = NumArgs + 1 InArg = True End If 'Concatenate character to current argument. ArgArray(NumArgs - 1) = ArgArray(NumArgs - 1) & C Else 'Found a space or tab. 'Set InArg flag to False. InArg = False End If Next i 'Resize array just enough to hold arguments. ReDim Preserve ArgArray(NumArgs - 1) 'Return Array in Function name. GetCommandLine = ArgArray '() End Function

Third, the two routines which wrap the WMI functions to set priority and to kill process. The latter was found at tek-tips. If I remember correctly, the places in each routine where it says

sComputer = "."

could, in fact, have some other computer's name. If you had sufficient privilege you could be tweaking or killing a process on someone else's machine.

Function SetPriority(sProcess As String, nPriority As Integer) As Boolean Dim sComputer As String Dim oWMIService As Object Dim cProcesses As Object Dim oProcess As Object Dim bDone As Boolean bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") On Error Resume Next Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) If Err.Number <> 0 Then GoTo DoNext End If bDone = True DoNext: Next On Error GoTo 0 SetPriority = bDone End Function Function KillProcess(sProcess As String) As Integer Dim oWMIService As Object Dim sComputer As String Dim oProcess As Object Dim nDone As Integer nDone = 0 sComputer = "." 'this computer Set oWMIService = GetObject("winmgmts:") For Each oProcess In oWMIService.InstancesOf("Win32_process") If LCase(oProcess.Name) = LCase(sProcess) Then oProcess.Terminate nDone = nDone + 1 End If Next KillProcess = nDone End Function

Finally, the Main subroutine. Notice the additions to the priorities collection. Note also the change in the way the command line is handled.

Because there's no .Exists method on Collections, the .Item call is wrapped in an 'On Error' so that a non-existent item situation is caught appropriately.

Sub Main() Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim nInstances As Integer Dim dPriorities As New Collection dPriorities.Add Item:=KILL_PROCESS, Key:="kill" dPriorities.Add Item:=LOW_PRIORITY, Key:="low" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="belownormal" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="normal" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="abovenormal" dPriorities.Add Item:=HIGH_PRIORITY, Key:="high" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="realtime" dPriorities.Add Item:=KILL_PROCESS, Key:="0" dPriorities.Add Item:=LOW_PRIORITY, Key:="1" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="2" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="3" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="4" dPriorities.Add Item:=HIGH_PRIORITY, Key:="5" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="6" Dim aArgs As Variant If Command() = "" Then Syntax End End If aArgs = GetCommandLine(2) sProcess = aArgs(0) sLevel = aArgs(1) If sProcess = "" Or sLevel = "" Then Syntax End End If On Error Resume Next nLevel = dPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite "Invalid selection of runlevel." & vbNewLine Syntax End End If On Error GoTo 0 If nLevel = 0 Then nInstances = KillProcess(sProcess) If nInstances = 0 Then ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine Else ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine End If Else ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _ " boosted", " NOT boosted") & _ " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine End If End Sub

What's next with this thing? I suppose one could explore the possibility of influencing the lives of applications on other computers:

BOOST Skype.exe kill /C:GUEST_01

There's also the fact that the commandline parser doesn't properly handle double-quoted names. If an .exe had a space it its name, you wouldn't be able use BOOST on it.

Finally, here's a short batch file (killall.bat) I use for killing applications en masse. It was originally designed to get around the 'typing the /P and /L' issue, but I'm so used to using it now ...

@echo off :loop if %1@==@ goto done c:\bin\boost %1 kill shift goto loop :done

An example invocation:

killall excel.exe outlook.exe

© Copyright Bruce M. Axtens, 2007

[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] Where else have I logged in on this network?

It's not so much a question for me -- I remotely log into many pcs daily as part my job, and try to leave as few tracks as possible. However, today a customer rang saying she'd lost a few important Favourites and had no backup. The best way I could think of helping her, was to locate all the machines she's logged into and see if any of the Favourites could be found.

I did find what she was looking for. Here's the code I used.

First the standard header implementing the synthetic include (derived from Rube Goldberg Memorial Scripting Page)

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"

StandardLibrary.vbs is getting big. 1500+ lines of code.

Next a little function for a right fill. Having needed this only once, I haven't included it in the StandardLibrary.

Function RightFill( sText, nLen, sFill )
    RightFill = Left( sText & String( nLen, sFill ), nLen )
End Function

Now the main body of the script.

1. Check commandline to see if a username is specified.
1.1 If nothing specified, throw a fit.
2. Get an array of all the computers currently online.
2.1 No error checking here but there ought to be
3. Tell everyone what's going on.
4. Loop through the names of the online machines
4.1 Trim off the leading \\ put on by NET VIEW
4.2 Write out the name, right filled with dots
4.3 Get an array of the login profiles for the computer
4.4 Scan the array to see if contains the the username (case insensitive search)
4.4.1 If found say so with a CRLF
4.4.2 otherwise issue a CR

The calls to BeginsWith are commented out. They apply only to my situation where a company edict ensures that all desktop pc names start with PC and all laptops with LP.

Dim oArgs
Set oArgs = WScript.Arguments.Unnamed

If oArgs.Count > 0 Then
    sToFind = oArgs( 0 )
Else
    WScript.Echo "Syntax:" & vbNewLine & vbTab & WScript.ScriptName & " domain\username"
    WScript.Quit
End If

Dim aComp
aComp = GetOnLineComputers( "XXXX" ) 

Dim i
Dim sComp
Dim aProf
Dim sToFind

WScript.Echo "Searcing for " & sToFind & " on network"

For i = 0 To UBound( aComp )
    sComp = Replace( aComp( i ), "\\", vbNullString )
    'If BeginsWith( sComp, "PC", True ) Or BeginsWith( sComp, "LP", True ) Then
        WScript.StdOut.Write RightFill( sComp, 10, "." ) 

        aProf = GetLoginProfiles( sComp )
        If StrInArray( sToFind, aProf, True ) Then 
            WScript.StdOut.Write " has " & sToFind & vbNewLine
        Else
            WScript.StdOut.Write vbCR
        End If
    'End If
Next

The supporting library rountines are below, First GetOnLineComputers with its supporting routines, GetNetView, CaptureDOS and ReadFile

Function GetOnlineComputers( sDomain )
    Dim sTemp
    Dim aTemp
    Dim aResult
    Dim i
    sTemp = GetNetView( sDomain )
    aTemp = Split( sTemp, vbNewLine )
    Redim aResult( UBound( aTemp ) - 6 )

    For i = 3 To UBound( aTemp ) - 3
        aResult( i - 3 ) = NthField( aTemp( i ), " ", 1 )
    Next

    GetOnlineComputers = aResult
End Function

Function GetNetView( sDomain )
    GetNetView = CaptureDOS( "%COMSPEC% /C NET VIEW /DOMAIN:" & sDomain, True )
End Function

Function CaptureDOS( sCommand, bSynch )
    Dim sFolder
    Dim sName
    Dim sTempFile
    Dim sResult

    sResult = vbNullString

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sTempFile = oFSO.BuildPath( sFolder, sName )
    oShell.Run sCommand & "> " & DQ( sTempFile ), 0, bSynch
    sResult = ReadFile( sTempFile )
    oFSO.DeleteFile( sTempFile )
    CaptureDOS = sResult
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

Next, BeginsWith (included for completeness sake)

Function BeginsWith( sText, sBeginning, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sBeginning = VBNullString Then
        bResult = True
    Else
        If sText <> VBNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Left( UCase( sText ), Len( sBeginning ) ) = UCase( sBeginning ) )
            Else
                bResult = ( Left( sText, Len( sBeginning ) ) = sBeginning )
            End If
        End If
    End If

    BeginsWith = bResult
End Function

Then GetLoginProfiles, plus support routine AAdd

Function GetLoginProfiles( sComputer )
    Dim cItems
    Dim oItem
    Dim aResult
    ReDim aResult( -1 )

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
    If Err.Number = 0 Then
        Set cItems = oWMI.ExecQuery("Select Name from Win32_NetworkLoginProfile",,48)
        For Each oItem in cItems
            AAdd aResult, oItem.Name 
        Next

    End If
    Err.Clear
    On Error Goto 0

    GetLoginProfiles = aResult 
End Function

Function AAdd( ByRef aToThis, ByVal xAddThis )
    Dim nPos
    nPos = UBound( aToThis ) + 1
    ReDim Preserve aToThis( nPos )
    aToThis( nPos ) = xAddThis
    AAdd = nPos
End Function

And, finally, StrInArray.

Function StrInArray( sItem, aList, bCaseInsensitive )
    Dim i
    Dim u
    Dim bResult
    bResult = False
    u = UBound( aList )
    For i = 0 To u
        If bCaseInsensitive Then
            bResult = ( LCase( sItem ) = LCase( aList( i ) ) )
        Else
            bResult = ( sItem = aList( i ) )
        End If
    Next
    StrInArray = bResult
End Function

Unfortunately, this does not run quickly. It can take ages to get through the entire list and sometimes hangs inexplicably. Your mileage may vary.

If anyone comes up with a faster way of doing this I'd be very interested.

[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.

[VBScript] Deriving user name from computer name

I found a brilliant bit of code for deriving the username from the computer name. It's found inside Matt Williams's "ManagePC v1.31" HTA. His description of the routine is as follows

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).
-- Matthew Williams, ManagePC

Below is my routine, combining his code with some extra housekeeping. 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 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 Of course, if no one is logged in, you get nothing. My own take on Matt's routine adds in a check to see if the computer is actually running, using ResolveIP() below: 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