[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

[FORTRAN] Making a DLL for VB6

As a break from trying to figure out how to get a pattern matching library DLLified (and UTF-32 sensitive), my boss gave me something else to do, something on the one hand similar (wrap something in a DLL) and on the other quite different (wrap two knapsack algorithms done in Fortran 90).

The knapsack code is derived from

Algorithm 4.9, Donald Kreher and Douglas Stinson, Combinatorial Algorithms, CRC Press, 1999, page 125.

and was downloaded from FORTRAN Source Codes, specifically, the COMBO library. Many thanks to John Burkardt for making this resources available.

The files used from the COMBO library were knapsack_01.f90, knapsack_rational.f90, knapsack_reorder.f90, rvec_backtrack.f90 and r_swap.f90, and were compiled using Compaq Visual Fortran.

Seeing as CVF is no longer available (except perhaps on eBay) you might get away with the Intel® Fortran Compiler for Windows, SilverFrost's FTN95 or g95.

Don't try it with Watcom Fortran, however, because that only does Fortran 77. Mind you, if the algorithms you're wrapping are F77 ones from NIST's 'Dictionary of Algorithms and Data Structures' or Steven Skiena's The Stony Brook Algorithm Repository you may do okay with the Watcom offering or even GNU's g77.

I really like Fortran. I remember writing some VAX-11 FORTRAN back in 1983 (along with a bit more VAX-11 COBOL) and found it quite powerful and expressive. I know that there's been a fairly widespread pooh-pooh-ing of Fortran in recent years, but I try not to be influenced by peer-group pressure, preferring to actually see for myself whether a language is any good or not.

Okay, off the soap box and down to the code. I'm not going to bother posting all the COMBO code, just what I wrote to wrap it.

These are the three exposed routines and have essentially the same framework: a subroutine header, two declarations controlling symbol names and method of access, the call to the COMBO routine, the return and the end of subroutine. Really, really, simple. Gobsmackingly simple, compared to some other languages I could mention. Rather embarrasing really ... so little to show.

If you're wondering why I explicitly state that the parameters are being passed by reference (!dec$ attributes reference ...), it's because a side effect of specifying "stdcall" is that it forces the passing mechanism into pass-by-value, and in this case, quite a few of the parameters are being modified by the subroutine.

!BOAL0.f90 !FUNCTIONS/SUBROUTINES exported from BOAL0.dll: !stdcall forces all parameters to pass-by-value, !thus the 'attributes reference' declaration subroutine Knapsack01( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "Knapsack01" :: Knapsack01 !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_01 ( n, mass_limit, p, w, x, mass, profit ) return end subroutine Knapsack01 subroutine KnapsackRational ( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackRational" :: KnapsackRational !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_rational ( n, mass_limit, p, w, x, mass, profit ) return end subroutine KnapsackRational subroutine KnapsackReorder ( n, p, w ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackReorder" :: KnapsackReorder !dec$ attributes reference :: n, p, w call knapsack_reorder ( n, p, w ) return end subroutine KnapsackReorder

The other routines are linked in during the compile and I end up with a nice little .DLL.

Okay, so maybe there's something more to show on the VB6 side.

First off, the declares. VB6 defaults to pass-by-reference, thus the missing "ByRef" ahead of each parameter.

Declare Sub KnapsackReorder Lib "BOAL0.dll" (n As Integer, p As Single, w As Single) Declare Sub Knapsack01 Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single) Declare Sub KnapsackRational Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single)

Next the test code which is derived from TEST094 and TEST095 found inside COMBO's combo_prb.f90.

Do note that the floating point variables are defined here as Single. This seems to be the best match to an undecorated Fortran REAL. Maybe if I'd tweaked the COMBO code to REAL*8, I could have used Double on the VB6 side.

Sub main() Dim i As Integer Dim mass As Single Const mass_limit As Single = 26# Dim p(4) As Single Dim profit As Single Dim w(4) As Single Dim x(4) As Single Const n As Integer = 4 p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_01 solves the 0/1 knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit Knapsack01 n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass '-- p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_RATIONAL solves the rational knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit KnapsackRational n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass End Sub

Hmm ... nothing much amazing there either. But that's how it was with wrapping the Fortran. Simple and powerful at the same time. So far as I'm concerned, if we ever have to rewrite Protium, Fortran's going to be very near the top of the list.

© Copyright Bruce M. Axtens., 2007