Code-a-holic: StandardLibrary

Showing posts with label StandardLibrary. Show all posts

Thursday, May 14, 2009

[VB6]Searching an ActiveX/COM object for a method

This article was first posted by me on StackOverflow in response to my own question, "How do I search an ActiveX/COM object for a method?". This article is an edited version of the original.

"After Googling around not quite finding what I wanted, I remembered the Edanmo site which got me thinking about TLBINF32.DLL, downloading Microsoft's TLBINF32.CHM and reading up on GetMembersWithSubStringEx.

Below is the implementation of it (done in VB6 with a reference to TLBINF32.DLL), some demo VBScript and output, and the wrapping of that functionality in some VBA.

Public Function SearchTLIMethodsAndProperties(sTypelib As Variant, sSymbol As Variant) As Variant
    Dim SI As SearchItem
    Dim aResults As Variant
    Dim bFound as boolean
    Dim Groups(1) As InvokeKinds
    Groups(0) = INVOKE_FUNC Or INVOKE_PROPERTYGET Or _
     INVOKE_PROPERTYPUT Or INVOKE_PROPERTYPUTREF
    ReDim aResults(0)
    bFound = False
    With TypeLibInfoFromFile(sTypelib)
 .SearchDefault = tliStClasses Or tliStEvents
 For Each SI In .GetMembersWithSubStringEx(sSymbol, Groups)
     bFound = True
     arr.AAdd_PostIncrement aResults, SI.Name
 Next
    End With
    if bFound then 
 ReDim Preserve aResults(UBound(aResults) - 1)
    end if
    SearchTLIMethodsAndProperties = aResults
End Function

VBScript demo. The above code was included in my StdLib DLL in the Registry coclass.

Dim O, R
Set O = CreateObject("Std.Registry")
Set R = CreateObject("Std.Arrays")
WScript.Echo R.ShowStructure( O.SearchTLIMethodsAndProperties( "MSSCRIPT.OCX",""))

Output from the demo (script was run in SciTE).

>cscript "C:\foo\foo.vbs"
{Add,AddCode,AddObject,AllowUI,Clear,CodeObject,Column,Count,Description,Error,Eval,ExecuteStatement,HasReturnValue,HelpContext,HelpFile,Item,Language,Line,Modules,Name,NumArgs,Number,Procedures,Reset,Run,SitehWnd,Source,State,Text,Timeout,UseSafeSubset}
>Exit code: 0

Finally, the VBA code. A cell has a symbol in it and this routine finds it or returns an error string. (reg. in this case refers to the Registry coclass in the StdLib.DLL)

Public Function LookupSymbol(sLib As String, sSym As String) As String
    Dim aRes As Variant
    aRes = reg.SearchTLIMethodsAndProperties(sLib, sSym)
    Dim i As Integer
    LookupSymbol = "!!NotFound!!"
    For i = 0 To UBound(aRes)
 If LCase$(aRes(i)) = LCase$(sSym) Then
     LookupSymbol = sSym
     Exit For
 End If
    Next
End Function

Hmm ... no error checking. Should fix that.

© Copyright Bruce M. Axtens, 2009

Tuesday, June 10, 2008

[VBScript] StandardLibrary.zip

For those interested, who haven't been able to download it recently, here's the latest iteration of StandardLibrary.vbs. Now it's called stdlib.vbs and can be obtained from my boost account at the Perth Linux Users Group.

There have been a few changes, mostly additional functions and the odd tweak in favour of better functionality.

Significant in the additions are a few functions for sending emails: Blat, BlatAttachment, ErrorEmail, ErrorEmailApp, RedemptionSend and ThunderbirdSend. If I remember correctly, ErrorEmail has been around for a while, but is included here for completeness sake.

Function Blat( sTo, sSubj, sText )
    Const TIMEOUT_LIMIT = 60000
    Const TIMEOUT_SLICE = 500
    Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode"
    Dim nTimeout
    Dim bTimedOut
    Dim oExec
    Dim sCmd
    Dim sFolder
    Dim sName
    Dim sPath
    Dim sSave
    Dim sResult
    Dim aResult
    Dim bResult
    Dim bDontCare
    
    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sPath = oFSO.BuildPath( sFolder, sName) 
    WriteFileU sPath, sText, WF_CREATE

    sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) ))
    bTimedOut = False
    nTimeout = TIMEOUT_LIMIT
    Set oExec = oShell.Exec( sCmd )
    bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY )
    Do While oExec.Status = 0
        Doze TIMEOUT_SLICE
        nTimeout = nTimeout - TIMEOUT_SLICE
        If nTimeout < 1 Then
            bTimedOut = True
            Exit Do
        End If
    Loop
    sResult = oExec.StdOut.ReadAll
    aResult = Split( sResult, vbCRLF )
    If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then
        bResult = False
    Else
        bResult = True
    End If  
    Blat = Array( bResult, sResult )    
End Function

Function BlatAttachment( sTo, sSubj, sText, aAttachments )
    Const TIMEOUT_LIMIT = 30000
    Const TIMEOUT_SLICE = 500
    Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode"

    Dim nTimeout
    Dim bTimedOut
    Dim oExec
    Dim sCmd
    Dim sFolder
    Dim sName
    Dim sPath
    Dim sSave
    Dim sResult
    Dim aResult
    Dim bResult
    Dim bDontCare
    
    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sPath = oFSO.BuildPath( sFolder, sName) 
    WriteFileU sPath, sText, WF_CREATE
    
    sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) ))
    bTimedOut = False
    nTimeout = TIMEOUT_LIMIT
    Set oExec = oShell.Exec( sCmd )
    bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY )
    Do While oExec.Status = 0
        Doze TIMEOUT_SLICE
        nTimeout = nTimeout - TIMEOUT_SLICE
        If nTimeout < 1 Then
            bTimedOut = True
            Exit Do
        End If
    Loop
    sResult = oExec.StdOut.ReadAll
    aResult = Split( sResult, vbCRLF )
    If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then
        bResult = False
    Else
        bResult = True
    End If  
    Blat = Array( bResult, sResult )    
End Function

Const SLICE = 1024

Sub ErrorEmail( vTo, sSubj, sText )
    Dim sCC
    Dim sTo
    If IsArray( vTo ) Then
        sTo = Escape( vTo( 0 ) )
        sCC = Escape( vTo( 1 ) )
    Else
        sTo = Escape( vTo )
    End If
    
    sSubj= Escape( sSubj )
    sText = Escape( sText )
    
    If IsArray( vTo ) Then
        sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) )
    Else
        sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    End If
    '~ MsgBox sCmd
    On Error Resume Next
    oShell.Run sCmd ', 0, True
    If Err.Number <> 0 Then
        document.parentwindow.clipboardData.SetData "text", UnEscape( sText )
        MsgBox "Windows didn't like the size of message. I've put it on the clipboard"
        sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) )
        oShell.Run sCmd, 0, True
        HTASleep 5000
    End If
End Sub

Sub ErrorEmailApp( cApp, vTo, sSubj, sText )
    Dim sCC
    Dim sTo
    If IsArray( vTo ) Then
        sTo = Escape( vTo( 0 ) )
        sCC = Escape( vTo( 1 ) )
    Else
        sTo = Escape( vTo )
    End If
    
 IF cApp <> "" Then cApp = DQ( cApp ) & " "
 
    sSubj= Escape( sSubj )
    sText = Escape( sText )
    
    If IsArray( vTo ) Then
        sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) )
    Else
        sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    End If
    On Error Resume Next
    oShell.Run cApp & sCmd ', 0, True
    If Err.Number <> 0 Then
        document.parentwindow.clipboardData.SetData "text", UnEscape( sText )
        MsgBox "Windows didn't like the size of message. I've put it on the clipboard"
        sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) )
        oShell.Run cApp & sCmd, 0, True
        HTASleep 5000
    End If
End Sub

Function RedemptionSend( aRecipients, sSubject, sBody )
  dim oSafeItem
  Dim oItem 
  Dim oApplication
  Dim oNameSpace
  Dim sRecip
  
  set oSafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem 
  set oApplication = CreateObject("Outlook.Application")
  set oItem = oApplication.CreateItem(0) 'Create a new message
  oSafeItem.Item = oItem 'set Item property
  For Each sRecip In aRecipients
    If sRecip <> "" Then
      oSafeItem.Recipients.Add sRecip
      oSafeItem.Recipients.ResolveAll
    End If
  Next
  oSafeItem.Subject = sSubject 
  oSafeItem.Body = sBody
  oSafeItem.Send
End Function

Function ThunderbirdSend( aRecipients, sSubject, sBody, aAttachments )
    'thunderbird.exe -compose "to='foo@nowhere.net,foo@foo.de',subject=cool page,attachment=file:///c:/temp/foode.txt" 
    Dim sRecip
    Dim sApp
  Dim sCmd
    sRecip = "'" & Join( aRecipients, "," ) & "'"
    Dim sAttItem
    Dim sAttach
    For Each sAttItem in aAttachments
        If sAttItem <> "" Then
            sAttItem = Replace(sAttItem, "\", "/" )
            sAttach = sAttach & "attachment='file:///" & sAttItem & "',"
        End If
    Next
    If Right( sAttach, 1 ) = "," Then
        sAttach = Left( sAttach, Len( sAttach ) - 1 )
    End If
    sApp = "C:\Program Files\Mozilla Thunderbird\thunderbird.exe"
    sCmd = Subst( " -compose ""to=[1],subject=[2],body=[3],[4]""", Array( sRecip, sSubject, sBody, sAttach ))
    oShell.Run DQ( sApp ) & sCmd, 0, False
    HTASleep 5000
End Function

A while back Derek Parnell wrote a replacement for Euphoria's print function which would show the structure of arrays. ShowStructure and a support routine AsString make this available to the VBScript programmer. By the way, in case you haven't heard, Euphoria is now open-source!

function ShowStructure( vToShow )
    dim nCounter
    dim sResult
    dim nArraySize
    sResult = ""

    if isarray( vToShow ) then
        nArraySize = ubound( vToShow )
        If nArraySize >= 0 Then
            for nCounter = 0 to nArraySize - 1
                sResult = sResult & ShowStructure( vToShow( nCounter ) ) & ","
            next
            sResult = "{" & sResult & ShowStructure( vToShow( nArraySize ) ) & "}"
        Else
            sResult = "{}"
        End If
    else
        sResult = AsString( vToShow )
    end if
    ShowStructure = sResult
end function

Function AsString( x )
    Dim sResult
    If TypeName( x ) = "Null" Then
        sResult = "Null"
    Else
        sResult = CStr( x )
    End If
    AsString = sResult
End Function

The output, then, from code such as this:

a = Array(1,Array(2,3,Array("moo")))
wscript.echo showstructure(a)

would be

{1,{2,3,{moo}}}

which maybe leads on toward data serialisation ...

There've been some additions to the file handling space, with the addition of routines to read and write unicode files (ReadFileU, WriteFileU, ReadFirstLineU and its ANSI equivalent, ReadFirstLine.)

Logging has been worked on. It's something I'm unlikely to be totally happy with, but there's now a SetLog and a ClearLog as well as the standard Log (and, given the possibility of confusion with the logarithm system, maybe I should change it to Trace (oh man, how many scripts that would break!))

What else? Well, BuildTree builds a directory tree. FirstLineOf returns the first vbNewLine-delimited line from a string (useful where you've used ReadFile or ReadFileU to inhale an entire file.) LastLineOf does what FirstLineOf does but for the end of the file, and NthLineOf gets you the ... nth ... line.

I've actually forgotten what I wrote UpToAndAfter for, but it's included anyway.

IsOnLine uses the ResolveIP function with the IP address 198.182.196.48 (which points somewhere on linux.org) to see if you are still on line.

SetPriority uses the same code as used in BOOST to set process priority.

StrInArray finds a string in an array of strings, with optional case sensitivity.

StringMap scans a string for the presence of items in one array and swaps them for the equivalently indexed elements in the second array. If the second array is a string, they get swapped for that string.

Doze wraps WSCript.Sleep and HTASleep, so that it can be used in .VBS files and .HTA files.

ModalThing2 shows a modal dialog (only works in .HTA files)

And, finally, SoundMessage:

Sub SoundMessage( sSoundFile, sMessage )
    Dim sCommand
    Dim sFullname
    sCommand = "sndrec32 /play /close " & DQ( sSoundFile )
    oShell.Run sCommand, 0, False
    Doze 1000
    Msgbox sMessage
End Sub

Obviously, if you see something that needs to be fixed, fix it. And tell me to fix it so that it can be fixed in the distribution and your name can be added to the list of contributors.

© Copyright Bruce M. Axtens, 2008

Wednesday, August 30, 2006

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

Saturday, August 12, 2006

[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

Tuesday, September 27, 2005

[VBScript] "Watcher" - on the way to code profiling ... sort of

I've just implemented a new class, Watcher, which is giving me an idea of what routines in my stdFunctions.vbs are actually being used, and how frequently.

At present the class depends on some of the routines it would otherwise be watching so those routines can't refer to Watcher until such time as I make the class self-contained.

The class gets instantiated in the usual way right at the start of my stdFunctions.vbs file

dim watch
set watch = new watcher

and then at the beginning of each of the subs and functions in stdFunctions.vbs there is a reference to watch, e.g.

Sub Die( theMsg )
    watch "Die"
    Log theMsg
    WScript.Echo theMsg
    WScript.Quit
End Sub


Sub Log( theMsg )
    watch "Log"
    Const theExt = ".log"
...

When the class terminates the data is saved in Watcher.txt as lines of tab-delimited text, for example:

me 6
you 6
Logging 3
EnforcePath 3
Die 3
Log 3
ForceExtension 3

and these are then read back in at the initialisation of class next runtime round.

If you find this useful please let me know. Code below.

class Watcher
 private objHash
 
    private sub Class_Initialize()
     dim strData
     dim arrLines
     dim strLine
     dim arrKeyData
     dim i 
     
     set objHash = CreateObject( "Scripting.Dictionary" )
'      wscript.echo "dictionary created"
     If IsFile2( "Watcher.txt" ) Then
      strData = GetFile( "Watcher.txt" )
      arrLines = Split( strData, vbNewLine )
      For i = 0 To UBound( arrLines )
       strLine = arrLines( i )
       If Len( strLine ) > 0 Then
        arrKeyData = Split( strLine, vbTab )
'         wscript.echo "adding", parray( arrKeyData )
        objHash.Add arrKeyData( 0 ), arrKeyData( 1 )
       End If
      Next
     End If
    end sub
    
    public default sub lambda( strName )
     if objHash.Exists( strName ) then
      objHash( strName ) = objHash( strName ) + 1
'       wscript.echo "updating watched item " & strName
     else
      objHash.Add strName, 1
'       wscript.echo "new item " & strName
     end if
    end sub
    
    private sub Class_Terminate()
     dim arrItems
     dim arrKeys
     dim numCount
     dim i
     dim strResult
     
     arrItems = objHash.Items
     arrKeys  = objHash.Keys
     numCount = objHash.Count
     
     for i = 0 to numCount - 1
      strResult = strResult & arrKeys( i ) & vbTab & arrItems( i ) & vbNewLine
     next
     
     WriteFile2 "Watcher.txt", strResult, False
     
'      wscript.echo "Terminated"
end sub
end class