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

[Euphoria] Structured Access, part 2

I knew I had it somewhere. Okay, these implement the following: BYTE, BYTES, WORD, DWORD, QWORD, ASCIIZ and PSTRING. You can pull the data one chunk at a time as per the last posting or else pull a whole set all at once.

The file versions don't work and I'm not sure why, and as I said before, I don't have the time to do anything about it.

By the way, this was written before Euphoria 2.5. In fact, possibly before 2.4 so the code may need some tweaking.

mread is like the getmem of the previous posting. memread takes a sequences of reads. I will eventually post an example (if I can find one).

(Since writing part 1, I've been in touch with CChris from Euphoria Standard Library who has taken over the development of getmem. It's great to be able to give something back to the Euphoria community after all these years (I've been using it since version 1.5).)

-- tools for structures, based on earlier work in misctool.e
--
-- memload procedure. Initialises memBlock to contents of passed
--      sequence.
-- memread function. Reads memBlock according to parameters and
--      returns as sequence
-- memfree procedure. Frees allocated memory.

-- fmemload procedure. Like memload but sets up for direct file
--      access.
-- fmemread function. Reads file according to parameters.
-- fmemfree procedure. Close file.

include machine.e
include file.e
include get.e

atom memBlock
integer memAllocated

integer fileNumber
integer fileAllocated
integer fileLength

memAllocated = 0
fileAllocated = 1

function mread( integer offset, sequence typ )
        sequence conv
        object result
        integer i
        if equal( typ, "BYTE" ) then
                result = peek( memBlock + offset )

        elsif equal( typ, "WORD" ) then
                conv = peek( { memBlock + offset, 2 } ) & { 0, 0 }
                result = bytes_to_int( conv )

        elsif equal( typ, "DWORD" ) then
                conv = peek( { memBlock + offset, 4 } )
                result = bytes_to_int( conv )

        elsif equal( typ, "QWORD" ) then
                result = peek( { memBlock + offset, 8 } )

        elsif equal( typ, "ASCIIZ" ) then
                i = 0
                result = {}
                while 1 = 1 do
                        conv = peek( memBlock + offset + i )
                        if conv = #00 then
                                exit
                        end if
                        result &= conv
                        i = i + 1
                end while

        elsif equal( typ[ 1 .. 5], "BYTES" ) then
                i = typ[ 6 ]
                result = peek( { memBlock + offset, i } )

        elsif equal( typ, "PSTRING" ) then
                i = peek( { memBlock + offset, 1 } )
                result = peek( { memBlock + offset + 1, i } )
        end if
        return result
end function

function fpeek( object access )
        integer seke
        object result
        result = -1
        if atom( access ) then -- byte at offset
                if access <= fileLength then
                        seke = seek( fileNumber, access )
                        if seke = 0 then
                                result = getc( fileNumber )
                        end if
                end if
        else -- sequence of offset and length
                if ( access[ 1 ] + access[ 2 ] ) <= fileLength then
                        seke = seek( fileNumber, access[ 1 ] )
                        if seke = 0 then
                                result = get_bytes( fileNumber, access[ 2 ] )
                        end if
                end if
        end if
        return result
end function

function fmread( integer offset, sequence typ )
        sequence conv
        object result
        integer i
        if equal( typ, "BYTE" ) then
                result = fpeek(  offset )

        elsif equal( typ, "WORD" ) then
                conv = fpeek( {  offset, 2 } ) & { 0, 0 }
                result = bytes_to_int( conv )

        elsif equal( typ, "DWORD" ) then
                conv = fpeek( {  offset, 4 } )
                result = bytes_to_int( conv )

        elsif equal( typ, "QWORD" ) then
                result = fpeek( {  offset, 8 } )

        elsif equal( typ, "ASCIIZ" ) then
                i = 0
                result = {}
                while 1 = 1 do
                        conv = fpeek(  offset + i )
                        if conv = #00 then
                                exit
                        end if
                        result &= conv
                        i = i + 1
                end while

        elsif equal( typ[ 1 .. 5], "BYTES" ) then
                i = typ[ 6 ]
                result = fpeek( {  offset, i } )

        elsif equal( typ, "PSTRING" ) then
                i = fpeek( {  offset, 1 } )
                result = fpeek( {  offset + 1, i } )
        end if
        return result
end function

global procedure memload( sequence data )
        memBlock = allocate( length( data ) + 1 )
        poke( memBlock, data )
        memAllocated = 1
end procedure

global procedure memfree()
        if memAllocated = 1 then
                free( memBlock )
        end if
end procedure

global function memread( sequence offsetTypes )
        object result
        result = -1
        if memAllocated = 1 then
                result = repeat( {}, length( offsetTypes ) )
                for i = 1 to length( offsetTypes ) do
                        result[ i ] = mread( offsetTypes[ i ][ 1 ], offsetTypes[ i ][ 2 ] )
                end for
        end if
        return result
end function

global procedure fmemload( sequence file )
        integer res
        fileNumber = open( file, "rb" )
        if fileNumber != -1 then
                fileAllocated = 1
                res = seek( fileNumber, -1 )
                if res = 0 then
                        fileLength = where( fileNumber )
                else
                        fileLength = 0
                end if
        end if
end procedure

global procedure fmemfree()
        if fileAllocated = 1 then
                close( fileNumber )
        end if
end procedure

global function fmemread( sequence offsetTypes )
        object result
        result = -1
        if fileAllocated = 1 then
                result = repeat( {}, length( offsetTypes ) )
                for i = 1 to length( offsetTypes ) do
                        result[ i ] = fmread( offsetTypes[ i ][ 1 ], offsetTypes[ i ][ 2 ] )
                end for
        end if
        return result
end function

[Euphoria] Structured Access

Late last century, in a developing part of the world, I tried writing a diskette cataloguer. It worked okay, once I'd figured out how to do all the gymnastics necessary for BIOS calls. In the process I wrote a function to access memory in a structured way. Brilliant as Euphoria sequences are, they are just that: sequences. There's little in the way of structure, unless you apply some of your own.

I've reproduced the function in its entirety below. Essentially, the code takes data from memory in a structure way, that is, in terms of BYTE, BYTES, WORD, DWORD or ASCIIZ.

An attempt was made to make the functions applicable to files. Those routines don't work, and I haven't taken the time to find out why. Good as Euphoria is, there's no Mac OS X version (so I can't use it at home) and there's no opportunity to use it at work -- Euphoria's not in the SOE. If you're interested in looking at the code, write.

global function getmem( atom addr, integer offset, sequence typ )
        sequence conv
        object result
        integer i
        if equal( typ, "BYTE" ) then
                result = peek( addr + offset )
        elsif equal( typ, "WORD" ) then
                conv = peek( { addr + offset, 2 } ) & { 0, 0 }
                result = bytes_to_int( conv )
        elsif equal( typ, "DWORD" ) then
                conv = peek( { addr + offset, 4 } )
                result = bytes_to_int( conv )
        elsif equal( typ, "ASCIIZ" ) then
                i = 0
                result = {}
                while 1 = 1 do
                        conv = peek( addr + offset + i )
                        if conv = #00 then
                                exit
                        end if
                        result &= conv
                        i = i + 1
                end while
        elsif equal( typ[ 1 .. 5], "BYTES" ) then
                i = typ[ 6 ]
                result = peek( { addr + offset, i } )
        end if
        return result

end function

As an example of how to use getmen, below is the code for GetDriveParameterTable

global constant GDPT_DRIVE = 1,
                GDPT_UNIT = 2,
                GDPT_BYTES_PER_SECTOR = 3,
                GDPT_SECTORS_PER_CLUSTER_MINUS_1 = 4,
                GDPT_SECTORS_PER_CLUSTER_MULITPLIER = 5 ,
                GDPT_BOOT_SECTORS = 6,
                GDPT_FAT_COPIES = 7,
                GDPT_ROOT_DIRECTORY_ENTRIES = 8,
                GDPT_FIRST_DATA_SECTOR = 9,
                GDPT_TOTAL_CLUSTERS_PLUS_1 = 10,
                GDPT_NUMBER_SECTORS_PER_FAT = 11,
                GDPT_FIRST_ROOT_SECTOR = 12,
                GDPT_PTR_DEVICE_DRIVER_HEADER = 13,
                GDPT_MEDIA_DESCRIPTOR_BYTE = 14,
                GDPT_DISK_ACCESSED_BYTE = 15,
                GDPT_PTR_NEXT_DRIVE_PARAMETER_TABLE = 16,
                GDPT_FIRST_FREE_CLUSTER = 17,
                GDPT_NUMBER_FREE_CLUSTERS = 18

global function GetDriveParameterTable( integer logicalDrive )
        sequence r
        atom DPT
        integer drive
        integer unit
        integer bytesPerSector
        integer sectorsPerClusterMinus1
        integer sectorsPerClusterMulitplier
        integer bootSectors
        integer FATcopies
        integer rootDirectoryEntries
        integer firstDataSector
        integer totalClustersPlus1
        integer numberSectorsPerFAT
        integer firstRootSector
        atom ptrDeviceDriverHeader
        integer mediaDescriptorByte
        integer diskAccessedByte
        atom ptrNextDriveParameterTable
        integer numberFreeClusters
        integer firstFreeCluster
        
        r = repeat( 0, 10 )
        r[ REG_AX ] = #3200 --#1F00
        r[ REG_DX ] = logicalDrive
        r = dos_interrupt( #21, r )
        if lobyte( r[ REG_AX ] ) != 255 then
                DPT = r[ REG_DS ] * 16 + r[ REG_BX ]
                
                drive = getmem( DPT, #00, "BYTE" ) 
                unit  = getmem( DPT, #01, "BYTE" ) 
                bytesPerSector = getmem( DPT, #02, "WORD" )
                sectorsPerClusterMinus1 = getmem( DPT, #04, "BYTE" )
                sectorsPerClusterMulitplier = getmem( DPT, #05, "BYTE" )
                bootSectors = getmem( DPT, #06, "WORD" )
                FATcopies = getmem( DPT, #08, "BYTE" )
                rootDirectoryEntries = getmem( DPT, #09, "WORD" )
                firstDataSector = getmem( DPT, #0B, "WORD" )
                totalClustersPlus1 = getmem( DPT, #0D, "WORD" )
                numberSectorsPerFAT = getmem( DPT, #0F, "WORD" )
                firstRootSector = getmem( DPT, #11, "WORD" )
                ptrDeviceDriverHeader = getmem( DPT, #13, "DWORD" )
                mediaDescriptorByte = getmem( DPT, #17, "BYTE" )
                diskAccessedByte = getmem( DPT, #18, "BYTE" )
                ptrNextDriveParameterTable = getmem( DPT, #19, "DWORD" )
                firstFreeCluster = getmem( DPT, #1D, "WORD" )
                numberFreeClusters = getmem( DPT, #1F, "WORD" )
                return { drive, 
                        unit, 
                        bytesPerSector, 
                        sectorsPerClusterMinus1, 
                        sectorsPerClusterMulitplier, 
                        bootSectors, 
                        FATcopies, 
                        rootDirectoryEntries, 
                        firstDataSector, 
                        totalClustersPlus1, 
                        numberSectorsPerFAT, 
                        firstRootSector, 
                        ptrDeviceDriverHeader, 
                        mediaDescriptorByte, 
                        diskAccessedByte, 
                        ptrNextDriveParameterTable, 
                        firstFreeCluster, 
                        numberFreeClusters } 
        else
                return -1
        end if
end function

As an example of the BYTES parameter:

global function GetDiskLabels( integer drive )
        sequence r
        atom addr
        object result


        addr = allocate_low( 25 )
        r = repeat( 0, 10 )

        r[ REG_AX ] = #6900
        r[ REG_BX ] = drive
        r[ REG_DS ] = floor( addr / 16 )
        r[ REG_DX ] = remainder( addr, 16 )

        r = dos_interrupt( #21, r )

        if not Carry( r ) then
                result = { getmem( addr, #00, "WORD" ),
                           getmem( addr, #02, "DWORD" ),
                           getmem( addr, #06, "BYTES" & 11 ),
                           getmem( addr, #11, "BYTES" & 8 )
                         }
        else
                result = -1

        end if

        free_low( addr )

        return result

end function

The ASCIIZ parameter is like the BYTES except it keeps working its way through memory until it encounters a binary zero and then returns everything up to that point.

From memory I remember writing a version of getmem() which received a sequence of BYTE, WORD, etc. specifications and returned the resulting sequence of results. When I find it I'll post it.

Enjoy.

[VBScript] A CLI framework

Here's a simple framework for building your own CLI (Command Language Interface) Dim sLine Dim aLine Dim sKeyword Dim sArguments Do While True WScript.StdOut.Write ">> " sLine = WSCript.StdIn.ReadLine aLine = Split( sLine, " ", 2 ) If UBound( aLine ) > -1 Then sKeyword = aLine( 0 ) If UBound( aLine ) > 0 Then sArguments = aLine( 1 ) Else sArguments = "" End If Select Case LCase( sKeyword ) Case "quit", "exit", "bye" Exit Do Case "eval" Evaluate sArguments Case "echo" Evaluate "wscript.echo " & sArguments Case "set" Evaluate "Set " & sArguments Case "run" Evaluate "oShell.Run " & sArguments End Select End If Loop Sub Evaluate( sArg ) On Error Resume Next ExecuteGlobal sArg If Err.Number <> 0 Then WScript.Echo "Error:",Err.Number WScript.Echo vbTab, Err.Source WScript.Echo vbTab, Err.Description Err.Clear End If On Error GoTo 0 End Sub Keywords at this point are: quit, exit, bye, eval, echo, set and run. Below is a sample session. >> foo foo? >> my dog has fleas my? >> eval dim a >> eval a = 1000 >> echo a*a 1000000 >> echo b >> set Error: 1002 Microsoft VBScript compilation error Syntax error >> set x Error: 1011 Microsoft VBScript compilation error Expected '=' >> set x= Error: 1002 Microsoft VBScript compilation error Syntax error >> set x=1 Error: 424 Microsoft VBScript runtime error Object required >> set onotes = createobject("notes.notessession") >> echo onotes.username CN=Bruce Axtens/O=XXXX >> bye Now my own version adds a little to this framework by including a .vbs file full of extra symbols, procedures and classes. I've reproduced it below just so that you can see how to do a synthetic include in VBScript. Interestingly, the technique also works in HTAs. 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 GetEnv( "USERPROFILE" ) & "\Desktop\Stuff\Dev\Lib.vbs" Dim oNotes Set oNotes = CreateObject( "Notes.NotesSession" ) Dim sLine Dim aLine Dim sKeyword Dim sArguments Do While True WScript.StdOut.Write ">> " sLine = WSCript.StdIn.ReadLine aLine = Split( sLine, " ", 2 ) If UBound( aLine ) > -1 Then sKeyword = aLine( 0 ) If UBound( aLine ) > 0 Then sArguments = aLine( 1 ) Else sArguments = "" End If Select Case LCase( sKeyword ) Case "quit", "exit", "bye" Exit Do Case "eval" Evaluate sArguments Case "echo" Evaluate "wscript.echo " & sArguments Case "set" Evaluate "Set " & sArguments Case "run" Evaluate "oShell.Run " & sArguments Case Else WScript.Echo sKeyword & "?" End Select End If Loop Sub Evaluate( sArg ) On Error Resume Next ExecuteGlobal sArg If Err.Number <> 0 Then WScript.Echo "Error:",Err.Number WScript.Echo vbTab, Err.Source WScript.Echo vbTab, Err.Description Err.Clear End If On Error GoTo 0 End Sub Enjoy.

[VBScript] CSV to variables using Execute

Nico wrote, on microsoft.public.scripting.vbscript:

I need ASP to read the CSV file to read lines 2 on-wards and display it back to the user for verification. Each line has aprx 8 "," that control user properties.

I am looking for each line to be displayed back to the user without the "," so they can verify and write to an access db.

All i am looking for is a simple way to read the text display to the user for acceptance before writing it back to the db.

I wrote a response but thought a fuller treatment was in order, thus the following:

Data, stored in DEMO.CSV 0084,DALTON,ANGELA,01-08-06,15:07:29,16:04:04,00:56:35 0085,CONNELLY,BILLY,01-08-06,15:07:29,16:04:04,00:56:35 0086,LE CHOCOLATE FACTORIE,CHARLEY,01-08-06,15:07:29,16:04:04,00:56:35 0087,INT LIONSDEN,DANIEL,01-08-06,15:07:29,16:04:04,00:56:35 0088,SMITH,EDWINA,01-08-06,15:07:29,16:04:04,00:56:35 0089,L'KING,FREDERICK,01-08-06,15:07:29,16:04:04,00:56:35 Then the code which does nothing other than read the file, store the data in variables for each line of data, and for effect, echoes the first and last names Dim OPID Dim LastName Dim FirstName Dim CallDate Dim LogonTime Dim LogoffTime Dim WorkHours Dim aVars aVars = Array( "OPID", "LastName", "FirstName", "CallDate", "LogonTime", "LogoffTime", "WorkHours" ) Dim oFSO Set oFSO = CreateObject( "Scripting.FileSystemobject" ) Const INPUT_FILE = "DEMO.CSV" Dim oStream Dim sData Dim aData Set oStream = oFSO.OpenTextFile( INPUT_FILE ) oStream.SkipLine Do While oStream.AtEndOfStream = False sData = oStream.ReadLine aData = Split( sData, "," ) For i = 0 To UBound( aData ) Execute aVars( i ) & " = " & Chr( 34 ) & aData( i ) & Chr( 34 ) Next 'At this point all the vars referred to in aVars have the values 'of the current record WSCript.Echo FirstName, LastName Loop oStream.Close And here's the results of the run, taken from SciTE's output window ANGELA DALTON BILLY CONNELLY CHARLEY LE CHOCOLATE FACTORIE DANIEL INT LIONSDEN EDWINA SMITH FREDERICK L'KING A possible extra step would be to read the header line, strips the spaces, build the "Dim" statements and execute them as well. Or maybe, create an instance of "Scripting.Dictionary" and use that. Or ... well, there must be more than two ways to do it, even in VBScript!

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