[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

[Visual BASIC 6] BOOST (v3)

BOOST got another look-in recently. I had been using it exclusively to do "realtime" and "kill". This particular time I tried to do an "abovenormal" -- instead it did a "kill".

In the process of finding and fixing that bug, I replaced the Collection mechanism with the augmented Collection supplied by the "Class Builder" add-in.

The source code is essentially the same as before but with a few changes. First the SysVars and Var classes. (The comments are predominantly those supplied by the add-in.)

First, SysVars.cls:

'local variable to hold collection Private mCol As Collection Public Function Add(key As String, Optional sKey As String) As Var Dim objNewMember As Var 'create a new object Set objNewMember = New Var 'set the properties passed into the method objNewMember.Value = key objNewMember.key = sKey If Len(sKey) = 0 Then mCol.Add objNewMember Else mCol.Add objNewMember, sKey End If 'return the object created Set Define = objNewMember Set objNewMember = Nothing End Function Public Property Get Item(vntIndexKey As Variant) As Var 'used when referencing an element in the collection 'vntIndexKey contains either the Index or Key to the collection, 'this is why it is declared as a Variant 'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5) Set Item = mCol(vntIndexKey) End Property Public Function Exists(vntIndexKey As Variant) As Boolean Dim V As Var On Error Resume Next Set V = mCol(vntIndexKey) Exists = (Err.Number = 0) End Function Public Function Count() As Long 'used when retrieving the number of elements in the 'collection. Syntax: Debug.Print x.Count Count = mCol.Count End Function Public Sub Remove(vntIndexKey As Variant) 'used when removing an element from the collection 'vntIndexKey contains either the Index or Key, which is why 'it is declared as a Variant 'Syntax: x.Remove(xyz) mCol.Remove vntIndexKey End Sub Public Sub Modify(sValue As String, sKey As String) Dim V As Var 'Set V = New Var Set V = mCol.Item(sKey) V.Value = sValue 'mCol.Remove sKey 'Add sValue, sKey End Sub Public Property Get NewEnum() As IUnknown 'this property allows you to enumerate 'this collection with the For...Each syntax Set NewEnum = mCol.[_NewEnum] End Property Private Sub Class_Initialize() 'creates the collection when this class is created Set mCol = New Collection End Sub Private Sub Class_Terminate() 'destroys collection when this class is terminated Set mCol = Nothing End Sub

Next, Vars.cls (it's tiny but it could hold so much more):

Public key As Variant Public Value As Variant

Now the main module. The first thing that is different here, is that nLevel is now a Long. Integer doesn't handle the ABOVENORMAL_PRIORITY value without complaint.

Next change is removing the reference to Collection, changing it to SysVars and setting up the values.

The benefit of using SysVars and that approach to the Collection object is that we now have an .Exists method, so we now have a tidier way of setting nLevel and trapping invalid settings thereof.

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

All the other routines are as before.

I haven't gotten around to extending this tool to do stuff to remote computers. It's not hard; killing a process on another machine means another value for sComputer in KillProcess, and, of course, the relevant privilege level.

© Copyright Bruce M. Axtens, 2008