[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] "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] 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] 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] 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( ":" )