Code-a-holic: [VBScript] Threads ... thin ones

Tuesday, January 10, 2006

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

5 comments:

Anonymous said...: How are these threads? you're spawning processes, no?; 8:47 pm
Bruce M. Axtens said...: Well ... (cough, cough) ... err ... umm ... yes, they're processes (blush). It's about the closest VBScript gets to threads. If I remember correctly, the MouseTrax article used the term and I blithely followed.; 6:20 pm
Andy said...: Once I finally understood what you're doing there, I caught myself quietly muttering...

"That's cool"

Neat concept.

Andy; 12:35 pm
Bruce M. Axtens said...: Thanks for dropping by, Andy. It's great to see that these articles are still being read after all these years.; 4:31 pm
Anonymous said...: You ranked 3rd on google for 'vbscript background thread' so I do appreciate your contribution; I am looking to incorperate this into a HTA so that I can get a more responsive UI, especially when I have a process that can run up to and beyond 8 hours [really].; 4:33 am