[VBScript] Configure

Below is retake on the Include subroutine which heads up the vast majority of my scripts. This incarnation puts a wrapper around Include and is called, for want of a better word, Configure. This subroutine takes no parameters at all. Rather, it builds up a filename based on WScript.ScriptFullName with ".cfg" tagged on, reads it in and then hands it over to ExecuteGlobal. This means that the .cfg file must contain functioning VBScript code.

Provided the .cfg sits side-by-side with the .vbs, the .vbs should work. And if you change locations, change the .cfg code. If the .cfg can't be found, you get an error message. I haven't put in any error trapping yet.

Had fun with "With"/"End With" on this one.

So in the .vbs we have

Sub Configure With CreateObject("Scripting.FileSystemObject") With .OpenTextFile(WScript.ScriptFullName & ".cfg") ExecuteGlobal .ReadAll End With End With End Sub Configure

and in the .cfg we have (for example)

MsgBox "Hello from " & WScript.ScriptFullName

[Observation] freshmeat, no. CodePlex, yes?

Seems that freshmeat don't want Windows-only projects. So it may be CodePlex you'll find the project on. More details when they come to hand.

[Delphi] COM of libiconv

I have just finished my first serious bit of Delphi programming, using Turbo Delphi Explorer. As a RAD/IDE it's pretty good. However, given the limitations of the Explorer version, I'll upgrade to the Pro version fairly soon.

COMlibiconv is an in-process COM object and was born out of the company's need to convert some multibyte encodings into Unicode. It's based on DIConverters, a unit made available by Ralf Junker of The Delphi Inspiration. DIConverters is licensed as LGPL. COMlibiconv will also be LGPL.

(Did I mention that I'm working again? No? Okay, well now I work as a software engineer for Strapper Technologies, of Fremantle, WA, Australia, makers of the Protium language.)

I'll be posting version 1.0 of the project up on Freshmeat by the end of next week, God willing.

COMlibiconv appears to work. I've used it in VBScript, late-bound, as

Set o = CreateObject( "Comlibiconv.Converters" )

and I think my boss has used it, early-bound, in VB6.

At this stage the methods and properties exposed are as follows (taken from the source):

type TConverters = class(TAutoObject, IConverters) protected function iconv_toUnicode(const sEncoding, inString: WideString; startingAt, finishingAfter: Integer): OleVariant; safecall; function Get_ErrorCode: Integer; safecall; function Get_Success: WordBool; safecall; function Aliases(nIndex: Integer): OleVariant; safecall; function Get_Count: Integer; safecall; function CNames(nIndex: Integer): OleVariant; safecall; end;

The function iconv_toUnicode takes a string defining the name of the multibyte encoding, the string to be converted, and two integers stating where to start and when to finish. I should probably give those default values so that the method can be called with just the encoding and the string.

ErrorCode contains an integer value which, when Success is false, represents what went wrong. An enumeration of possible error values is indicated and may make it into the next version.

Aliases gives all the various names for an encoding, indexed by a number from zero to the number of encodings (which can be found using Count).

CNames is also indexed in a similar way, and returns what I have called the 'CName' of the encoding. It's stuff that was in the DIConverters unit. I haven't found a use for it, but included it anyway.

The next version will, God willing, contain a method to allow conversions from Unicode back to multibyte.

If you're interested in this, and it hasn't appeared on Freshmeat by 18th November 2006, write a comment to remind me.

© Copyright Bruce M. Axtens, 2006

[Observations] Microsoft Changes Attitude Toward FOSS?

After years of looking on FOSS as a disease, Microsoft have started talking with, and indeed collaborating with, the FOSS commmunity. For some the change is too unreal, with many taking a cynical, unbelieving attitude. For others, it's a godsend.

Check out Port 25's posting about a recent cooperation between Microsoft and Mozilla, titled Why I invited Mozilla

Then, if you have the time and bandwidth, there's a 1 hour video interview with Bill Hilf of the Open Source Software Lab at Microsoft

It seems almost too good to be true. What do you think?

[Observations] Wardriving

Last night I went war ... er ... bussing. From part way through the 879's route as far as the stop nearest home, there must have been over 30 hot spots. At least three weren't encrypted, and "offered" subnets to the passerby.

I'm on an 879 again this morning (2006-09-07, Thursday, after 09:00.) We haven't gone three kilometres yet and already NetStumbler has a list of over 50 hits. About half have WEP and the rest don't. And again about 1 in 10 of the total are open to the public.

Pardon my naivety, but is this the usual state of affairs?

It introduces an interesting ethical issue: no one can stop you stealing another's bandwidth if they don't take steps to protect it. It seems that you can sit in a tree outside their front gate, downloading to your heart's content and they wouldn't know it, until their ISP bills them for exceeding their download allowance, or they ring the ISP to ask why they've been shaped only to be told that one day last week they downloaded 5G of something or other.

NetStumbler's own help file says, under the heading "Wardriving", "... To avoid using the networks that you observe, go to the Network Control Panel and unbind TCP/IP from your wireless LAN card." (Inevitably?) ethics aren't mentioned.

[Later, 09:30] On the way into the Busport (inner city Perth) the list expanded rather dramatically. Some of the SSID's are more meaningful: PCEC_Dimension_Data and BHPB_NiW_Avaya_Voip, for instance. The name "metromesh" keeps coming up ... eight times so far. I wonder what that's all about?

Waiting for a 36 to take me to Midland. May start cycling there next week ... only about 30 kilometres each way.

Now working for Strapper Technologies. More about that later.

[VBScript] StandardLibrary.zip

As promised in the previous posting, Standard Library is now available as a ZIP. Thanks to Perth Linux Users Group for the storage space.

[VBScript] Standard Library

My apologies for the hiatus between entries. I have been struggling with the "black dog."

Recently, I was asked to make the Standard Library available, so here it it. For ease of digestion, I have segmented it, though you will find that some functions make use of routines in other segments. I will in due course make the whole file available in a single ZIP. Until then, you'll have to navigate as best you can.

Cheers, comments, creative criticism and corrections all gratefully received. It's been a few months since I last used the library; you may find the odd rough edge. (I have edited the file a little for publication, but only to remove references to previous employers' sites, and a few redundant comments.)

As knife manufacturers have no way of controlling how people use their knives, so I have no control over where and how you use the code on this weblog. I have tried as much as possible to acknowledge my sources. I would appreciate it if you also would do the same.

Okay, with that out of the way, let's begin.

I have adopted an Hungarian variable naming regime that is a bit different to the usual given in VBScript examples from Microsoft. Objects start with "o", collections with "c", strings with "s", numbers with "n", booleans with "b", dates with "d", arrays with "a", and variants with "v". I must confess, however, that I have not always followed my own standards.

First, a few symbols and standard objects.

'StandardLibrary.vbs

'based on original DLI_Lib.vbs 2005-12-12 Bruce M. Axtens v0.1

'***** SYMBOLS
Dim oFSO
Set oFSO = CreateObject( "Scripting.FileSystemobject" )

Dim oShell
Set oShell = CreateObject( "WScript.Shell" )

Dim oAppShell
Set oAppShell = CreateObject( "Shell.Application" )

Dim oDict
Set oDict = CreateObject( "Scripting.Dictionary" )

Dim oNetwork
Set oNetwork = CreateObject("WScript.Network")

Dim oProcess
Set oProcess = oShell.Environment( "PROCESS" )

Dim oVolatile
Set oVolatile = oShell.Environment("VOLATILE")

Dim oDSE
Set oDSE = GetObject( "LDAP://rootDSE" )

Dim oWMI

Const WF_APPEND = 1
Const WF_CREATE = 2

Const WF_FOR_APPENDING = 8
Const WF_FOR_WRITING = 2
Const WF_CREATE_NONEXISTING = True

Const adOpenForwardOnly = 0
Const adOpenStatic = 3
Const adLockOptimistic = 3

Next a symbol table class, similar to that used in CLIVE.

'***** CLASSES
Class Syms
    Private oVar

    Private Sub Class_Initialize()
        Set oVar = CreateObject( "Scripting.Dictionary" )
    End Sub

    Private Sub Class_Terminate()
        Dim i
        Set oVar = Nothing
    End Sub

    Public Sub Store( sName, vStuff )
        If oVar.Exists( sName ) = True Then
            oVar( sName ) = vStuff
        Else
            oVar.Add sName, vStuff
        End If
    End Sub

    Public Function Recall( sName )
        Dim vResult
        Dim vTemp

        If oVar.Exists( sName ) = True Then
            vResult = oVar( sName )
        Else
            vResult = Null
        End If
        Recall = vResult
    End Function

    Public Sub ClearList( aList )
        Dim i
        For i = 0 To UBound( aList )
            Store aList( i ), vbNullString
        Next
    End Sub

    Public Function SymTab()
        Dim aList
        Dim i
        Dim aKeys
        Dim aItems

        aKeys = oVar.Keys
        aItems = oVar.Items

        ReDim aList( oVar.Count - 1 )
        For i = 0 To oVar.Count - 1
            aList( i ) = aKeys( i ) & "=" & aItems( i )
        Next
        SymTab = Join( aList, vbNewLine )
    End Function

End Class

Next, String manipulation tools. There are lots of things in here: LeftOf, RightOf, CountFields, NthField, BeginsWith, EndsWith, Contains, ForceExtension, Subst, Subst2, DQ, Between, Wrap (which puts HTML markup around text), RemoveSpaces, Zerofill2, RightFill, and LeftFill.

'***** DATA MANIPULATION - STRING
Function LeftOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = Instr( sText, sItem )
    IF nPos >0 Then
        sResult = Left( sText, nPos -1 )
    End If
    LeftOf = sResult
End Function

Function RightOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = Instr( sText, sItem )
    IF nPos >0 Then
        sResult = Mid( sText, nPos + Len( sItem ) )
    End If
    RightOf = sResult
End Function

Function CountFields( strText, strDelim  )
    Dim nOffset, nFoundAt
    Dim nCounter

    nCounter = 1
    nOffset = 1

    Do
        nFoundAt = Instr( nOffset, strText, strDelim )
        If nFoundAt > 0 Then
                nCounter = nCounter + 1
                nOffset = nFoundAt + Len( strDelim )
        Else
            Exit Do
        End If
    Loop

    CountFields = nCounter
End Function

Function NthField( sText, sDelimiter, nReqdField )
    Dim nOffset, nFoundAt
    Dim nCounter
    Dim vResult

    nCounter = 1
    nOffset = 1
    vResult = -1
    If nReqdField >= 1 Then

        Do
            nFoundAt = Instr( nOffset, sText, sDelimiter )
            If nFoundAt > 0 Then
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset, nFoundAt - nOffset )
                    Exit Do
                Else
                    nCounter = nCounter + 1
                    nOffset = nFoundAt + Len( sDelimiter )
                End If
            Else
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset )
                End If
                Exit Do
            End If
        Loop
    End If
    NthField = vResult
End Function

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

Function EndsWith( sText, sEnding, bCaseInsensitive )
    Dim bResult

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

    EndsWith = bResult
End Function

Function Contains( sText, sChunk, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sChunk = VBNullString Then
        bResult = True
    Else
        If sText <> VBNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Instr( UCase( sText ), UCase( sChunk ) ) > 0 )
            Else
                bResult = ( Instr( sText, sChunk ) > 0 )
            End If
        End If
    End If

    Contains = bResult
End Function

Function ForceExtension( ByVal sFilename, ByVal sFileExtension )
    Dim sResult
    Dim nDotPos

    nDotPos = InStrRev( sFilename, "." )
    If nDotPos = 0 Then
        sResult = sFilename & sFileExtension
    Else
        sResult = Left( sFilename, nDotPos - 1 ) & sFileExtension
    End If
    ForceExtension = sResult
End Function

Function Subst( sText, aArgList )
    Dim sResult
    Dim sTemp
    Dim i

    sResult = sText

    For i = 0 To UBound( aArgList )
        sTemp = aArgList( i )
        If IsNull( sTemp ) Then
            sTemp = ""
        End If
        sResult = Replace( sResult, "[" & CStr( i + 1 ) & "]" , sTemp )
    Next

    Subst = sResult
End Function

Function Subst2( sText, aArgList )
    Dim sResult
    Dim i

    sResult = sText

    For i = 0 To UBound( aArgList )
        sResult = Replace( sResult, "[" & CStr( i + 1 ) & "]" , aArgList( i ) )
    Next

    sResult = Replace( sResult, "\n", vbNewLine )
    sResult = Replace( sResult, "\t", vbTab )

    Subst2 = sResult
End Function

Function DQ( s )
    DQ = Chr(34) & s & Chr(34)
End Function

Function Between( sText, sBegin, sEnd )
    Dim nBegin
    Dim nEnd

    nBegin = Instr( sText, sBegin )
    'no error checking yet
    nEnd = Instr( nBegin + Len( sBegin ), sText, sEnd )
    Between = Mid( sText, nBegin + Len( sBegin ), nEnd - nBegin - 1 )
End Function

Function Wrap( sTag, sContent )
    Dim aFirst
    aFirst = Split( sTag, " ", 2 )
    Log "{" & Join( aFirst, "," ) & "}"
    Wrap = "<" & sTag & ">" & sContent & "</" & aFirst( 0 ) & ">"
End Function

Function RemoveSpaces( sText )
    Dim sResult
    Dim s
    Dim i

    sResult = ""
    For i = 1 To Len( sText )
        s = Mid( sText, i, 1 )
        If s <> " " Then
            sResult = sResult & s
        End If
    Next
    RemoveSpaces = sResult
End Function

Function Zerofill2( nNum )
    Zerofill2 = Right( "00" & nNum, 2 )
End Function

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

Function LeftFill( sText, nLen, sFill )
    LeftFill = Right( String( nLen, sFill ) & sText, nLen )
End Function

The one date manipulation function came out of a problem with encoding dates in Access. See the link for a fuller description.

'***** DATA MANIPULATION - DATE
Function dbDate(dDate)
    '~ http://www.aspfaq.com/show.asp?id=2260
    dbDate = year(dDate) & "-" & _
             zerofill2( month(dDate) ) & "-" & _
             zerofill2( day(dDate) ) & " " & _
             zerofill2( hour( dDate ) ) & ":" & _
             zerofill2( minute( dDate ) ) & ":" & _
             zerofill2( second( dDate ) )
End Function

Arrays: AAdd, InArray, StrInArray, AMax and Amin.

'***** DATA MANIPULATION - ARRAY
Function AAdd( ByRef aToThis, ByVal xAddThis )
    Dim nPos
    nPos = UBound( aToThis ) + 1
    ReDim Preserve aToThis( nPos )
    aToThis( nPos ) = xAddThis
    AAdd = nPos
End Function

Function InArray( sItem, aList )
    Dim i
    Dim u
    Dim bResult
    bResult = False
    u = UBound( aList )
    For i = 0 To u
        If sItem = aList( i ) Then
            bResult = True
            Exit For
        End If
    Next
    InArray = bResult
End Function

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

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

File manipulation code: CollectFiles, ReadFile, ReadFirstLine, Exists, WriteFile, Env and IncludeClass. Essentially wrappers around existing functionality, but with more flavour.

'***** DATA MANIPULATION - FILES
Function CollectFiles( sDirectory, sFileType )
    Dim aResult
    Dim oFolder
    Dim cItems
    Dim i
    Dim sItem
    Dim nCount

    aResult = Array()
    Set oFolder = oAppShell.Namespace(sDirectory)
    'On Error Resume Next
    Set cItems = oFolder.Items
    If Err.Number = 0 Then
        ReDim aResult( cItems.Count - 1 )
        nCount = 0
        For i = 0 To cItems.Count - 1
            sItem = cItems.Item( i )
            If EndsWith( sItem, sFileType, False ) Then
                aResult( nCount ) = sItem
                nCount = nCount + 1
            End If
        Next
    End If
    ReDim Preserve aResult( nCount - 1 )
    CollectFiles = aResult
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 ReadFirstLine( FileName )
    Dim oStream
    Dim sData

    sData = VBNullString

    Set oStream = oFSO.OpenTextFile(FileName)
    sData = oStream.ReadLine
    oStream.Close

    ReadFirstLine = sData
End Function

Function Exists( sFile )
    Exists = oFSO.FileExists( sFile )
End Function

Sub WriteFile( 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 Env( strEnvVar )
    Dim oProcessEnvironment
    Dim sResult
    With CreateObject( "WScript.Shell" )
        Env = .Environment( "PROCESS" )( UCase( strEnvVar ) )
    End With
End Function

Sub IncludeClass( 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

How do you classify the "mexican if"?

'***** DATA MANIPULATION - OTHER
Function IIF( bCondition, vTrue, vFalse )
    Dim vResult
    If bCondition = True Then
        vResult = vTrue
    Else
        vResult = vFalse
    End If
    IIF = vResult
End Function

Now we get into some serious Active Directory (AD) and Windows Management Interface (WMI) code. As much as possible I've included the relevant attributions for stuff I have lifted and/or adapted.

First, domain access: GetAvailableNTDomains

'***** DOMAINS
'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'----------------------------------------------------------------
' Function:     GetAvailableNTDomains
' Description:  Returns a listing of available NT Domains
' Parameters:   None
' Returns:      Variant array of NT Domain names.
'----------------------------------------------------------------
Public Function GetAvailableNTDomains()
  Dim objIADsContainer      ' ActiveDs.IADsContainer
  Dim objIADsDomain         ' ActiveDs.IADsDomain
  Dim vReturn               ' Variant

  ReDim vReturn(0)

  Set objIADsContainer = GetObject("WinNT:")
  For Each objIADsDomain In objIADsContainer
    If Trim(vReturn(0)) <> "" Then
      ReDim Preserve vReturn(UBound(vReturn) + 1)
    End If
    vReturn(UBound(vReturn)) = objIADsDomain.Name
  Next

  Set objIADsDomain = Nothing
  Set objIADsContainer = Nothing
  GetAvailableNTDomains = vReturn
End Function

Then computers: GetRemoteEnvironment, GetOnlineComputers, GetNetView, GetComputers, GetNBT, GetNBTA, GetDomainComputers, GetSpecs, ResolveIP, DetectTempFolder, and ExistsFolder.

'***** COMPUTERS
Function GetRemoteEnvironment( sComputer )
    Dim aResult
    Dim oWMI
    Dim cVars
    Dim oVar

    aResult = Array()

    Set oWMI = GetObject( "winmgmts:\\" & sComputer & "\root\cimv2")
    Set cVars = oWMI.ExecQuery( "Select * from Win32_Environment")
    For Each oVar in cVars
        AAdd aResult, oVar.SystemVariable & "^" & oVar.Name & "^" & oVar.VariableValue & "^" & oVar.Description & "^" & oVar.UserName
    Next
    GetRemoteEnvironment = aResult
End Function

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 GetComputers( sDomain )
    Dim oController
    Dim nCount
    Dim oComputer
    Dim aResult
    ReDim aResult( 5000 )

    Set oController = GetObject( "WinNT://" & sDomain )
    oController.Filter = Array( "Computer" )

    nCount = 0
    For Each oComputer In oController
        aResult( nCount ) = oComputer.Name
        nCount = nCount + 1
    Next
    ReDim Preserve aResult( nCount - 1 )
    GetComputers = aResult
End Function

Function GetNBT( sComputer )
    Dim sText
    Dim aText
    Dim i
    Dim sTemp
    Dim n
    Dim sResult

    sResult = ""

    sText = CaptureDOS( "%COMSPEC% /c nbtstat -a " & sComputer, True )
    aText = Split( sText, vbNewLine )

    If Instr( aText( 4 ), "Host not found." ) = 0 Then
        n = 0
        For i = 0 To UBound( aText )
            sTemp = Replace( RTrim( LTrim( aText( i ) ) ), vbCR, "" )
            aText( i ) = sTemp
        Next

        Dim sIP
        Dim sLine
        Dim sMac

        sIP = Between( aText( 2 ), "[", "]" )

        n = 7
        Do While True
            If Len( aText( n ) ) = 0 Then
                Exit Do
            End If
            sLine = aText( n )
            n = n + 1
        Loop

        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )

        sMac = Split( aText( n + 1 ), " = ")( 1 )
        sResult = sIP & "^" & sMac & "^" & Split( sLine, " " )( 0 )
    End If
    GetNBT = sResult
End Function

Function GetNBTA( sIPAddr )
    Dim sText
    Dim aText
    Dim i
    Dim sTemp
    Dim n
    Dim sResult

    sResult = ""

    sText = CaptureDOS( "%COMSPEC% /c nbtstat -A " & sIPAddr, True )
    aText = Split( sText, vbNewLine )

    If Instr( aText( 4 ), "Host not found." ) = 0 Then
        n = 0
        For i = 0 To UBound( aText )
            sTemp = Replace( RTrim( LTrim( aText( i ) ) ), vbCR, "" )
            aText( i ) = sTemp
        Next

        Dim sIP
        Dim sLine
        Dim sMac

        sIP = Between( aText( 2 ), "[", "]" )

        n = 7
        Do While True
            If Len( aText( n ) ) = 0 Then
                Exit Do
            End If
            sLine = aText( n )
            n = n + 1
        Loop

        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )

        sMac = Split( aText( n + 1 ), " = ")( 1 )
        sResult = sIP & "^" & sMac & "^" & Split( sLine, " " )( 0 )
    End If
    GetNBTA = sResult
End Function

'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 GetSpecs( sComputer )
    Dim cItems
    Dim sQuery
    Dim oItem
    Dim sResult

    sResult = ""

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\CIMV2")
    If Err.Number = 0 Then
        sQuery = "SELECT Manufacturer, Model, Name, SystemType, TotalPhysicalMemory, DomainRole FROM Win32_ComputerSystem"
        Set cItems = oWMI.ExecQuery( sQuery )
        For Each oItem in cItems
            With oItem
                sResult =                 Trim( .Manfacturer )
                sResult = sResult & "^" & Trim( .Model )
                sResult = sResult & "^" & Trim( .Name )
                sResult = sResult & "^" & Trim( .SystemType )
                sResult = sResult & "^" & Trim( Int( ( ( .TotalPhysicalMemory ) / 1024 ) / 1024 ) ) & " MB"

                Select Case .DomainRole
                    Case 0
                        sResult = sResult & "^" & "Standalone Workstation"
                    Case 1
                        sResult = sResult & "^" & "Member Workstation"
                    Case 2
                        sResult = sResult & "^" & "Standalone Server"
                    Case 3
                        sResult = sResult & "^" & "Member Server"
                    Case 4
                        sResult = sResult & "^" & "Backup Domain Controller"
                    Case 5
                        sResult = sResult & "^" & "Primary Domain Controller"
                End Select
            End With
        Next
        Err.Clear
        On Error GoTo 0
    End If
    GetSpecs = sResult
End Function

Function ResolveIP( sName )
    Dim sHost
    Dim sTarget
    Dim cPingResults
    Dim oPingResult
    Dim sResult

    sResult = vbNullString
    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

Function DetectTempFolder( sDir )
    Dim sTemp1
    Dim sTemp2
    Dim sResult

    sTemp1 = "c:\Windows\Temp"
    sTemp2 = "c:\TEMP"
    sResult = vbNullString

    If ExistsFolder( V.Recall( "COMPUTERNAME" ), sTemp1 ) Then
        sResult = "\\" & V.Recall( "COMPUTERNAME" ) & Replace( sTemp1, "c:\", "\C$\" )
    ElseIf ExistsFolder( V.Recall( "COMPUTERNAME" ), sTemp2 ) Then
        sResult = "\\" & V.Recall( "COMPUTERNAME" ) & Replace( sTemp2, "c:\", "\C$\" )
    Else
        '
    End If
    DetectTempFolder = sResult

End Function

Function ExistsFolder( sComputer, sDir )
    Dim oWMI
    Dim cFiles
    Dim oFile
    Dim sUNC

    sUNC = Replace( sDir, "\", "\\" )

    Set oWMI = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")

    Set cFiles = oWMI.ExecQuery _
        ("Select * from CIM_Directory Where name = '" & sUNC & "'")

    ExistsFolder = cFiles.Count > 0
End Function

Also user-specific tools: GetOUofUser, GetLoginProfiles, GetMac, GetComputerUsers, GetComputerUsers2, GetDomainUser, and GetNameAndDescription.

'***** USERS
Function GetOUofUser( sDomain, sUsername )
    Dim sResult
    sResult = vbNullString

    On Error Resume Next

    Const ADS_SCOPE_SUBTREE = 2

    Set oConnection = CreateObject("ADODB.Connection")
    Set oCommand =   CreateObject("ADODB.Command")
    oConnection.Provider = "ADsDSOObject"
    oConnection.Open "Active Directory Provider"
    Set oCommand.ActiveConnection = oConnection

    oCommand.Properties("Page Size") = 1000
    oCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

    oCommand.CommandText = _
        "SELECT distinguishedName FROM 'LDAP://" & sDomain & "' WHERE objectCategory='user' " & _
            "AND sAMAccountName='" & sUsername & "'"
    Set oRecordSet = oCommand.Execute

    oRecordSet.MoveFirst
    Do Until oRecordSet.EOF
        sResult = oRecordSet.Fields("distinguishedName").Value
        oRecordSet.MoveNext
    Loop

    Set oRecordSet = Nothing
    Set oCommand = Nothing
    Set oConnection = Nothing

    GetOUofUser = sResult
End Function

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 * 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 GetMac( sDevice )
    Dim cItems
    Dim oItem
    Dim sResult

    sResult = vbNullString

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sDevice & "\root\cimv2")
    If Err.Number = 0 Then
        Set cItems = oWMI.ExecQuery( "Select * from Win32_NetworkAdapterConfiguration" )
        For Each oItem in cItems
            sResult = sResult &  oItem.Caption & "~" & oItem.MACAddress & "^"
        Next

        sResult = Mid( sResult, 1, Len( sResult ) - 1 )
    End If
    Err.Clear
    On Error Goto 0

    GetMac = sResult
End Function

'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'----------------------------------------------------------------
' Function:     GetComputerUsers
' Description:  This function will return the names of the users
'                 for a specified computer or domain
' Parameters:   ByVal strComputerName - Name of an NT Computer or
'                 domain to retrieve the list of Users from.
' Returns:      Variant array of user account for the specified
'           computer
'----------------------------------------------------------------
Function GetComputerUsers(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsUser           'As ActiveDs.IADsUser
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' Connect to the computer or domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' apply a filter to retrieve only objects of class User
   objIADsContainer.Filter = Array("User")

   ' iterate all user objects within the container
   For Each objIADsUser In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsUser.Name
   Next

   Set objIADsUser = Nothing
   Set objIADsContainer = Nothing
   GetComputerUsers = vReturn
End Function

Function GetComputerUsers2(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsUser           'As ActiveDs.IADsUser
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' Connect to the computer or domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' apply a filter to retrieve only objects of class User
   objIADsContainer.Filter = Array("User")

   ' iterate all user objects within the container
   For Each objIADsUser In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsUser.Name & "^" & objIADsUser.FullName
   Next

   Set objIADsUser = Nothing
   Set objIADsContainer = Nothing
   GetComputerUsers2 = vReturn
End Function

Function GetDomainUser( sComputer )
    Dim cProc
    Dim oProcess
    Dim sUser, sDomain
    Dim sResult

    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 GetNameAndDescription( spDomain, sUsername )
    Dim sDomain
    Dim oIADSUser
    Dim sResult

    sResult = vbNullString

    If IsEmpty( spDomain ) Then
        sDomain = oNetWork.UserDomain
    Else
        sDomain = spDomain
    End If

    If Len( sUsername ) > 0 Then
        On Error Resume Next
        Set oIADSUser = GetObject( Subst( "WinNT://[1]/[2],user", Array( sDomain, sUsername ) ) )
        If Err.number = 0 Then
            sResult = oIADSUser.FullName & "^" & oIADSUser.Description
            Set oIADSUser = Nothing
        End If
        Err.Clear
        On Error Goto 0

    End If

    GetNameAndDescription = sResult
End Function

I didn't use them often, but there are function here for Group access as well: GetComputerGroups and GetGroups.

'***** GROUPS
'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'---------------------------------------------------------------
' Function:     GetComputerGroups
' Description:  This function will return the names of
'                 the NT Groups for a specified computer.
' Parameters:   ByVal strComputerName - Name of an NT
'                 Computer or Domain to retrieve the list of
'           Groups from.
' Returns:      Variant array of NT Groups for the specified
'           computer
'----------------------------------------------------------------
Public Function GetComputerGroups(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsGroup          'As ActiveDs.IADsGroup
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' connect to the computer or Domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' Set the filter on the container to retrieve only
   ' objects of Class Group
   objIADsContainer.Filter = Array("Group")

   ' iterate through each group object in the container
   For Each objIADsGroup In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsGroup.Name
   Next

   Set objIADsGroup = Nothing
   Set objIADsContainer = Nothing
   GetComputerGroups = vReturn
End Function

Function GetGroups()
    Dim objRecordSet
    Dim objCommand
    Dim objConnection
    Dim i
    Dim aList
    ReDim aList( 10000 )
    On Error Resume Next

    Const ADS_SCOPE_SUBTREE = 2

    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection

    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

    objCommand.CommandText = _
        "SELECT cn, name, ADsPath, description FROM 'LDAP://" & GetDefaultNamingContext() & "' WHERE " _
            & "objectCategory='group'"
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    i = 0
    Do Until objRecordSet.EOF
        aList( i ) = objRecordSet.Fields("cn").Value & "^" & objRecordSet.Fields("ADsPath").Value
        objRecordSet.MoveNext
        i = i + 1
    Loop

    Set objRecordSet = Nothing
    Set objcommand = Nothing
    Set objConnection = Nothing


    ReDim Preserve aList( i - 1 )
    GetGroups = aList
End Function

Okay, now we get onto the application control routines, starting with Excel: ExcelStart, ExcelNewSheet and ExcelColumnNames.

'***** SPREADSHEET
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

Sub ExcelColumnNames( aHeadings )
    Dim i
    For i = 0 To UBound( aHeadings )
        oSheet.Cells( 1, i + 1 ).Value = aHeadings( i )
        oSheet.Cells( 1, i + 1 ).Font.Bold = True
    Next
End Sub

Then, Access routines: CreateDatabase, OpenDatabase, OpenRecordSet, CreateStructure and CreateIndex.

'***** DATABASE
Sub CreateDatabase( sFile )
    Dim oCatalog

    Set oCatalog = CreateObject( "ADOX.Catalog" )
    oCatalog.Create( "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Jet OLEDB:Engine Type=5;Data Source=" & sFile)

    Set oCatalog = Nothing
End Sub

function OpenDatabase( theFile )
    Dim oConnection
    On Error Resume Next
    Set oConnection = CreateObject( "ADODB.Connection" )
    oConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & theFile
    If Err.Number <> 0 Then
        Die "OpenDatabase", Err
    End If
    Err.Clear
    On Error GoTo 0
    Set OpenDatabase = oConnection
end function

Function OpenRecordSet( ByRef oDB, sQuery )
    Dim oRecordSet
    Set oRecordSet = CreateObject( "ADODB.RecordSet" )
    oRecordSet.Open sQuery, oDB, adOpenStatic, adLockOptimistic
    Set OpenRecordSet = oRecordSet
End Function

Sub CreateStructure( oDb, sSpec )
    On Error Resume Next
    oDb.Execute sSpec
    If Err.Number <> 0 Then
        Die "CreateStructure error", Err
    End If
End Sub

Sub CreateIndex( oDb, sSpec )
    On Error Resume Next
    oDb.Execute sSpec
    If Err.Number <> 0 Then
        Die "CreateIndex error", Err
    End If
End Sub

One lonely email-specific tool: ErrorEmail.

'***** EMAIL
Sub ErrorEmail( sTo, sSubj, sText )
    sTo = Escape(   sTo )
    sSubj= Escape(  sSubj )
    sText = Escape( sText )
    sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    oShell.Run sCmd
End Sub

Internet Explorer tools: ModalDialog, ModalText, ModalThing, ReadClipboard, WriteClipboard.

'***** WEBBROWSER
Function ModalDialog( sOption )
    Dim sHTML
    Dim sContainer
    Dim sFolder
    Dim sName

    sContainer = "<SELECT name=selID id=selID>[1]</SELECT><input type='submit' Value='Choose' onclick=subSet>"
    sHTML = Wrap( "HEAD", Wrap( "TITLE", "Selection Dialog" ) )
    sHTML = sHTML & Wrap( "SCRIPT language='VBScript'", Replace( "\nSub subSet()\nwindow.ReturnValue = selID.Value\nwindow.close\nEnd Sub\n", "\n", vbNewLine ) )
    sHTML = sHTML & Wrap( "BODY", Wrap( "CENTER", "Select Name from List:&nbsp;" & "[1]" ) )
    sHTML = Wrap( "HTML", sHTML )
    Log sHTML

    sContainer = Subst( sContainer, Array( sOption ) )
    Log sContainer

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )
    Log sHTML

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:80px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )
    Log sTemp
    ModalDialog = sTemp
End Function

Sub ModalText( sText )
    Dim sHTML
    Dim sContainer
    Dim sFolder
    Dim sName


    sHTML = Wrap( "HEAD", Wrap( "TITLE", "Display Dialog" ) )
    sHTML = sHTML & Wrap( "SCRIPT language='VBScript'", Replace( "\nSub ClipCopy()\ndocument.parentwindow.clipboardData.SetData """", taStuff.Value\nEnd Sub\n", "\n", vbNewLine ) )
    sHTML = sHTML & Wrap( "BODY", Wrap( "CENTER", Wrap( "TEXTAREA id='taStuff' name='taStuff' rows='5' cols='55'", sText ) ) )
    'sHTML = sHTML & Wrap( "CENTER", "<input type='button' Value='Copy to Clipboard' onclick=ClipCopy>")
    sHTML = Wrap( "HTML", sHTML )

    Log sHTML

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )
    Log sHTML

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:120px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )
    Log sTemp

End Sub

Sub ModalThing( sTitle, sMarkup )
    Dim sHTML
    Dim sFolder
    Dim sName


    sHTML = Wrap( "HEAD", _
                Wrap( "TITLE", _
                    sTitle _
                    ) _
                )

    sHTML = sHTML & Wrap( "BODY", sMarkup )
    sHTML = Wrap( "HTML", sHTML )

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:245px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )

End Sub

function ReadClipboard
' Reads Clipboard into a variable
' by Christoph Basedau, http://dev.remotenetworktechnology.com/wsh/rubegoldberg.htm
' modified by Bruce M. Axtens to read clipboard rather than write to it
    with createobject("internetexplorer.application")
        .navigate "about:blank"
        ReadClipboard = .document.parentwindow.clipboardData.getData ("text")
        .quit
    end with
end function

Sub WriteClipboard( sText )
' Reads Clipboard into a variable
' by Christoph Basedau, http://dev.remotenetworktechnology.com/wsh/rubegoldberg.htm
    with createobject("internetexplorer.application")
        .navigate "about:blank"
        .document.parentwindow.clipboardData.setData "text", sText
        .quit
    end with
end Sub

An LDAP function: GetDefaultNamingContext

'***** LDAP
Function GetDefaultNamingContext()
    GetDefaultNamingContext = oDSE.Get( "defaultNamingContext" )
End Function

A function, CaptureDOS. It runs a command in the CMD shell, captures the output to a text file, and then sucks the data into a string variable.

'***** DOS
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

Logging variables and functions: LogTo, Log, Die and Faint.

'***** LOGGING
Dim bIsLogging
Dim oLogStream
Dim bLog

Dim sLogFilename

bIsLogging = False
bLog = False

Sub LogTo( sFile )
    sLogFilename = sFile
End Sub

Sub Log( sMsg )
    Const STR_LOG_EXT = ".log"

   Dim sFilename
   Dim sLogname

    If IsEmpty( sLogFilename ) Then
        sFilename = "Scripting.log"
    Else
        sFilename = sLogFilename
    End If

    sLogname = ForceExtension( sFilename, STR_LOG_EXT )


    If bIsLogging = False Then
        If bLog = True Then
            'On Error Resume Next
            Set oLogStream = oFSO.OpenTextFile( sLogname, WF_FOR_APPENDING, True ) 
            If Err.Number <> 0 Then
                MsgBox Err.Description
            End If
            Err.Clear
            On Error Goto 0
            bIsLogging = True
        End If
    End If


    If bIsLogging = True Then oLogStream.WriteLine sMsg

End Sub

Sub Die( sPlace, oErr )
    Dim sMsg
    bLog = True
    LogTo WScript.ScriptFullName
    sMsg =  sPlace & "|" & oErr.Number & "|" & oErr.Source & "|" & oErr.Description
    Log sMsg
    MsgBox sMsg
    WScript.Echo sMsg
    WScript.Quit
End Sub

Sub Faint( sPlace, oErr )
    Dim sMsg
    bLog = True
    LogTo WScript.ScriptFullName
    sMsg =  sPlace & "|" & oErr.Number & "|" & oErr.Source & "|" & oErr.Description
    Log sMsg
    WScript.Quit
End Sub

Next comes a testing module which is only executed if the library itself is executed directly. For example:
    CSCRIPT StandardLibrary.vbs

Anything goes in this section, and the stuff below is what was in there the last time I tested the file, which was sometime in January 2006.

'***** TESTING
Dim sTemp
Dim aTemp
Dim sPC
Dim aComputers
Dim aDomains
Dim j
Dim vars

Dim aReport
ReDim aReport( 0 )

sPC = "PC00001"
If WScript.ScriptName = "StandardLibrary.vbs" Then
    WScript.Echo LeftOf( "my\\dog", "\\" )
    WScript.Echo RightOf( "my\\dog", "\\" )
    WScript.Quit
    IncludeClass "C:\Script\StandardSymbols.vbs"
    aTemp = GetRemoteEnvironment( sPC )
    For i = 0 To UBound( aTemp )
        WScript.Echo aTemp( i )
    Next

    aTemp =  GetOnlineComputers( "DOMAIN" )
    For i = 0 To UBound( aTemp )
        aadd aReport, i & " " & aTemp(i)
    Next
    'WScript.Echo Join( aTemp, vbNewLine & vbTab )
    'WScript.Quit
    If InArray( "\\" & sPC, aTemp ) Then
        aadd aReport, sPC & " is online"
    End If
    '~ WScript.Quit
    aadd aReport, Join( GetComputerUsers( "DOMAIN" ), vbNewLine & vbTab )
    aadd aReport, "GetMac of " & sPC & ": "
    aadd aReport,  GetMac( sPC )

    aDomains = GetAvailableNTDomains()
    For j = 0 To UBound( aDomains )
        aComputers = GetComputers( aDomains( j ) )
        For i = 0 To UBound( aComputers )
            aadd aReport,  aDomains( j ) & " " & aComputers( i )
        Next
    Next
    'With WScript
        aadd aReport,  "Between [ and ] in 'my[foo]': " & Between( "my[foo]", "[", "]" )
        aadd aReport,  "defaultNamingContext: " & oDSE.Get( "defaultNamingContext" )
        sTemp = GetDomainUser( sPC )
        aadd aReport,  "GetDomainUser " & sPC & ": " & sTemp
        If Left( sTemp, 1 ) <> "<" Then
            aTemp = Split( sTemp, "\" )
            aadd aReport,  "GetNameAndDescription " & sTemp & ": " & GetNameAndDescription( aTemp(0), aTemp(1) )
        End If
        aadd aReport,  "GetLoginProfiles " & sPC & ": " & Join( Split( GetLoginProfiles( sPC ), "^" ), vbNewLine & vbTab )
        aadd aReport,  "GetNBT of " & sPC & ": " & GetNBT( sPC )
    'End With
    WScript.Echo Join( aReport, vbNewLine )
    ErrorEmail "dog@cat.com", "StandardLibary tests", Join( aReport, vbNewLine )
End If

Okay, that's the end of it.

I don't know when I'll be doing VBScript again; I have designed the Sudoku solver but haven't coded it yet. I had thought of doing it as an HTA.

At the moment I'm looking into the ISIS database technology (a friend has developed a Win32 Unicode-enabled version), serial i/o, FreeBASIC, and xbScript.

I hope to recommence regular postings soon, likely in support of a new language, Protium. Until then.

© Copyright Bruce M. Axtens, 2006

[News] Working again ...

... at Lion Nathan's Swan Brewery.

Thanks, by the way, to all the visitors who keep my stats at an average of 10 visits per week.

More code is in the works: a tcl archive exploder, and a Sudoku solver written as an HTA.

Don't hold your breath!

[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

[News] Looking for work ... again

Went and visited three new (to me) employment agencies today. Gryphon, Sinclair Knight Merz and Candle. I also went to the offices of the City of Perth and picked up a busking permit application. Do I have the guts to stand up and sing, a capella, in Murray St. Mall?

[News] Codeaholic/LL

That's it then ... 99.9% of the languages that were listed down the left hand side are now over on the Code-a-holic Language List.

Mate! I'm glad that's over.

[News] Today and Tomorrow

Today it was swapping hard drives; sharing receipt printer; finding, downloading, and failing to get working the old touch-screen software; telling all the other machines to use LPT6 when running the POS application, but making sure that the POS machine itself still uses LPT1 (using Clipper 5.3); and getting the floppy drive to work in the SERVER.

Today I celebrated by 45th birthday. One of the gifts I received was a PLUG membership. Eventually the ancient source codes promised but never delivered on Code-a-holic will find their way there.

Tomorrow is the first day (of about 1.5 weeks) at Home Open working on the help desk. More news, and code, as it comes to hand.

[News] End of Contract ... again

The Holy Grail, permanent work, remains elusive. I have good KSAs (Knowledge, Skills, Attitudes) but employers seem only interested in having me around for a few weeks ... maybe it's my deodorant / mouthwash / politics / religion ...

A couple of times it's been suggested I try out writing for a living. What do I live on in the meantime? Others have suggested getting a heavy-rigid licence and signing up to be a bus driver. That's tempting, and it may leave time to write. But it also means stepping into the twilight between an IT career and "something else."

So Monday it's climb back into the suit, catch the bus into town, and go door to door, employment agency to employment agency, saying, "Hey, remember me? I'm looking for a job (again.)"

[Languages] The Left-Hand List

The list of programming languages on the left-hand side is shrinking. That's A to E done. They've all been moved over to the language list on Code-a-holic/LL.
Over the next few weeks I'll be posting the rest of the data I have on those languages (the bare minimum of name, link, and description.) If anyone's interested in the metacard database or having an XML-ish file with all of the extra details (platform, users' group, date of last activity, etc.), please leave a comment.
Leave a comment too, if you can see anything that needs changing / updating.

[VBScript] CliVE - Command Language Interpreter VBScript Environment

A few years back ZATZ Publishing, in their DominoPower Magazine, published an article entitled Using Python to create a command line interpreter for Notes. Not being that au fait with Python I decided to have a go at doing the same thing in VBScript. CliVE is the result.

CliVE takes the basic CLI mechanism of my previous posting ([VBScript] CLI Framework) and adds a couple of extra bits: Loading, Saving, and a shorthand for 'WScript.Echo'

First the code supporting the standard header.

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"

Then support for putting script files on the commandline. Files specified on the command line are loaded and interpreted, one after the other.

Dim oArgs Set oArgs = WScript.Arguments.Unnamed Dim i If oArgs.Count > 0 Then For i = 0 to oArgs.Count - 1 LoadRun oArgs( i ) Next End If

This is the main interpreter loop.

The aSession array stores each line passed to Evaluate so that a given session's script can be stored.

In the main loop, a prompt is output and input received. The sLine is split into a two element list: the first element being the keyword; the second being all subsequent text.

There are a few keywords starting with a dot. These are peculiar to CliVE:

.quit

.exit

Synonyms for WScript.Quit

.echo

?

Synonyms for WScript.Echo. Unlike other dot commands, the line starting with this command is passed to the Evaluate function.

.save

Saves the contents of the aSession array to SaveClive.clive unless a filename is given as an argument.

.run

.load

Reads the filename given in the argument and executes the code therein by passing it to ExecuteGlobal.

.debug

An empty procedure. A place to put test code.

All other commands are treated as VBScript commands and are passed to the Evaluate subroutine.

Dim aSession Dim sLine Dim aLine Dim sKeyword Dim sArguments Dim sClip ReDim aSession( -1 ) Do While True WScript.StdOut.Write "cliVE> " sLine = WScript.StdIn.ReadLine aLine = Split( sLine, " ", 2 ) If UBound( aLine ) > -1 Then sKeyword = aLine( 0 ) If UBound( aLine ) > 0 Then sArguments = LTrim( RTrim( aLine( 1 ) ) ) Else sArguments = vbNullString End If Select Case LCase( sKeyword ) Case ".quit", ".exit" Exit Do Case ".echo", "?" Evaluate "WScript.Echo " & sArguments Case ".save" Save sArguments Case ".run", ".load" LoadRun sArguments Case ".debug" DoDebug Case Else Evaluate sLine End Select End If Loop

Evaluate, Save, LoadRun and Debug.

Note that the code for Evaluate traps errors, and displays an error message. Note also that LoadRun has no such protection. It's something one might want to add ASAP!

Note also the call to AAdd, which adds the evaluated command to the aSession array if the command works without error.

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 Else AAdd aSession, sArg End If On Error GoTo 0 End Sub Sub Save( sFilename ) Dim nMode If sFilename = vbNullString Then sFileName = "SaveClive.clive" nMode = WF_APPEND Else nMode = WF_CREATE End If WriteFile sFilename, Join( aSession, vbNewLine ), nMode End Sub Sub LoadRun( sFileName ) If sFileName <> vbNullString Then If Exists( sFileName ) Then ExecuteGlobal ReadFile( sFileName ) WScript.Echo sFilename & " evaluated without error" Else WScript.Echo sFileName & " not found" End If Else WScript.Echo "Please specify filename" End If End Sub Sub DoDebug End SUb

Rather than reproduce the entire StandardLibrary (1500+ lines), here are the referenced routines (AAdd, Exists, ReadFile, WriteFile), plus supporting symbols.

Function AAdd( ByRef aToThis, ByVal xAddThis ) Dim nPos nPos = UBound( aToThis ) + 1 ReDim Preserve aToThis( nPos ) aToThis( nPos ) = xAddThis AAdd = nPos End Function Dim oFSO Set oFSO = CreateObject( "Scripting.FileSystemobject" ) Function Exists( sFile ) Exists = oFSO.FileExists( sFile ) 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 Const WF_APPEND = 1 Const WF_CREATE = 2 Const WF_FOR_APPENDING = 8 Const WF_FOR_WRITING = 2 Const WF_CREATE_NONEXISTING = True Sub WriteFile( 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

[Community] Code-a-holic in print

TechTrax January 2006, from MouseTrax Computing Solutions.

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