[VBScript] Deriving user name from computer name

I found a brilliant bit of code for deriving the username from the computer name. It's found inside Matt Williams's "ManagePC v1.31" HTA. His description of the routine is as follows

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).
-- Matthew Williams, ManagePC

Below is my routine, combining his code with some extra housekeeping. Function GetDomainUser( sComputer ) Dim cProc Dim oProcess Dim sUser, sDomain Dim sResult Dim oWMI 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 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 Of course, if no one is logged in, you get nothing. My own take on Matt's routine adds in a check to see if the computer is actually running, using ResolveIP() below: Function ResolveIP( sName ) Dim sHost Dim sTarget Dim cPingResults Dim oPingResult Dim sResult sResult = "" 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

[VBScript] Plugins

I had written a plugin architecture for one of my HTA applications. Now I discover that I can have plugins using almost any scripting language available. I found this bit of brilliance in a google search: "Hartmut Callies" <Spam_callies@web.de> wrote in message news:%23$FV8t07FHA.3044@TK2MSFTNGP10.phx.gbl... > > Hello, > I have two vbScripts. In a.vbs I will create a global variable glVariable as > String, so that > I can read this variable in a other script (b.vbs) - msgBox glVariable. > How can I do that? Considering using the volatile environment. Set the variable in a.vbs like this: oWSH.Environment("VOLATILE")("glVariable") = "Information from script a.vbs" Read it from b.vbs using something like this: sVar = oWSH.Environment("VOLATILE")("glVariable") I can now pass whatever information I like to and fro from application to plugin and back again. And if another scripting languages does something better than VBScript I can use it (provided it gives access to the volatile store).

[Working Again]

After a short stint on the support queue at iiNet (part-time), I'm now on contract at Department of Land Information. L1 and L2 support with a bit of scripting on the side. VBScript again, sadly.

[Pharmacy Software]

One of my clients has suggested I write pharmacy software. He has a home-grown Clipper app that does everything from Dispensing to Cash Register. I give him a hand with it from time to time. He reckons there's a market for a low-cost package which would fit the Western Australian situation better than the off-the-shelf ones now available.

So comes then the ever-present question: Closed Source, or Open Source.

No knowing a lot about how Open Source works as an income generator, I fear that there is the risk that my non-Open Source competitors may steal my ideas and woo my customers away because they have the resources to bring them (the ideas, not the customers) to the market faster than I can. Is that a valid concern?

Closed Source isn't without its problems either.

And then comes the other questions: programming language / IDE / RAD. I wonder if anyone's come up with a template for software projects in the style of Word / Excel / PowerPoint templates.

[Visual Studio 2005 Team System Beta 2]

I went to a Microsoft do yesterday and that's what they gave me (amongst other things.) Now to find a machine to install it on (only Linux, MacOSX and Win98 at home).

Eventually I want to start bidding on jobs at Get A Coder and Get a Freelancer.

Until then ... Khuda janta he.

[VBScript] Shell and Heap Sorts

The final versions of the Shell sort and Heap sort classes. First the ShellSorter:

class ShellSorter 
'~ http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/shell/shell.htm
    private a
    private n

    public sub sort(a0)
        a = a0
        n = UBound( a ) + 1
        shellsort
    end sub

    public function sorted()
        sorted = a
    end function

    private sub shellsort()
        dim i, j, k, h, t
        dim cols
        cols = array( 1391376, 463792, 198768, 86961, 33936, _
                    13776, 4592, 1968, 861, 336, 112, 48, 21, 7, 3, 1 )
        
        for k = 0 to UBound( cols )
            h = cols( k )
            for i = h to n - 1
                j = i
                t = a( i )
                do while j >= h
                    if a( j - h ) <= t then exit do
                    a( j ) = a( j - h )
                    j = j - h
                loop
                a( j ) = t
            next
        next
    end sub
end class

and then the HeapSorter

class HeapSorter 
    '~ http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/heap/heapen.htm
    private aVector
    private n

    public sub sort( aVec )
        aVector = aVec
        n = UBound( aVector ) + 1
        heapsort
    end sub

    public function sorted()
        sorted = aVector
    end function

    private sub heapsort()
        buildheap
        do while n > 1
            n = n - 1
            exchange 0, n
            downheap 0
        loop
    end sub

    private sub buildheap()
        dim v
        for v = int( n / 2 ) - 1 to 0 step -1
            downheap v
        next
    end sub

    private sub downheap(v)
        dim w
        w = 2 * v + 1   '// first descendant of v
        do while w < n
            if w + 1 < n then   '// is there a second descendant?
                if aVector( w + 1 ) > aVector( w ) then
                    w = w + 1
                end if
            end if

            '// w is the descendant of v with maximum label
            if aVector( v ) >= aVector( w ) then
                exit sub  '// v has heap property
            end if

            '// otherwise
            exchange v, w  '// exchange labels of v and w
            v = w          '// continue
            w = 2 * v + 1
        loop
    end sub

    private sub exchange(i, j)
        dim t
        t = aVector( i )
        aVector( i ) = aVector( j )
        aVector( j ) = t
    end sub

end class

By the way, I'm unemployed again. Things might be a bit quiet around here for a while.

[VBScript] sorting algorithms

Thanks to Dr Hans Werner Lang for his helpful comments on the sorting routines, as below:

Hi,
but there is no need to rewrite the outer loop, is it?
    for i=h to n-1
    ...

The inner loop, with the problem of the conditional And, could be written as
    do while j>=h
        if a(j-h)<=t then exit do
        ...
    loop

In my opinion, exit do should be avoided (when possible).

Regards
H.W. Lang

I've made the changes to the class as suggested but haven't posted them as yet.

[MetaCard] Starter Kit script size limit, Part 2

And if anyone was curious what happened to the MetaCard script size issue, Ken Ray said,

>I've been told, via the MetaCard list, that you have a technique for
>getting around the script size limit in MetaCard. If that's so, please
>can you tell me whence I can download the whitepaper about it.

Sorry to disappoint you, Bruce, but I don't. In fact, given that DreamCard is only $99, it seems counterproductive to attempt to get around the script size limits when you can pick up a full development environment very inexpensively.

and Geoff Canyon said

I don't recall that I wrote anything in particular. I did write an exporter for the documentation for earlier versions of Revolution, and they had a small section on dealing with the script limits in the starter kit. The basic point is to understand how to write tight code. You can insert scripts in front and back, and "start using" stacks, and use nested groups to your advantage. You can also store scripts in custom properties and use the "do" command on them.

If you ask on the mailing list, there are several people there who spent significant time working within the script limits who can probably help you with any specific issues. I bought a license early on so I don't have much practical experience.

Finally, if you're concerned about whether Rev is a good fit for what you want to do, ask on the list. People will tell you the truth. There are (many) things Rev is very good for, and (almost as many) things it isn't well suited for.
>I'm told that, sometime late last century, you wrote
>something about side-stepping the script size limit in
>the MetaCard unregistered version.

So the upshot of all this is: spend some money and stop complaining.

[xbScript] Hooley Dooley! Move over VBScript, here comes xbScript

This is just amazing! "xbScript.dll enables xBase scripting (exactly like MS vbScript and JScript) in any MS ActiveScript compliant Host." Now I can help a friend, who has a large legacy Clipper app running in DOS under Windows, to integrate his software into the Windows environment. And he won't have to learn another language when he wants to tweak things. Hallelujah!!

[EOC] T minus 2 and counting

It's Thurday. I'm busily updating the documentation.

Friday 14 October is "The Last Day". (I wish it was THE last day, that is, the day Jesus returns.)

Of the 19 agencies I've written to, 4 have replied to say they're working on it. Looks like it's back to getting suited up and walking from agency to agency in the Perth CBD saying, "G'day, remember me? Yeah, I'm actually 3D and have feelings."

There's this disease one can get -- I get it often -- called PLOM disease: Poor Little Old Me.

[VBScript] Please, please, no more sorting!!

After so many tries, I had thought I was done with it. Well the virtual memory limit on my machine still stands so when the shellSort encountered an array of 1.5 million records, it failed. I could have gone ahead with getting the VM size increased but decided it was better to deal with the limitation as it stood. Who knows, the next bloke may not have much virtual memory either (though, I suppose, he's more likely to have lots more.)

I handed the job over to SORT.EXE and used the Exec method to call it. Like this: Dim sSamplesFilename, sSamplesData, aSamplesData, sSampleItem sSamplesFilename = Join( Array( sReportPath, sTableName & "_DataStream.txt" ), "\" ) If isFile2( sSamplesFilename ) Then oSamples.ReadFile sSamplesFilename End If WScript.Echo "Sorting " & FormatNumber( oSamples.ByteLength / 2, 0,,,-1) & " Unicode bytes to " & BaseName( sSamplesFilename ) oSamples.WriteFile "TemporaryFile.$$$", adSaveCreateOverWrite SortFile "TemporaryFile.$$$", sSamplesFilename The actual call to SortFile is what were talking about but the oSamples stuff needs some explaining. Dim oSamples Set oSamples = New SuperContainer SuperContainer is a class based on the ADODB.Streams object. Class SuperContainer private oStream Private Sub Class_Initialize() Set oStream = CreateObject( "ADODB.Stream" ) oStream.Open End Sub Public Sub Store( sText ) oStream.WriteText sText End Sub Public Function Recall() Dim sResult oStream.Position = 0 sResult = oStream.Read( adReadAll ) Recall = sResult End Function Public Sub ReadFile( sFilename ) Dim sText Dim aText Dim sItem Dim nStart Dim nFinish If IsFile2( sFilename ) = True Then sText = Chomp( GetFile( sFilename ) ) aText = Split( sText, VbNewLine ) nStart = oStream.Position For Each sItem in aText oStream.WriteText sItem & VbNewLine Next nFinish = oStream.Position WScript.Echo FormatNumber( nFinish - nStart / 2, 0,,,-1) & " ubytes read from " & sFilename Else WScript.Echo "Cannot find " & sFilename End If End Sub Public Sub WriteFile( sFilename, nMode ) oStream.SaveToFile sFilename, nMode End Sub Private Sub Class_Terminate() oStream.Close Set oStream = Nothing End Sub Public Function ByteLength() ByteLength = oStream.Size End Function End Class Interestingly I had a lot of trouble with the ReadFromFile method in ADODB.Stream. I think this had to do with it expecting Unicode but getting ASCII. When you hand a Unicode file over to SORT.EXE, it sorts it okay but changes it into ASCII. ReadFromFile tries to interpret the file as Unicode and you end up with a mess. Thus the GetFile()/Split/For Each thing in my ReadFile method.

The code for the sorting routine is: Sub SortFile( sInputFilename, sOutputFilename ) Const sCommandline = "SORT ""%IN%"" /O ""%OUT%""" Dim oExec Dim sCommand sCommand = Subst3( sCommandline, Array( Array( "IN", sInputFilename ), Array( "OUT", sOutputFilename ) ) ) If bDebugging = True Then Info "SortFile: Exec> " & sCommand End If Set oExec = oShell.Exec( sCommand ) Do While oExec.Status <> 1 WScript.Sleep 100 Loop If bDebugging = True Then If Not oExec.StdOut.AtEndOfStream Then Info "SortFile: StdOut> " & oExec.StdOut.ReadAll End If End If End Sub I have a global in my stdFunctions.vbs called bDebugging. It's normally False but I can change it and get some useful feedback thereby.

The upshot of all this is that the sorting seems to be working ... but still not perfectly -- when I gave SORT.EXE a 63 Gigabyte file it didn't like it. But the likelihood of generating datasets that large is low.

[VBScript] read and write local and remote files

Check out a wonderful write up by Antonin Foller of PSTRUH Software on reading and writing files in VBScript. Note the very helpful stuff on Binary Files.

[General] Mergesort

This is a great site for algorithms, like Mergesort. A round of applause for the author, Prof. Dr. H. W. Lang.

It's mostly German language, but there are some English translations and the Java code is fairly human-language-neutral.

[VScript] At last, a working shell sort

Finally found a shell sort that works. The problems I had previously might have been had because of this: while (j>=h && a[j-h]>t) I converted that straight to VBScript and kept crashing because a[j-h] with a negative index would get evaluated. By using a do/loop and breaking the test up into two parts do if j < h then exit do end if if a( j - h ) <= t then exit do end if ... I got stuff to work. Here's the code. Usage is similar to that for heap sort. class ShellSorter '~ http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/shell/shell.htm private a private n public sub sort(a0) a = a0 n = UBound( a ) + 1 shellsort end sub public function sorted() sorted = a end function private sub shellsort() dim i, j, k, h, t dim cols cols = array( 1391376, 463792, 198768, 86961, 33936, _ 13776, 4592, 1968, 861, 336, 112, 48, 21, 7, 3, 1 ) for k = 0 to UBound( cols ) h = cols( k ) i = h do if i >= n then exit do end if j = i t = a( i ) do if j < h then exit do end if if a( j - h ) <= t then exit do end if a( j ) = a( j - h ) j = j - h loop a( j ) = t i = i + 1 loop next end sub end class

[VBScript] Arrrghh!! Sorting out sorting ...

Just when I thought my problems were all over ... or at least the sorting ones ... I found that my machine didn't have enough virtual memory to handle the sort using ADODB (and I don't have the privilege level to do anything about it).

So I ported a heap sort to VBScript and ... so far ... everything look like it's going to work.

Here's the code class HeapSorter '~ http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/heap/heapen.htm private aVector private n public sub sort( aVec ) aVector = aVec n = UBound( aVector ) + 1 heapsort end sub public function sorted() sorted = aVector end function private sub heapsort() buildheap while n > 1 n = n - 1 exchange 0, n downheap 0 wend end sub private sub buildheap() dim v for v = int( n / 2 ) - 1 to 0 step -1 downheap v next '~ for (int v=n/2-1; v>=0; v--) '~ downheap (v); end sub private sub downheap(v) dim w w = 2 * v + 1 '// first descendant of v while w < n if w + 1 < n then '// is there a second descendant? if aVector( w + 1 ) > aVector( w ) then w = w + 1 end if end if '// w is the descendant of v with maximum label if aVector( v ) >= aVector( w ) then exit sub '// v has heap property end if '// otherwise exchange v, w '// exchange labels of v and w v = w '// continue w = 2 * v + 1 wend end sub private sub exchange(i, j) dim t t = aVector( i ) aVector( i ) = aVector( j ) aVector( j ) = t end sub end class ... and to use it, something like this ... Set oHeap = New HeapSorter oHeap.sort aVector aSortedVector = oHeap.sorted()

[VBScript] Sorting ... another way

I have tried and tried to get Shell sorts working but every algorithm I've tried ends up crashing out with negative indexes into the array.

So below is another way around the whole issue: create a RecordSet, populate it with fields, add data to it and use the RecordSet's own internal sorting routines. class Container2 private oRecordSet Private Sub Class_Initialize() Const adVarWChar = 202 Dim oFields Set oRecordSet = CreateObject( "ADODB.RecordSet" ) Set oFields = oRecordSet.Fields oFields.Append "Data", adVarWChar, 255 oRecordSet.Open End Sub Public Sub Add( sText ) oRecordSet.AddNew "Data", sText End Sub Public Function Extract() Const adClipString = 2 Dim sResult sResult = oRecordSet.GetString( adClipString, oRecordSet.RecordCount, , , "") Extract = sResult End Function Public Sub Sort( sDirection ) Dim sSort sDirection = UCase( Left( sDirection, 1 ) ) Select Case sDirection Case "A" sSort = "Data ASC" Case "D" sSort = "Data DESC" Case Else sSort = "" ' no sort, natural order End Select WScript.Echo "Sorting " & oRecordSet.RecordCount & " items" oRecordSet.Sort = sSort End Sub Private Sub Class_Terminate() oRecordSet.Close Set oRecordSet = Nothing End Sub Public Sub SaveData( sFilename ) Const adPersistADTG = 0 oRecordSet.Save sFilename, adPersistADTG End Sub Public Sub SaveXML( sFilename ) Const adPersistXML = 1 oRecordSet.Save sFilename, adPersistXML End Sub end class And a trivial example of its use function rangedRandom( nLoBound, nHighBound ) rangedRandom = Int((nHighBound - nLoBound + 1) * Rnd + nLoBound) end function dim c set c = new container2 randomize dim x(100) for i = 100 to 0 step -1 c.add rangedRandom(1,1000) & vbtab & "my dog has " & i & " fleas" next c.sort "Ascending" wscript.echo c.extract filedelete("dim.dat") c.savedata "dim.dat" filedelete("dim.xml") c.savexml "dim.xml"

[VBScript] Synthetic Includes in Traditional VBScript Files

Most of us are aware of the entry "Synthetic Includes in Traditional VBScript Files" in the Rube Goldberg Memorial Scripting Page.

Today I stumbled across how to embed test routines in the include file without causing these routines to be activated when the file is included.

My include file is called "StdFunctions.vbs". At the bottom of the file I've put If BaseName( WScript.ScriptFullName ) = "StdFunctions.vbs" Then WScript.Echo "Testing StdFunctions.vbs" 'tests go here End If When StdFunctions.vbs is included by a script, ScriptFullName evaluates to the name of that script. It's only when StdFunctions.vbs is run by itself that ScriptFullName ends with "StdFunctions.vbs".

BaseName is one of my routines and look a bit like this: Function BaseName( aFile ) Dim oFSO Set oFSO = CreateObject( "Scripting.FileSystemObject" ) BaseName = oFSO.GetFileName( aFile End Function [later that same day]

Read the manual, Bruce, read the manual: why use Basename with .ScriptFullName when you can just use .ScriptName?

[EOC] Other things it could mean

Meaning	Contributor
Elongated Orbital Crocodile	Bruce Axtens
Emu-Olive Cross	Daniel Axtens
Extra Old Codger	Robert Glanville, Icon Recruitment

[EOC] End of Contract

I've got one more week and then I'm unemployed again.

I feel down. I wish there was something "cutting edge" I could do. Everything I can think of is diametrically opposed to the cutting edge, being either the blunt bit at the back of the knife or the even blunter bit on top of the chisel handle.

Who cares about MetaCard? Who cares about S*BOL but a few diehard fanatics (who are mostly older and greyer than me)? Who cares about Clipper or xHarbour but a few South Americans into retro memorabilia? As for VBScript, this is just one of thousands of websites and I'm a relative newcomer to a tool that's been around for very long time.

Eventually I'll have posted all my MoonRock BASIC, Fitted Software Tools Modula-2, Turbo Pascal 5 and Euphoria code. Whooptie do. Even if I finish my CCNA, learn Haskell, and write Kiwi CatTools equivalents ... who cares?

[MetaCard and Tcl] Blogs.mc

I got asked to describe the stack a little better. Here goes:

My blogs.mc stack has two text fields (fSource and fGenerated) and some buttons at the bottom (create_card, first, prev, next, last, render, preview, delete).

With some marked-up text in the fSource field, I click 'render' and the output of the Tcl script (HTML) is put into the fGenerated field (line 6 of the 'Render' script).

Then when I click on 'preview' the HTML in the fGenerated field gets dumped to a file and passed to Safari. The fGenerated field is modifiable so I can play with things to get what I want and then tweak the Tcl script appropriately afterwards.

About the same time I posted this to the MetaCard list:

On my blog, codeaholic.blogspot.com, I've posted an item about MetaCard (on OS X) using Tcl to more-or-less bypass the script size limit of the unregistered version of MetaCard.

Richard Gaskin wrote back, saying (in part):

since there is no MetaCard anymore anyway, and since Rev only offers a 30-day trial for the engine, I'm not sure how helpful the article will be.

At $99 for the low-end Rev license, is the pricing really so prohibitive?

Also Alejandro Tejada wrote

i do not see how this could get around the 10 lines limit, but Geoff Canyon wrote an extensive tutorial to manage longer scripts within the 10 lines limits.

This tutorial is still useful for developers that want to run longer scripts in their standalone applications.

I get it from Ken Ray's website within the RR v 1.1 docs (saved as a pdf file). i'm not sure if this tutorial is still available in any website.

You could ask directly to Geoff Canyon. Look for his website: inspiredlogic.com

I answered with

> i do not see how this could get around the
> 10 lines limit,

bad choice of words on my part. It doesn't so much get around it as it does acquiesce to the fact and try to use other tools to do what can't otherwise be done. Instead of using MetaCard's HTML mechanism or writin8g something in MetaTalk, I've farmed out the functionality to a Tcl script.

> but Geoff Canyon wrote an
> extensive tutorial to manage longer scripts
> within the 10 lines limits.

of this I was unaware. I have thought about doing something similar. What I usually end up doing however, when I need to hang more closely to MetaCard is to use AppleScript and 'do script' or 'evaluate' the things I need. I will nevertheless make enquiries now that I know better.

[General] Five year from now, Google will dwarf Microsoft

Networking Pipeline | Blog | Will Google Buy AOL?

[General] Neuronstorm website update

I'm supposed to be one of the admins for Neuronstorm and when I successfully extract the digit, I'm to implement the Neuronstorm OSI (operating system interface) in GTk for Windows (and possibly Mac OS X).

Daniel's a good developer and there's certainly a fair bit of interest at his school in an open-source version of Inspiration™.

[Clipper 5.3 / xHarbour] .DBF to .CH (Clipper Header)

The client had Clipper 5.3. I had xHarbour. The client had a database of constants. I turned them into a .ch (Clipper Header) file with this bit of code which compiled both under xHarbour and Clipper 5.

procedure main()
        local cFName, vFValue
        local cCValue, cCName
        local nMax, i
        local h
        local cType
        local CRLF := CHR(13)+CHR(10)
        local cLine

        h := FCREATE( "./dispense.ch", 0 )
        ? h
        use numbers alias num
        goto 1
        nMax := FCOUNT()
        for i = 1 to nMax
                cFName := FIELDNAME( i )
                *? cFName
                cCName := "CONST_" + cFName
                vFValue := &cFName
                cType := VALTYPE(vFValue)
                *? cType
                DO CASE 
                        CASE cType == "C"
                                cCValue := '"' + vFValue + '"'
                        CASE cType == "N"
                                cCValue := STR( vFValue )
                        CASE cType == "D"
                                cCValue := DTOC( vFValue )
                        CASE cType == "L"
                                cCValue := IIF( vFValue, ".T.", ".F." )
                        OTHERWISE
                                ? "Don't know what to do with a cType of " + cType
                                QUIT
                END CASE
                cLine := "#define " + cCName + " " + cCValue + CRLF 
                ? cLine
                FWRITE( h, cLine )
                

        next
        FCLOSE( h )
        CLOSE DATABASES
        QUIT

[VBScript] 99 bottles of beer - "class" version

Check out my 99 bottles of beer submission.

Look at the entries for your own favourite language. Some of them a dead boring. Submit an example that would show off the real power of the language.

If you're using a language that isn't on the board, submit a version of the song in that too.

[MetaCard and Tcl] Broggle's cousin at home on the iBook

MetaCard's great but I can't afford to buy it (not that you can anyway, now that it's been subsumed into Runtime Revolution). But using the demo version means I keep bumping up against an inbuilt limit for scripts. So I hit upon the idea of bypassing the issue by calling external scripts.

The tool I use to write blogs at home (as opposed to the HTA I use elsewhere) is written in MetaCard and does the render and preview passes using Tcl.

[Aside: Not that there's anything about Tcl that lends itself to the job. I could have used Perl, Lua, Python, sed (maybe), awk, or any number of other languages from Algol68 (there's an implementation for Mac OS X believe it or not) right through to Zen BASIC. It's just that Tcl is familiar ground.]

Right, where was I. Oh yes ...

First the script in my "Render" button ...

on mouseUp
  put "/tmp/blog_" & random(65535) into fname
  open file fname for write
  write field fSource to file fname
  close file fname
  put shell("/usr/bin/tclsh ~/MindWeb/Writing/render.tcl " & fname ) into field fGenerated
  delete file fname
end mouseUp

... which creates a file in the temporary folder (I'm on Mac OS X here ... might work on Linux ... have to do something drastic for Windows), and puts my marked-up text from field fSource into it. Then it shells out to render.tcl and captures its output into the fGenerated field. The temporary file is deleted.

Render.tcl looks like this (in its current incarnation):

#! /usr/bin/tclsh
set auto_path [lappend auto_path /usr/local/lib/tcllib1.7/]
package require textutil

set fname [lindex $argv 0]
set h [open $fname r]
set theLines [split [read $h] \n]
close $h

#puts stdout "<!-- [llength $theLines] -->"

set last ""
set inCode 0
set c 0
set ender 0

proc doOpen { aTag } {
        global inCode
        global ender
        switch -exact -- $aTag {
                code    { 
                        puts -nonewline stdout "<span style=\"font-family: courier new;\"><pre><textarea rows=\"10\" cols=\"60\" readonly>"
                        set inCode 1 
                        }
                text    { puts -nonewline stdout "<span style=\"font-family: georgia;\">" }
                quot    { puts -nonewline stdout "<blockquote>" }
                end     { set ender 1
                          puts -nonewline stdout "" }
        }
}

proc doClose { aTag } {
        global inCode
        switch -exact -- $aTag {
                code    { puts -nonewline stdout "</textarea></pre></span>"
                          set inCode 0 }
                text    { puts -nonewline stdout "</span>" }
                quot    { puts -nonewline stdout "</blockquote>" }
                end     { puts -nonewline stdout "" }
        }
}


foreach l $theLines {
        incr c
        if {[string index $l 0] == "@"} {
                doClose $last
                set last [string range $l 1 end]
                doOpen $last
                if { $ender == 1 } { break }
        } else {
                if {$l == "" } {
                        if {$inCode == 0} {
                                puts -nonewline stdout "<br><br>"
                        } else {
                                puts stdout ""
                        }
                } else {
                        if {$inCode == 1} {     
                                puts stdout [string map { {&} {&amp;} {<} {&lt;} {>} {&gt;} } [::::textutil::untabify2 $l 8]]
                        } else {
                                puts -nonewline stdout $l
                        }
                }
        }
}
if {$last != "end"} {
        doClose $last
}

#puts stdout "<!-- $c -->"

This script inhales the file specified on the command line, splits it on newline and works its way through the lines, outputting HTML according to the rules of the markup: @ in column 1 identifies markup and there are currently four types: text, code, quot and end. Very simple, but it does me fine ... for now.

So after this runs, there's HTML in the fGenerated field. If I want to see how it's going to turn out in a browser, then I click on the Preview button. Okay, so it won't have all the CSS definitions that blogspot/blogger would apply but I get a useful approximation.

The script for the Preview button ...

on mouseUp
  put "/tmp/blog_" & random(65535)  & ".html" into fname
  open file fname for write
  write field fGenerated to file fname
  close file fname
  put shell("/usr/bin/open -a Safari " & fname ) into tmp
  --delete file fname
end mouseUp

... is similar to that of the Render button except this time I create an .html file in /tmp and and write the contents of the fGenerated field to it. I ignore the output of the shell() command.

I haven't quite figured out how to delete the temporary file because, if I uncomment the "delete file", by the time Safari is ready to load the file it's gone. There might be some way of making the shell synchronous, the way that /WAIT does on Win2k's START command, but then that'd probably mean waiting until Safari quits before I can use my blog writer again ... definitely sub-optimal. Then again, it'd be waiting for "open" to close, which happens as soon as it's launched Safari. And it's 10:48 pm and ...

Well, that's it. I really enjoyed this short break away from the long run of VBScript posts. I've got more stuff cooking here at home including a short foray into Javascript (a language I should have learned ages ago). Till then ...

[VBScript] function parameters

Things just got very interesting ... function parameters. This is where late binding helps. The mind reels: Dictionaries of references to procedure and function objects? sub bar( varParameter ) wscript.echo varParameter end sub sub foo( objFunction, varParameter ) objFunction varParameter end sub foo getref( "bar" ), 1

[VBScript] allsorts (not licorice)

Assorted sorts. I figured out I didn't need them after all. The BubbleSort is the slowest on large datasets. Sub BubbleSort( arr ) dim arr_j, arr_j1, i, j, temp for i = UBound(arr) - 1 To 0 Step -1 for j = 0 to i arr_j = arr( j ) arr_j1 = arr( j + 1 ) if arr_j > arr_j1 then temp=arr_j1 arr(j+1)=arr_j arr(j)=temp end if next next End Sub Sub QuickSort(vec,loBound,hiBound) Dim pivot,loSwap,hiSwap,temp '== This procedure is adapted from the algorithm given in: '== Data Abstractions & Structures using C++ by '== Mark Headington and David Riley, pg. 586 '== Quicksort is the fastest array sorting routine for '== unordered arrays. Its big O is n log n '~ http://4guysfromrolla.com/webtech/012799-2.shtml '== Two items to sort if hiBound - loBound = 1 then if vec(loBound) > vec(hiBound) then temp=vec(loBound) vec(loBound) = vec(hiBound) vec(hiBound) = temp End If End If '== Three or more items to sort pivot = vec(int((loBound + hiBound) / 2)) vec(int((loBound + hiBound) / 2)) = vec(loBound) vec(loBound) = pivot loSwap = loBound + 1 hiSwap = hiBound do '== Find the right loSwap while loSwap < hiSwap and vec(loSwap) <= pivot loSwap = loSwap + 1 wend '== Find the right hiSwap while vec(hiSwap) > pivot hiSwap = hiSwap - 1 wend '== Swap values if loSwap is less then hiSwap if loSwap < hiSwap then temp = vec(loSwap) vec(loSwap) = vec(hiSwap) vec(hiSwap) = temp End If loop while loSwap < hiSwap vec(loBound) = vec(hiSwap) vec(hiSwap) = pivot '== Recursively call function .. the beauty of Quicksort '== 2 or more items in first section if loBound < (hiSwap - 1) then Call QuickSort(vec,loBound,hiSwap-1) '== 2 or more items in second section if hiSwap + 1 < hibound then Call QuickSort(vec,hiSwap+1,hiBound) End Sub 'QuickSort Function ShellSort( ArrayToSort ) '~ http://www.adit.co.uk/html/a_question_of_sorts.html Dim SortLoop, ShellPoint Dim HoldValue, SortPoint ShellPoint = Lbound(ArrayToSort) Do Until ShellPoint > Ubound(ArrayToSort) ShellPoint = (3 * ShellPoint) + 1 Loop Do Until ShellPoint = Lbound(ArrayToSort) ShellPoint = ShellPoint / 3 For SortLoop = (ShellPoint + LBound(ArrayToSort)) To Ubound(ArrayToSort) HoldValue = ArrayToSort(SortLoop) SortPoint = SortLoop Do While (ArrayToSort(SortPoint - ShellPoint) > HoldValue) ArrayToSort(SortPoint) = ArrayToSort(SortPoint - ShellPoint) SortPoint = SortPoint - ShellPoint If SortPoint < ShellPoint Then Exit Do End If Loop ArrayToSort(SortPoint) = HoldValue Next Loop ShellSort = True End Function

[VBScript] using Watcher

And I've discovered that my Zerofill routine, which can be given any number of leading zeroes, never gets called with anything other than 2 leading zeroes. I discovered that by changing 'watch "Zerofill"' to 'watch "Zerofill." & nWidth'. Zerofill gets called > 700,000 times in a session.

So I create a new version of Zerofill Function Zerofill( nNum, nWidth ) Zerofill = Right( String( nWidth, "0" ) & nNum, nWidth ) End Function which I call Zerofill2 Function Zerofill2( nNum ) Zerofill2 = Right( "00" & nNum, 2) End Function and get a slight speed-up

[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

[VBScript] Map. Is there a more useless function?

Map is great for other languages. I've implemented it for no good reason. And I really can't think of a good use for it. Anyone? function map( arrSource, strOp ) Dim i Dim varItem Dim strEval Dim max Dim arrCopy arrCopy = arrSource max = UBound( arrCopy ) For i = 0 To max varItem = arrCopy( i ) strEval = Replace( strOp, "${item}", varItem ) arrCopy( i ) = Eval( strEval ) Next map = arrCopy End Function dim arr arr = map ( array(1,2,3,4,5,6,7,8,9),"${item}*${item}" ) 'arr now equals array(1,4,9,16,25,36,49,64,81)

[VBScript] Timer class

A class to set multiple timers and get back program run time in seconds, or as a nicely formatted hours-minutes-seconds. class StopWatch private dThen, dNow private bTicking private sub Class_Initialize() bTicking = False end sub public sub Start IF bTicking = False Then bTicking = True dThen = Now Else MsgBox "StopWatch already ticking" End If end sub public sub Finish If bTicking = True Then bTicking = False dNow = Now Else MsgBox "StopWatch not ticking" End If end sub public function StartTime() If bTicking = True Then StartTime = dThen Else MsgBox "StopWatch not started" StartTime = Empty End If end function public function FinishTime() If bTicking = False Then FinishTime = dNow Else MsgBox "StopWatch still ticking" FinishTime = Empty End If end function public function Seconds() If bTicking = False Then Seconds = DateDiff( "s", dThen, dNow ) Else MsgBox "StopWatching still ticking" Seconds = Empty End If end function public function LapTime() Dim dTemp, iHour, iMin, iSec if bTicking = False Then dTemp = DateAdd( "s", DateDiff( "s", dThen, dNow ), Empty ) iHour = Hour( dTemp ) iMin = Minute( dTemp ) iSec = Second( dTemp ) LapTime = iHour & "h " & iMin & "m " & iSec & "s" Else MsgBox "StopWatch still ticking" LapTime = Empty End If end function end class An example: dim ticker set ticker = new stopwatch ticker.start WScript.Echo ticker.StartTime() 'Waste a lot of time uselessly For i = 1 to 100000 str = Join( Split( Join( Split( "1.2.3.4.5.6.7.8.9.0.1.2.3.4.5.6.7.8.9.0...........","."),"."),"."),".") next ticker.Finish WScript.Echo ticker.FinishTime() WScript.Echo ticker.Laptime() ... which gave (at time of testing) ... 19/09/2005 4:04:11 PM 19/09/2005 4:04:18 PM 0h 0m 7s

[VBScript] Classes, classes, classes

Over at Win32Scripting where I've been hanging out of late, some bright spark, Tony Hinkle by name, put up code to

"Use IE as an output device! This script is an example of how to make a DIV element an object and then change the innerHTML property. This is a vbs file, not an .asp file. ..."

Being adventurous, I turned it into a class and added a bit of WMI to get the screen dimensions. class IEDisplay '~ Based on original work by Tony Hinkle, tonyhinkle@yahoo.com private TEMPORARY_FOLDER private objShell private objIE private objFSO private objFolder private strName private streamOut private objDIV private numHeight private numWidth private numTop private numLeft private sub Class_Initialize() Dim strComputer Dim objWMIService Dim colItems Dim objItem Dim arrMonitors( 10, 1 ) Dim numMonitorCount Set objShell = WScript.CreateObject("WScript.Shell") Set objIE = CreateObject("InternetExplorer.Application") strComputer = "." Set objWMIService = GetObject( "winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery( "Select * from Win32_DesktopMonitor") numMonitorCount = 0 For Each objItem in colItems arrMonitors( numMonitorCount, 0 ) = objItem.ScreenHeight arrMonitors( numMonitorCount, 1 ) = objItem.ScreenWidth numMonitorCount = numMonitorCount + 1 Next numHeight = arrMonitors( 0, 0 ) numWidth = arrMonitors( 0, 1 ) '~ MsgBox numHeight & " " & numWidth Set objFSO = CreateObject("Scripting.FileSystemObject") TEMPORARY_FOLDER = 2 set objFolder = objFSO.GetSpecialFolder( TEMPORARY_FOLDER ) '~ strName = objFolder.Path & "\" & objFSO.GetTempName & ".html" strName = objFSO.GetTempName '~ WScript.Echo strName set streamOut = objFolder.CreateTextFile( strName, True ) streamOut.WriteLine("<HTML><HEAD><TITLE>Information</TITLE></HEAD>") streamOut.WriteLine("<BODY SCROLL='NO'><CENTER><FONT FACE='arial black'> <HR COLOR='BLACK'>") streamOut.WriteLine("<DIV id='MakeMeAnObject'></DIV>") streamOut.WriteLine("<HR COLOR='BLACK'></FONT></CENTER></BODY></HTML>") streamOut.Close numTop = 0 numLeft = 0 end sub Sub Init( strPosition ) 'NW, N, NE, W, CENTRE, E, SW, S, SE Select Case strPosition Case "NW" numTop = 0 numLeft = 0 Case "N" numTop = 0 numLeft = ( numWidth / 2 ) - 250 Case "NE" numTop = 0 numLeft = numWidth - 500 Case "W" numTop = ( numHeight / 2 ) - 55 numLeft = 0 Case "CENTRE" numTop = ( numHeight / 2 ) - 55 numLeft = ( numWidth / 2 ) - 250 Case "E" numTop = ( numHeight / 2 ) - 55 numLeft = numWidth - 500 Case "SW" numTop = numHeight - 110 numLeft = 0 Case "S" numTop = numHeight - 110 numLeft = ( numWidth / 2 ) - 250 Case "SE" numTop = numHeight - 110 numLeft = numWidth - 500 Case Else numTop = 0 numLeft = 0 End Select SetupIE( objFolder.Path & "\" & strName ) Set objDIV = objIE.Document.All("MakeMeAnObject") '~ wscript.echo typename(objdiv) end sub private sub Class_Terminate() 'Close IE and delete the file objIE.Quit '~ optionally you may want to get rid of the temp file end sub public sub Display( strMsg, numMillisec ) '~ wscript.echo typename(objdiv) '~ MsgBox TypeName( numMillisec ) objDIV.InnerHTML = strMsg WScript.Sleep numMillisec end sub Private Sub SetupIE(File2Load) objIE.Navigate File2Load objIE.ToolBar = False objIE.StatusBar = False objIE.Resizable = False Do Loop While objIE.Busy objIE.Width = 500 objIE.Height = 110 objIE.Left = numLeft objIE.Top = numTop objIE.Visible = True objShell.AppActivate("Microsoft Internet Explorer") End Sub end class And some test code which puts boxes at 9 different points on the screen: set x = new iedisplay dim a a = split("NE,N,NW,SE,S,SW,E,CENTRE,W",",") for i = 0 to ubound(a) x.Init a(i) x.Display "Woof",10 next

[VBScript] Helping out with wildcarded directory searches

At Emulate The Dir Command Via Vbscript... ( Vbscript ) Christian D'heureuse had written a ListDir Function to list files using wildcards. Someone else wanted filtration and another suggested regular expressions. The following works a little faster than the latter and gives fine control over what is acceptable and what is not.

The following collects all the files to a comma delimited list (you may want to put it in an array). Function CollectFiles( theDirectory ) Dim oFSO, oDir, oFiles, aFile Dim theResult Dim a(), i theResult = "" Set oFSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set oDir = oFSO.GetFolder( theDirectory ) Set oFiles = oDir.Files If Err.Number = 0 Then ReDim a( oFiles.Count - 1) i = 0 For Each aFile in oFiles a( i ) = aFile.Path '& "\" & aFile.Name i = i + 1 Next theResult = Join( a, "," ) End If CollectFiles = theResult End Function I then used this function to do the filtration Function PassedThroughFilters( strString, ByRef arrInclude, ByRef arrExclude ) Dim bResult Dim bDone Dim arrFilter Dim i bResult = False bDone = False For i = 0 To UBound( arrExclude ) arrFilter = arrExclude( i ) If BeginsWith( strString, arrFilter( 0 ), True ) And EndsWith( strString, arrFilter( 1 ), True ) Then bResult = False bDone = True Exit For End If Next If bDone = False Then 'not excluded, will it be included? For i = 0 To UBound( arrInclude ) arrFilter = arrInclude( i ) If BeginsWith( strString, arrFilter( 0 ), True ) And EndsWith( strString, arrFilter( 1 ), True ) Then bResult = True bDone = True Exit For End If Next End If PassedThroughFilters = bResult End Function and tied it all together as below (this is cut from a project file and the ellipses indicate code removed.) strDir = ParseEnvVar( strDir ) WScript.Echo "Collecting files in " & strDir strFiles = CollectFiles( ParseEnvVar( strDir ) ) arrFiles = Split( strFiles, "," ) arrFilesCount = UBound( arrFiles ) ... iFileCount = 0 For i = 0 To arrFilesCount If iFileCount = 0 Then strOutput = strAllExtras End If strFilename = arrFiles( i ) If PassedThroughFilters( BaseName( strFilename ), arrInclude, arrExclude ) = True Then WScript.Echo "Accepted: " & strFilename Log "Accepted: " & strFilename iFileCount = iFileCount + 1 ... Else Log "Rejected: " & strFilename End If Next The inclusions and exclusions are handled through arrays, and in my project these were drawn from .ini files, a part of which is recorded below [Filters] ExcludeCount=7 Exclude1=car_*0103.xls Exclude2=car_*0203.xls Exclude3=car_*0303.xls Exclude4=car_*0403.xls Exclude5=car_*0503.xls Exclude6=car_*0603.xls Exclude7=*.rar IncludeCount=16 Include1=car_210703.xls Include2=car_220703.xls Include3=car_230703.xls Include4=car_240703.xls Include5=car_250703.xls Include6=car_260703.xls Include7=car_270703.xls Include8=car_280703.xls Include9=car_290703.xls Include10=car_300703.xls Include11=car_310703.xls Include12=car_*0803.xls Include13=car_*0903.xls Include14=car_*1003.xls Include15=car_*1103.xls Include16=car_*1203.xls This all ran fairly fast and is better for speed than a regular expression mechanism, albeit at the cost of code size.

[VBScript] Helping out with DateDiff

Another from helping out at Automate Excel In Vbscript... ( Vbscript )

Please tell me how to subtract to time values. eg: 10.15 AM - (minus)8.30 Am Using example explain me

The DateDiff function is the one to use in this case. Using your data

a = "10:15 AM" b = "8:30 Am" c = datediff( "s", b, a ) ' the seconds between the two times c = datediff( "n", b, a ) 'the minutes between the two times (because "m" stands for months) c = datediff( "h", b, a ) ' the hours between the two times

[Neko] Check it out!

For another take on the Virtual Machine idea, see "Neko" via the weblog of it's creator Nicolas Cannasse

[VBScript] Evaluator

A quick scripting environment so that I could bash out a few lines, get the results easily and put them on the clipboard.

Have been using the Vrode Editor 1.1 for HTA development.

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML><HEAD><TITLE>Evaluator</TITLE> <META http-equiv=Content-Type content="text/html; charset=windows-1252"><HTA:APPLICATION id=oHTA selection="yes" windowState="normal" singleInstance="yes" showInTaskBar="yes" scrollFlat="no" scroll="no" navigable="yes" minimizeButton="yes" maximizeButton="no" innerBorder="yes" caption="yes" borderStyle="sunken" border="thick" applicationName="Evaluator" SYSMENU="yes" CONTEXTMENU="yes"> <SCRIPT language=VBScript> ReSizeTo 615, 520 Sub Window_Onload theScript.focus End Sub Sub bEvaluate_Click Dim aScript aScript = theScript.value aScript = Replace( aScript, "$RET$", "tResult.value" ) ExecuteGlobal aScript End Sub Sub bCopy_Click() if tResult.Value = "" Then MsgBox "Can't copy nothing.",,"Evaluator2" Else document.parentwindow.clipboardData.SetData "text", tResult.Value End If End Sub </SCRIPT> <META content="MSHTML 6.00.2800.1480" name=GENERATOR></HEAD> <BODY><TEXTAREA id=theScript rows=13 cols=70></TEXTAREA> <P>Put "$RET$ into the script as the destination of any calculations. For example<BR>&nbsp;&nbsp;&nbsp;&nbsp;dim pi: pi = 4 * atn(1):$RET$=pi</P> <P align=center><INPUT id=bEvaluate onclick=bEvaluate_Click type=button value=Evaluate></P><TEXTAREA id=tResult style="WIDTH: 580px; HEIGHT: 90px" name=tResult rows=4 cols=62></TEXTAREA> <P align=center><INPUT id=bCopy onclick=bCopy_Click type=button value="Copy to Clipboard"></P></BODY></HTML>

[VBScript and Excel] Relative/Absolute references

Again at Automate Excel In Vbscript... ( Vbscript ), Pentium10 wrote

I have a script which fills cells with exce.range.value function, but I have columns more than A-Z, how can I handle AA,AB, AC... columns???

Here is the script what I have:
excel.Range(chr(65+i) + str(excelrow), chr(65+i) + _
 str(excelrow)).value = lstOrder.cell(i,1)

And I wrote:

Re: I have a script which fills cells with ...

Function RelativeToAbsolute( aRow, aCol ) Dim alpha alpha = Split( "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", "," ) RelativeToAbsolute = alpha( aCol - 1 ) & aRow End Function That does me, but for you I'd suggest adding a few more items to the Split(). After Z put in ",AA,AB,AC," etc until you have what you need. Then code your references in terms of numeric column and a row and let the function generate a meaningful address.

For example: strRange = RelativeToAbsolute( 1, 1 ) & ":" & RelativeToAbsolute( 1 + iCount - 1, 1 ) oSheet.Range( strRange ).NumberFormat = "d/m/yyyy h:mm:ss" (iCount in this case is the number of rows in an array I was committing to the spreadsheet.)

[VBScript and Excel] Moving a sheet to the end of the list

Here's how to put the first sheet in a new spreadsheet at the end. This is a copy of a recent submission of mine at Automate Excel In Vbscript... ( Vbscript ) Set oExcel = CreateObject("Excel.Application") Set oWorkBook = oExcel.Workbooks.Add oWorkbook.Sheets("Sheet1").Move ,oWorkbook.Sheets( oWorkbook.Sheets.Count ) Note the comma after the space that is after the .Move. I'm specfying the "after" clause rather than the "before" and saying to move the sheet to after the last.

BTW, one of the best ways of finding out syntax is to record a macro and adapt the resulting code.

[VBScript] Sorting agonies

After hours spent trying this algorithm and that algorithm, trying Bubble sort (too slow for my massive datasets), QuickSort (which dies from lack of stack space), and ShellSort (which runs at least), I finally stumble over something completely different: Sorting Data by Using a Disconnected Recordset.

After you read the Microsoft blurb, check out what DevGuru has to say about .Sort: PROPERTY: Recordset::Sort.

It's good, but sometimes it seems I spend ages looking for something on the 'net, implementing what I find and then stumble over what I needed in the first place when looking for something else. Aarrrgghh!

To cap the whole episode off, I find I don't need a sort at all! Access will actually protect its indexes whether I "SELECT * FROM" or whether I "SELECT TOP 1 * FROM".

"I'm a teapot, I'm a teapot ..."

[VBScript/HTA] More Broggle

The next version of Broggle with the readonly textarea for the code.

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML><HEAD> <HTA:APPLICATION id=oHTA scroll="yes" showInTaskBar="yes" caption="yes" applicationName="Broggle" CONTEXTMENU="yes" SYSMENU="yes" singleInstance="yes" maximizeButton="no"> <SCRIPT language=VBScript> ResizeTo 631,500 Dim lastMark Dim inCode Function stopMarkup( mark ) Dim res Select Case mark Case "code" res = "</textarea>" inCode = False Case "quot" res = "</blockquote>" Case "text" res = "</span>" case "end" res = "" End Select stopMarkup = res End Function Function startMarkup( mark ) Dim res res = stopMarkup( lastMark ) Select Case mark Case "code" res = res & "<textarea cols=""60"" rows=""20"" style=""width: 100%; height: 500px;"" wrap=""off"" readonly>" inCode = True Case "quot" res = res & "<blockquote>" Case "text" res = res & "<span style=""font-family: georgia;"">" case "end" res = res & "" End Select startMarkup = res End Function Sub Evaluate( theText ) Dim theList, theMax, i, theLine Dim theResult Dim theTemp Dim markup theResult = "" theList = Split( theText, vbCRLF ) theMax = UBound( theList ) lastMark = "" inCode = False For i = 0 to theMax theLine = theList( i ) If Left( theLine, 1 ) = "#" Then markup = Mid( theLine, 2 ) TheResult = theResult & startMarkup( markup ) lastMark = markup Else If theLine = "" And InCode = False Then theResult = theResult & "<BR><BR>" Else If inCode = True Then theTemp = theLine If theTemp = "" Then ' theTemp = "<BR><BR>" theTemp = vbCrLf Else theTemp = Replace( theTemp, "&", "&amp;" ) theTemp = Replace( theTemp, "<", "&lt;" ) theTemp = Replace( theTemp, ">", "&gt;" ) End If theResult = theResult & theTemp & vbCRLF Else theResult = theResult & theLine & vbCRLF End If End If End If 'MsgBox theResult Next if lastMark <> "end" Then theResult = theResult & stopMarkup( lastMark ) tSlave.value = theResult End Sub Sub bEvaluate_Click() if tMaster.value = "" Then MsgBox "Can't evaluate nothing",,"Broggle" Else Evaluate tMaster.value End If End Sub Sub bCopy_Click() if tSlave.Value = "" Then MsgBox "Can't copy nothing.",,"Broggle" Else document.parentwindow.clipboardData.SetData "text", tSlave.Value End If End Sub Sub bPreview_Click If tSlave.Value <> "" Then preview.innerHTML = tSlave.Value End If End Sub Sub bScreen_Click v3.Value = document.body.clientHeight v4.Value = document.body.clientWidth End Sub </SCRIPT> </HEAD> <BODY> <P><TEXTAREA id=tMaster style="WIDTH: 578px; HEIGHT: 130px" name=tMaster rows=6 cols=61></TEXTAREA>&nbsp;</P> <P><TEXTAREA id=tSlave style="WIDTH: 579px; HEIGHT: 166px" name=tSlave rows=8 cols=62></TEXTAREA>&nbsp;</P> <P><INPUT id=bEvaluate onclick=bEvaluate_Click type=button value=Convert name=bEvaluate>&nbsp; <INPUT id="bPreview" onclick="bPreview_Click" type=button value="Preview">&nbsp; <INPUT id=bCopy onclick=bCopy_Click type=button value="Copy to Clipboard"></P> <HR> <DIV id="preview"></DIV> </BODY></HTML>

[SNOBOL4] Parsing text: OnLine Bible to text markup

As a SNOBOL4 script, this gets about as far as I got before getting sidetracked again into other languages. This is a filter converting the NOTES file out of my pre-OSX version of OnLine Bible into docScript, a markup language for my own version (written in REALbasic 3) of Will Duquette's brilliant Notebook.

* notes.sno * parse NOTES file, creating a docScript index page and a list of dependant * docScript pages * * NOTES contains an FF followed by a bible ref followed by a LF followed by * free text until the next FF &amp;TRIM = 1 &amp;ANCHOR = 0 C_FF = CHAR( 12 ) C_CR = CHAR( 13 ) C_LF = CHAR( 10 ) CNT = 0 OFFSET1 = 0 OFFSET2 = 0 PATH = '/Users/bruceaxt/Documents/BrainBucket/docScript/' KEYFILE = PATH "olbstuff.rbt" HDR = '^MClearEdit()^MSetSize(10)^MSetBold(false)^MSetCondense(false)^M' + 'SetExtend(false)^MSetItalic(false)^MSetOutline(false)^MSetShadow(false)^M' + 'SetUnderline(false)^MSetFont("Monaco")^MSetRed(0)^MSetGreen(0)^MSetBlue(0)^M' CVTHDR HDR '^M' = C_CR :S(CVTHDR) BUFFER = INPUT(.NOTES,IO_FINDUNIT(),'B,4096','NOTES') OUTPUT(.KEYFILE,IO_FINDUNIT(),'B',KEYFILE) DEFINE('WRITEFILE(CHUNK)OFFSET') DEFINE('SETTEXT(TEXT)') DEFINE('BLUEON()') DEFINE('BLUEOFF()') KEYFILE = "'olbstuff" C_CR HDR MAIN LINE = NOTES :F(BUFFLD) BUFFER = BUFFER LINE :(MAIN) * At this point we have BUFFER containing the entire text of the file. * Now break at every after the first FF and put that into a file. BUFFLD BUFFER C_FF @OFFSET2 :F(ENDDATA) BUFFER TAB(OFFSET2 - 1) . CHUNK LEN(1) REM . BUFFER WRITEFILE(CHUNK) NOLF CNT = CNT + 1 :(BUFFLD) <br><br>* At this point we have a chunk. Let's see whether the first line contains * anything useful ENDDATA WRITEFILE(BUFFER) * WRITECHUNK(CNT,CHUNK) ENDMAIN :(END) SETTEXT TEXT '"' = '&amp;quot;' :S(SETTEXT) SETTXT2 TEXT '&lt;' = '&amp;lt;' :S(SETTXT2) SETTXT3 TEXT '&gt;' = '&amp;gt;' :S(SETTXT3) SETTXT4 TEXT CHAR(0) = :S(SETTXT4) SETTXT5 TEXT C_LF = '&amp;return;' :S(SETTXT5) SETTEXT = 'settext("' TEXT '")' C_CR :(RETURN) BLUEON BLUEON = 'setblue(255)' C_CR :(RETURN) BLUEOFF BLUEOFF = 'setblue(0)' C_CR :(RETURN) WRITEFILE CHUNK C_LF @OFFSET :F(WF_NOLF) CHUNK TAB(OFFSET - 1) . HEADER LEN(1) REM . CHUNK CLEAN HEADER ':' = '.' :S(CLEAN) CLEAN2 HEADER ' ' = '' :S(CLEAN2) KEYFILE = SETTEXT('[') BLUEON() SETTEXT(HEADER) + BLUEOFF() SETTEXT(']&amp;return;') C_CR WF_NOLF OUTPUT(.OUTFILE,IO_FINDUNIT(),'B',PATH HEADER ".rbt") CLEAN3 TEXT C_LF = '&amp;return;' :S(CLEAN3) OUTFILE = "'" HEADER C_CR HDR SETTEXT(CHUNK) :(RETURN) END

[Cygwin] using Cygwin to make .cmd files. Eeeww...

Actually the whole thing is a bizarre mix of Cygwin, Win2k CMD and Euphoria. When I get some more time I'll go into the issue a little more deeply. Here's the line that the title refers to:
find . -name "*.dly" -exec basename {} .dly \; | gawk '{ print "call fix DLY" $1 }' | unix2dos >fixdly.cmd

[VBScript/HTA] Broggle on Steroids

Big changes to Broggle.hta. No more #code/#endcode etc. Just #text, #code, #quot and #end. Now the HTA is more in line with the MetaCard and Tcl version at home on the iBook. I've also put in a preview button (which should probably be somewhere other than where it is right now) which puts the conversion results into a <DIV> at the bottom (thus the scrollbar at the side.)

Enjoy
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML><HEAD> <HTA:APPLICATION id=oHTA scroll="yes" showInTaskBar="yes" caption="yes" applicationName="Broggle" CONTEXTMENU="yes" SYSMENU="yes" singleInstance="yes" maximizeButton="no"> <SCRIPT language=VBScript> ResizeTo 631,500 Dim lastMark Dim inCode Function stopMarkup( mark ) Dim res Select Case mark Case "code" res = "</pre></span>" inCode = False Case "quot" res = "</blockquote>" Case "text" res = "</span>" case "end" res = "" End Select stopMarkup = res End Function Function startMarkup( mark ) Dim res res = stopMarkup( lastMark ) Select Case mark Case "code" res = res & "<span style=""font-family: courier new;""><pre>" inCode = True Case "quot" res = res & "<blockquote>" Case "text" res = res & "<span style=""font-family: georgia;"">" case "end" 'If lastMark = "code" or lastMark = "text" Then ' res = res & "</span>" 'Else res = res & "" 'End If End Select startMarkup = res End Function Sub Evaluate( theText ) Dim theList, theMax, i, theLine Dim theResult Dim theTemp Dim markup theResult = "" theList = Split( theText, vbCRLF ) theMax = UBound( theList ) lastMark = "" inCode = False For i = 0 to theMax theLine = theList( i ) If Left( theLine, 1 ) = "#" Then markup = Mid( theLine, 2 ) TheResult = theResult & startMarkup( markup ) lastMark = markup Else If theLine = "" Then theResult = theResult & "<BR><BR>" Else If inCode = True Then theTemp = theLine If theTemp = "" Then theTemp = "<BR><BR>" Else theTemp = Replace( theTemp, "&", "&amp;" ) theTemp = Replace( theTemp, "<", "&lt;" ) theTemp = Replace( theTemp, ">", "&gt;" ) End If theResult = theResult & theTemp & vbCRLF Else theResult = theResult & theLine & vbCRLF End If End If End If 'MsgBox theResult Next if lastMark <> "end" Then theResult = theResult & stopMarkup( lastMark ) tSlave.value = theResult End Sub Sub bEvaluate_Click() if tMaster.value = "" Then MsgBox "Can't evaluate nothing",,"Broggle" Else Evaluate tMaster.value End If End Sub Sub bCopy_Click() if tSlave.Value = "" Then MsgBox "Can't copy nothing.",,"Broggle" Else document.parentwindow.clipboardData.SetData "text", tSlave.Value End If End Sub Sub bPreview_Click If tSlave.Value <> "" Then preview.innerHTML = tSlave.Value End If End Sub Sub bScreen_Click v3.Value = document.body.clientHeight v4.Value = document.body.clientWidth <BR><BR>End Sub </SCRIPT> </HEAD> <BODY> <P align=left><INPUT id=bEvaluate onclick=bEvaluate_Click type=button value=Convert name=bEvaluate></P> <P><TEXTAREA id=tMaster style="WIDTH: 578px; HEIGHT: 130px" name=tMaster rows=6 cols=61></TEXTAREA>&nbsp;</P> <P><TEXTAREA id=tSlave style="WIDTH: 579px; HEIGHT: 166px" name=tSlave rows=8 cols=62></TEXTAREA>&nbsp;</P> <P><INPUT id=bCopy onclick=bCopy_Click type=button value="Copy to Clipboard">&nbsp;<INPUT id="bPreview" onclick="bPreview_Click" type=button value="Preview"></P> <HR> <DIV id="preview"></DIV> </BODY></HTML>

[VBScript] Classes in VBScript, the definitive article?

Article Information
Article Title:	4GuysFromRolla.com - Using Classes within VBScript
Article Author:	Mark Lidstone
Published Date:	Thursday, September 23, 1999
Article URL:	http://www.4GuysFromRolla.com/webtech/092399-1.shtml

[VBScript] Changes to existing stuff

Just a couple of changes. To the Container class I've added

    public sub Clear
        redim vat(0)
        itemCount = 0
    end sub

and I forgot to include the DQuote for PArray

Function DQuote( aText )
    DQuote = Chr( 34 ) & aText & Chr( 34 )
End Function

[VBScript] Arrays within arrays and debugging them

Array() can contain Array(). I do it lots. But there's the issue of debugging things and of knowing what's in an array full of embedded arrays.

So I wrote PArray(). Function PArray( anArray ) Dim i Dim elem Dim res res = "{" For i = 0 to UBound( anArray ) elem = anArray( i ) IF IsArray( elem ) Then res = res & PArray( elem ) else res = res & IIF( IsNumeric( elem ), elem, DQuote( elem ) ) & "," end if Next If Right( res, 1 ) = "," Then res = Left( res, Len( res ) - 1 ) PArray = res & "}" End Function Tcl has a function of the same name which does the same thing. And the output looks very like an Euphoria sequence (now there's a nice language) but you can change that if you want to.

I suppose the next thing to do is to write a compiler of PArray() decompilations that would allow me to write nested arrays out to a text file and then read them back in. One day.

[VBScript] My first class

A "Container" class, which I can add stuff to and then pull it all out nicely Join()-ed or else as a raw array. class Container private vat() private itemCount private sub Class_Initialize() itemCount = 0 end sub private sub Class_Terminate() end sub public sub Import( cText ) redim preserve vat( itemCount ) vat( itemCount ) = cText itemCount = itemCount + 1 end sub public function Export( punctuatedBy ) Export = Join( vat, punctuatedBy ) end function public function Raw() Raw = vat end function end class And the nice thing is I can have multiple collections rather than the single instance thing I had a couple of days ago. Some test code ran like this: dim c1, c2 Set c1 = New Container Set c2 = New Container For i = 1 to 100 c1.Import i c2.Import i ^ i Next WScript.Echo Join( c1.Raw(), "," ) WScript.Echo c2.Export( ":" )

Template changes

Right, now we have black code instead of that faded out look. I think I'm finally starting to get the hang of CSS.

Good news about Modula-2 on Mac OS X

Hooray! Finally I get to leverage all my Modula-2 skill into the Mac OS X environment. Bring on the Objective Modula-2!! Objective Modula-2 and An Overview of Objective Modula-2 by the founder of the project, Benjamin Kowarsch. http://en.wikipedia.org/wiki/Objective_Modula-2 See also Objective Modula-2 – A Discussion and Working Paper

Leftovers after a meal of Bruce the Goose

I had a blog. It was called "Bruce the Goose" (aka Virtual Unknowns) and it listed programming languages and tried unsuccessfully to keep up with them all. The names of all that I found are in the links list on the left. If you find any dead links or want to suggest additions or changes, please contact me.

Broggle - a blogging tool in an HTML application

Okay, now a quick shift from straight VBScript to VBScript inside an HTML application. It's to deal with formatting issues I have with Blogger. The solution is probably way simpler than this.

Saved as Broggle.hta and then double-click launched in Explorer.

Just put "#code" and "#endcode" around code and "#text" and "#endtext" around text, click on [Evaluate], then click on [Copy to Clipboard], and then paste into the blog. <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML><HEAD> <META http-equiv=Content-Type content="text/html; charset=windows-1252"> <META content="MSHTML 6.00.2800.1480" name=GENERATOR> <HTA:APPLICATION id=oHTA scroll="no" showInTaskBar="yes" caption="yes" applicationName="Broggle" CONTEXTMENU="yes" SYSMENU="yes" singleInstance="yes" maximizeButton="no"> <SCRIPT language=VBScript> Sub Evaluate( theText ) Dim theList, theMax, i, theLine Dim theResult Dim inCode Dim theTemp theResult = "" theList = Split( theText, vbCRLF ) theMax = UBound( theList ) inCode = False For i = 0 to theMax theLine = theList( i ) If Left( theLine, 5 ) = "#text" Then theResult = theResult & "<span style=""font-family: georgia;"">" ElseIf Left( theLine, 8 ) = "#endtext" Then theResult = theResult & "</span><br><br>" ElseIf Left( theLine, 5 ) = "#code" Then theResult = theResult & "<span style=""font-family: courier new;""><pre>" inCode = True ElseIf Left( theLine, 8 ) = "#endcode" Then theResult = theResult & "</pre></span><br><br>" inCode = False ElseIf theLine = "" Then If inCode = False Then theResult = theResult & "<br><br>" & vbCRLF Else theResult = theResult & vbCRLF End If Else If inCode = True Then theTemp = theLine theTemp = Replace( theTemp, "&", "&amp;" ) theTemp = Replace( theTemp, "<", "&lt;" ) theTemp = Replace( theTemp, ">", "&gt;" ) theResult = theResult & theTemp & vbCRLF Else theResult = theResult & theLine & vbCRLF End If End If 'MsgBox theResult Next tSlave.value = theResult End Sub Sub bEvaluate_Click() if tMaster.value = "" Then MsgBox "Can't evaluate nothing",,"Broggle" Else Evaluate tMaster.value End If End Sub Sub bCopy_Click() if tSlave.Value = "" Then MsgBox "Can't copy nothing.",,"Broggle" Else document.parentwindow.clipboardData.SetData "text", tSlave.Value End If End Sub </SCRIPT> </HEAD> <BODY> <P><INPUT id=bEvaluate onclick=bEvaluate_Click type=button value=Evaluate name=bEvaluate></P> <P><TEXTAREA id=tMaster style="WIDTH: 578px; HEIGHT: 130px" name=tMaster rows=6 cols=61></TEXTAREA>&nbsp;</P> <P><TEXTAREA id=tSlave style="WIDTH: 579px; HEIGHT: 166px" name=tSlave rows=8 cols=62></TEXTAREA>&nbsp;</P> <P><INPUT id=bCopy onclick=bCopy_Click type=button value="Copy to Clipboard"></P> <P>&nbsp;</P></BODY></HTML>

How I used the CalculateState function

It's awful, and I'm glad I don't have to follow this any further. By the way, if you see any routines you would like to see elucidated, please let me know. Sub Check( ByVal theTable, ByVal theDate, ByRef theConn ) Dim oR1, oR2, oR3, oR4 Dim aDate1, aDate2, aDate3, aDate4 Dim kw1, kw2, kw3, kw4 Dim theRule Dim theDateComponents theDate = DateComponents( theDate ) Select Case Year( theDate ) Case 2001 aDate1 = DateAdd( "yyyy", 1, theDate ) '2002 OpenRecordSet2 theConn, oR1, SelectKW( theTable, Year( aDate1 ), Month( aDate1 ), Day( aDate1 ), Hour( aDate1 ), Minute( aDate1 ), 0 ) If oR1.RecordCount > 0 Then kw1 = oR1("kw") Else kw1 = 0 End If aDate2 = DateAdd( "yyyy", 2, theDate ) '2003 OpenRecordSet2 theConn, oR2, SelectKW( theTable, Year( aDate2 ), Month( aDate2 ), Day( aDate2 ), Hour( aDate2 ), Minute( aDate2 ), 0 ) If oR2.RecordCount > 0 Then kw2 = oR2("kw") Else kw2 = 0 End If aDate3 = DateAdd( "yyyy", 3, theDate ) '2004 OpenRecordSet2 theConn, oR3, SelectKW( theTable, Year( aDate3 ), Month( aDate3 ), Day( aDate3 ), Hour( aDate3 ), Minute( aDate3 ), 0 ) If oR3.RecordCount > 0 Then kw3 = oR3("kw") Else kw3 = 0 End If aDate4 = DateAdd( "yyyy", 4, theDate ) '2005 OpenRecordSet2 theConn, oR4, SelectKW( theTable, Year( aDate4 ), Month( aDate4 ), Day( aDate4 ), Hour( aDate4 ), Minute( aDate4 ), 0 ) If oR4.RecordCount > 0 Then kw4 = oR4("kw") Else kw4 = 0 End If Case 2002 aDate1 = DateAdd( "yyyy", -1, theDate ) '2001 OpenRecordSet2 theConn, oR1, SelectKW( theTable, Year( aDate1 ), Month( aDate1 ), Day( aDate1 ), Hour( aDate1 ), Minute( aDate1 ), 0 ) If oR1.RecordCount > 0 Then kw1 = oR1("kw") Else kw1 = 0 End If aDate2 = DateAdd( "yyyy", 1, theDate ) '2003 OpenRecordSet2 theConn, oR2, SelectKW( theTable, Year( aDate2 ), Month( aDate2 ), Day( aDate2 ), Hour( aDate2 ), Minute( aDate2 ), 0 ) If oR2.RecordCount > 0 Then kw2 = oR2("kw") Else kw2 = 0 End If aDate3 = DateAdd( "yyyy", 2, theDate ) '2004 OpenRecordSet2 theConn, oR3, SelectKW( theTable, Year( aDate3 ), Month( aDate3 ), Day( aDate3 ), Hour( aDate3 ), Minute( aDate3 ), 0 ) If oR3.RecordCount > 0 Then kw3 = oR3("kw") Else kw3 = 0 End If aDate4 = DateAdd( "yyyy", 3, theDate ) '2005 OpenRecordSet2 theConn, oR4, SelectKW( theTable, Year( aDate4 ), Month( aDate4 ), Day( aDate4 ), Hour( aDate4 ), Minute( aDate4 ), 0 ) If oR4.RecordCount > 0 Then kw4 = oR4("kw") Else kw4 = 0 End If Case 2003 aDate1 = DateAdd( "yyyy", -2, theDate ) '2001 OpenRecordSet2 theConn, oR1, SelectKW( theTable, Year( aDate1 ), Month( aDate1 ), Day( aDate1 ), Hour( aDate1 ), Minute( aDate1 ), 0 ) If oR1.RecordCount > 0 Then kw1 = oR1("kw") Else kw1 = 0 End If aDate2 = DateAdd( "yyyy", -1, theDate ) '2002 OpenRecordSet2 theConn, oR2, SelectKW( theTable, Year( aDate2 ), Month( aDate2 ), Day( aDate2 ), Hour( aDate2 ), Minute( aDate2 ), 0 ) If oR2.RecordCount > 0 Then kw2 = oR2("kw") Else kw2 = 0 End If aDate3 = DateAdd( "yyyy", 1, theDate ) '2004 OpenRecordSet2 theConn, oR3, SelectKW( theTable, Year( aDate3 ), Month( aDate3 ), Day( aDate3 ), Hour( aDate3 ), Minute( aDate3 ), 0 ) If oR3.RecordCount > 0 Then kw3 = oR3("kw") Else kw3 = 0 End If aDate4 = DateAdd( "yyyy", 2, theDate ) '2005 OpenRecordSet2 theConn, oR4, SelectKW( theTable, Year( aDate4 ), Month( aDate4 ), Day( aDate4 ), Hour( aDate4 ), Minute( aDate4 ), 0 ) If oR4.RecordCount > 0 Then kw4 = oR4("kw") Else kw4 = 0 End If Case 2004 aDate1 = DateAdd( "yyyy", -3, theDate ) '2001 OpenRecordSet2 theConn, oR1, SelectKW( theTable, Year( aDate1 ), Month( aDate1 ), Day( aDate1 ), Hour( aDate1 ), Minute( aDate1 ), 0 ) If oR1.RecordCount > 0 Then kw1 = oR1("KW") Else kw1 = 0 End If aDate2 = DateAdd( "yyyy", -2, theDate ) '2002 OpenRecordSet2 theConn, oR2, SelectKW( theTable, Year( aDate2 ), Month( aDate2 ), Day( aDate2 ), Hour( aDate2 ), Minute( aDate2 ), 0 ) If oR2.RecordCount > 0 Then kw2 = oR2("kw") Else kw2 = 0 End If aDate3 = DateAdd( "yyyy", -1, theDate ) '2003 OpenRecordSet2 theConn, oR3, SelectKW( theTable, Year( aDate3 ), Month( aDate3 ), Day( aDate3 ), Hour( aDate3 ), Minute( aDate3 ), 0 ) If oR3.RecordCount > 0 Then kw3 = oR3("kw") Else kw3 = 0 End If aDate4 = DateAdd( "yyyy", 1, theDate ) '2005 OpenRecordSet2 theConn, oR4, SelectKW( theTable, Year( aDate4 ), Month( aDate4 ), Day( aDate4 ), Hour( aDate4 ), Minute( aDate4 ), 0 ) If oR4.RecordCount > 0 Then kw4 = oR4("kw") Else kw4 = 0 End If Case 2005 aDate1 = DateAdd( "yyyy", -4, theDate ) '2001 OpenRecordSet2 theConn, oR1, SelectKW( theTable, Year( aDate1 ), Month( aDate1 ), Day( aDate1 ), Hour( aDate1 ), Minute( aDate1 ), 0 ) If oR1.RecordCount > 0 Then kw1 = oR1("kw") Else kw1 = 0 End If aDate2 = DateAdd( "yyyy", -3, theDate ) '2002 OpenRecordSet2 theConn, oR2, SelectKW( theTable, Year( aDate2 ), Month( aDate2 ), Day( aDate2 ), Hour( aDate2 ), Minute( aDate2 ), 0 ) If oR2.RecordCount > 0 Then kw2 = oR2("kw") Else kw2 = 0 End If aDate3 = DateAdd( "yyyy", -2, theDate ) '2003 OpenRecordSet2 theConn, oR3, SelectKW( theTable, Year( aDate3 ), Month( aDate3 ), Day( aDate3 ), Hour( aDate3 ), Minute( aDate3 ), 0 ) If oR3.RecordCount > 0 Then kw3 = oR3("kw") Else kw3 = 0 End If aDate4 = DateAdd( "yyyy", -1, theDate ) '2004 OpenRecordSet2 theConn, oR4, SelectKW( theTable, Year( aDate4 ), Month( aDate4 ), Day( aDate4 ), Hour( aDate4 ), Minute( aDate4 ), 0 ) If oR4.RecordCount > 0 Then kw4 = oR4("kw") Else kw4 = 0 End If End Select Set oR1 = Nothing Set oR2 = Nothing Set oR3 = Nothing Set oR4 = Nothing theRule = "R" & Year( theDate ) & "_" & calculateState( kw1, kw2, kw3, kw4 ) Select Case Year( theDate ) Case 2001 Report reportFile, Join( Array( theDate, "*",kw1,kw2,kw3,kw4, theRule ), vbTab ) Case 2002 Report reportFile, Join( Array( theDate, kw1,"*",kw2,kw3,kw4, theRule), vbTab ) Case 2003 Report reportFile, Join( Array( theDate, kw1,kw2,"*",kw3,kw4, theRule), vbTab ) Case 2004 Report reportFile, Join( Array( theDate, kw1,kw2,kw3,"*",kw4, theRule), vbTab ) Case 2005 Report reportFile, Join( Array( theDate, kw1,kw2,kw3,kw4,"*", theRule), vbTab ) End Select End Sub

Toward a state table generator (VBScript)

This bit of code I used to create a two-state table for 5 variables. It would have been fairly easy to add more states -- by changing the if to a select case in 'state' and giving the for loops more things to loop through -- and to add more variables -- by specifying another loop and and another call to 'state'.

I won't be writing the generator ... the whole need for state tables disappeared in a meeting earlier today. function dq( txt ) dq = chr(34) & txt & chr(34) end function function state( num,vlu ) if vlu = 0 then state = dq("v" & num & "=0" ) else state = dq("v" & num & ">0") end if end function f = "Array( _" & vbCRLF for a = 0 to 1 for b = 0 to 1 for c = 0 to 1 for d = 0 to 1 for e = 0 to 1 f = f & "Array(" & _ join( _ array( _ state(1,a), _ state(2,b), _ state(3,c), _ state(4,d), _ state(5,e) _ ), ", " _ ) & "), _" & vbCRLF next next next next next f = f & ")" f = replace( f, ", _" & vbCRLF & ")", " _" & vbCRLF & ")" ) wscript.echo f

Once I wrote a global search and replace ...

... and now I find that a simple bit of unix command line replaces hundreds of lines of MoonRock BASIC.

$ for x in *.chk; do cat $x | sed -e s/Database=/Filename=/ > tmp; mv tmp $x; done

Get every file ending in .chk, pipe it through sed to change the relevant string, capture the result into a temporary file and then copy it over the original.

Found another use for Eval() in VBScript - state tables

Imagine trying to keep track of all possible combinations of four variables. Big if/then/else/end if, right? Not necessarily. function calculateState( v1, v2, v3, v4 ) dim stateTable dim stateItem dim stateLoop dim stateRule stateTable = Array( _ Array( "v1=0", "v2=0", "v3=0", "v4=0" ), _ Array( "v1>0", "v2=0", "v3=0", "v4=0" ), _ Array( "v1=0", "v2>0", "v3=0", "v4=0" ), _ Array( "v1>0", "v2>0", "v3=0", "v4=0" ), _ Array( "v1=0", "v2=0", "v3>0", "v4=0" ), _ Array( "v1>0", "v2=0", "v3>0", "v4=0" ), _ Array( "v1=0", "v2>0", "v3>0", "v4=0" ), _ Array( "v1>0", "v2>0", "v3>0", "v4=0" ), _ Array( "v1=0", "v2=0", "v3=0", "v4>0" ), _ Array( "v1>0", "v2=0", "v3=0", "v4>0" ), _ Array( "v1=0", "v2>0", "v3=0", "v4>0" ), _ Array( "v1>0", "v2>0", "v3=0", "v4>0" ), _ Array( "v1=0", "v2=0", "v3>0", "v4>0" ), _ Array( "v1>0", "v2=0", "v3>0", "v4>0" ), _ Array( "v1=0", "v2>0", "v3>0", "v4>0" ), _ Array( "v1>0", "v2>0", "v3>0", "v4>0" ) _ ) stateRule = -1 For stateLoop = 0 To 15 stateItem = stateTable( stateLoop ) If Eval( stateItem( 0 ) ) And _ Eval( stateItem( 1 ) ) And _ Eval( stateItem( 2 ) ) And _ Eval( stateItem( 3 ) ) Then stateRule = stateLoop Exit For End If Next calculateState = stateRule End Function WScript.Echo calculateState( 0, 0, 1, 1 )

Cygwin again - Oh how I love the unix command line

$ getclip | gawk '{ print "convert.vbs /profile:" $1 ".cvt\ndaily.vbs /profile:" $1 ".dly\n" }' | putclip

It gets the word I put in the clipboard (selected and copied out of SciTe) and puts back on the clipboard the word as commands and filenames to be pasted back in. For example, I put

Marble_Bar

on the clipboard, reissue the command, and get

convert.vbs /profile:Marble_Bar.cvt
daily.vbs /profile:Marble_Bar.dly

HTA - HTML applications

I've played with this one from time to time and would like sometime to take it a bit further. It's a text editor written as an HTML application, good for doing CScript and WScript.

Simple VBScript Development Tool

It's also good an example of what you can do with HTML applications, especially the idea of being able to put a functional interactive GUI front end over VBScript (and JScript).

A printf for VBScript - derivative work

Uwe Keim, on the CodeProject site, has a "printf"-ish VBScript function. Here's my version (which I now realise is almost word for word the same as someone else's take on Uwe's original.) So ...

Sven Axelsson, on the above site, has a version of Uwe's original, called "FormatMessage-like formatting in VBScript" which looks almost exactly like that below (except he calls his "Fmt", rather than "Subst").

function Subst(str, args)
    dim res
    dim i
    res = str

    for i = 0 to UBound(args)
        res = Replace(res, "%" & CStr(i+1) & "%" , args(i) )
    next

    res = Replace(res, "\n", vbCrLf)
    res = Replace(res, "\t", vbTab)

    Subst = res
end function

And an example of use:

theSelector = "SELECT * FROM %1% WHERE [aKey] >= (DATESERIAL(%2%, %3%, %4% ) + TIMESERIAL( %5%, 0, 0 )) AND [aKey] <= (DATESERIAL(%2%, %3%, %4% ) + TIMESERIAL( %5%, 59, 59 ))"
theSelect = Subst( theSelector, Array( theTable, theYear, theMonth, theDay, theHour ) )