Code-a-holic: PLUG

Showing posts with label PLUG. Show all posts

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.

Wednesday, February 22, 2006

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