[Ada (GNAT/GPL)] Creating DLLs for VB6

As promised, the GNAT/GPL code. Based on Roger Pearse's The Noddy Guide to using ADA code with Visual Basic.

How I ended up with the names api.ads, api.adb and api.def is an artefact from something I was reading. [This space set aside for an attribution.]

First up, api.ads, which declares the functions and exports them.

• function Factorial, which accepts a C.int and returns a C.int
• procedure Mangle, which accepts a Win32.LPWSTR and attempts the same dangerous stuff that Bob6 does in the ObjectAda version. Still working on this one.
• function Pattern, which returns a Win32.LPWSTR
• procedures Initialize_API, and Finalize_API, which I understand are mandatory. (If someone knows better, please tell me.)

with Interfaces.C; use Interfaces; with Win32; use Win32; package API is Count : C.int := 0; function Factorial (Val : C.int) return C.int; procedure Mangle( Ptr : Win32.LPWSTR ); function Pattern return Win32.LPWSTR; procedure Initialize_API; procedure Finalize_API; -- Initialization & Finalization routines. More in the next section. private pragma Export (DLL, Initialize_API); pragma Export (DLL, Finalize_API); --pragma Export (StdCall, Count); pragma Export (DLL, Factorial ); pragma Export (DLL, Mangle ); pragma Export (DLL, Pattern ); end API;

Next, api.adb, where the declarations are explained.

Mangle replaces the incoming string with something of its own. If the incoming string is larger or the same size then everything's more or less okay. (Less in the latter case, but at least it doesn't crash.) However, if the incoming string is shorter, VB truncates up to the length it knows about, and who knows what damage we've done with whatever gets overwritten by the rest of foo.

Pattern returns a pointer to the string data. Not knowing a lot about Ada, I don't know if the contents of foo will still be there by the time VB looks it and reads out.

with Interfaces.C; use Interfaces.C; with Win32; use Win32; with Win32.Winmain; with Win32.Winbase; with System; package body API is function Factorial (Val : C.int) return C.int is Fact : C.int := 1; begin Count := Count + 1; for K in 1 .. Val loop Fact := Fact * K; end loop; return Fact; end Factorial; procedure Mangle( Ptr : Win32.LPWSTR ) is lp : Win32.lpwstr; foo : Wide_String := Wide_String'("foo man chew"); begin lp := Win32.Winbase.lstrcpyW( Ptr, Win32.Addr(foo) ); end Mangle; function Pattern return Win32.LPWSTR is foo : Wide_String := Wide_String'("foo man chew"); begin return Win32.Addr(foo); end Pattern; procedure Initialize_API is procedure Adainit; pragma Import (C, Adainit); begin Adainit; end Initialize_API; procedure Finalize_API is procedure Adafinal; pragma Import (C, Adafinal); begin Adafinal; end Finalize_API; end API;

api.def lists the symbols exported, and is needed by gnatdll.

EXPORTS factorial mangle initialize_api finalize_api pattern

Now, pulling it all together requires some handwaving on the commandline.

gnat make api -Ic:\gnat\2007\include\win32ada gnatdll -e api.def -d api.dll api.ali -Ic:\gnat\2007\lib\win32ada

The output from a run of these is as follows:

C:\Docume...ts\BO_DLL>gnat make api -Ic:\gnat\2007\include\win32ada gcc -c -Ic:\gnat\2007\include\win32ada api.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winbase.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winmain.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg-impl.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-utils.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-windef.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\win32-winnt.adb gcc -c -I.\ -Ic:\gnat\2007\include\win32ada -I- c:\gnat\2007\include\win32ada\stdarg-machine.ads C:\Documen...ts\BO_DLL>gnatdll -e api.def -d api.dll api.ali -Ic:\gnat\2007\lib\win32ada Building relocatable DLL... make api.dll and libapi.a Warning: resolving _finalize_api by linking to _finalize_api@0 Use --enable-stdcall-fixup to disable these warnings Use --disable-stdcall-fixup to disable these fixups Warning: resolving _initialize_api by linking to _initialize_api@0 Warning: resolving _mangle by linking to _mangle@4 Warning: resolving _pattern by linking to _pattern@0 Warning: resolving _factorial by linking to _factorial@4 Warning: resolving _finalize_api by linking to _finalize_api@0 Use --enable-stdcall-fixup to disable these warnings Use --disable-stdcall-fixup to disable these fixups Warning: resolving _initialize_api by linking to _initialize_api@0 Warning: resolving _mangle by linking to _mangle@4 Warning: resolving _pattern by linking to _pattern@0 Warning: resolving _factorial by linking to _factorial@4

Now the VB code. Take note of a few things:

• Exporting as DLL generates decorated names, but gnatdll was able to resolve the decorated ones with the undecorated ones specified in api.def
• For reasons I remember reading somewhere, initialize_api and finalize_api are mandatory, and must be the first and last calls to the DLL
• Seeing as woof woof woof woof is longer than foo man chew, s ends up containing foo man chew
  woof

Declare Sub initialize_api Lib "api.dll" () Declare Function factorial Lib "api.dll" (ByVal x As Integer) As Integer Declare Function pattern Lib "api.dll" () As Long Declare Sub mangle Lib "api.dll" (ByVal x As Long) Declare Sub finalize_api Lib "api.dll" () Sub main() Dim s As String s = "woof woof woof woof" initialize_api Debug.Print factorial(3) mangle StrPtr(s) Debug.Print Len(s), s finalize_api End Sub

Next stop is to get this working with "GNAT/GCC MS-Windows MinGW 4.2.1 R0". I would prefer to be working under the GMGPL.

© Copyright Bruce M. Axtens., 2007

[Ada (ObjectAda 7.2.2)] Creating VB6 DLLs

Creating DLLs for use by VB6 seems to be somewhat of a dark art. From what Roger Pearse, in his The Noddy Guide to using ADA code with Visual Basic says, it doesn't appear to be something easily achieved.

So far I've achieved it, to a certain extent, with ObjectAda and GNAT/GPL. The code for the ObjectAda implementation is below. I'll post the GNAT/GPL stuff in the next couple of days, God willing.

BO_DLib.adb, BO_D.adb and BO_D.ads are all based, albeit rather loosely, on sample files in winapi\samples\petzold\ch19\edrlib\

First up, BO_DLib.adb

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with BO_B; procedure BO_BLib is begin null; end BO_BLib;

Next, the spec file, BO_D.ads

There are six routines:

• procedure Bob1 calls dobox to show a messagebox.
• function Bob2 returns a long value, 1.
• function Bob3 receives a long and adds 21 to it.
• procedure Bob4 receives a long pointer to a string and passes it to dobox for display.
  I can pass Unicode to it and have it rendered appropriately.
• function Bob5 receives a long pointer to a string and returns a long being the length of the string.
• function Bob6 receives a long pointer to a string and catenates a string to it.
  "Danger, Will Robinson!" ... this is not how to do it and VB complains bitterly.

Okay, there are seven routines, but dobox isn't exported. It takes a pointer to a wide string and passes it to Win32.Winuser.MessageBoxW. I got dobox from a sample file as well.

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with Win32.Windef; package BO_B is procedure bob1; function Bob2 return Win32.LONG; function bob3 ( arg : Win32.LONG ) return Win32.LONG; procedure Bob4( Arg : win32.LPCWSTR ); function bob5( Arg : win32.PCWSTR ) return win32.LONG; procedure dobox (msg : Win32.PCWSTR); procedure Bob6( Arg : Win32.LPWSTR ); pragma Export (DLL_Stdcall, Bob1, "Bob1"); pragma export (DLL_Stdcall, Bob2, "Bob2"); pragma export (DLL_Stdcall, Bob3, "Bob3"); pragma Export (DLL_Stdcall, Bob4, "Bob4"); pragma Export (DLL_Stdcall, Bob5, "Bob5"); pragma Export (DLL_Stdcall, Bob6, "Bob6"); end BO_B;

And, finally, BO_D.adb, where the definitions given in BO_D are fleshed out.

-- ====================================================================================== -- -- -- -- Converted from Programming Windows 95 / Charles Petzold -- 4th ed. -- -- Chapter 19 EDRLIB.C: Easy Drawing Routine Library Module -- -- -- -- ====================================================================================== -- with Interfaces.C; with interfaces.C.Strings; use interfaces; with Ada.Unchecked_Conversion; with Interfaces.C.Strings; with System; with Win32.Crt.Direct; with Win32.Crt.Stdlib; with Win32.Winbase; with Win32.Windef; with Win32.Wingdi; with Win32.Winmain; with Win32.Utils; with Win32.Winuser; with win32; use win32; with Win32.windowsx; package body BO_B is procedure bob1 is msg : Win32.PCWSTR; HELLOMSG : constant WCHAR_Array := "Hello" & Wide_Nul; begin Msg := Addr(HELLOMSG); dobox(Msg); end bob1; function Bob2 return Win32.LONG is begin return 1; end bob2; function bob3 ( arg : Win32.LONG ) return Win32.LONG is use type Win32.LONG; sum : Win32.LONG; begin Sum := Arg + 21; return Sum; end Bob3; procedure Bob4( Arg : win32.PCWSTR ) is begin dobox(arg); end Bob4; function Bob5( Arg : win32.PCWSTR ) return win32.LONG is Arguments_Length : constant Win32.LONG := Win32.LONG (Win32.Winbase.lstrlenW (Arg)); begin return Arguments_Length; end Bob5; procedure Bob6( Arg : Win32.LPWSTR ) is H : Wide_String := Wide_String'("doo dah, doo dah"); c : Win32.lpwstr; begin c := win32.winbase.lstrcatW( Arg, Addr(H) ); end Bob6; procedure dobox (msg : Win32.PCWSTR) is IResult : Win32.INT; begin iResult := Win32.Winuser.MessageBoxW(System.Null_Address, Msg, Addr("Title"), 0); end dobox; end BO_B;

Now the VB code. Take note of a few things:

• I declared the functions and procedures as DLL_Stdcall in BO_D.ads so the routines come in decorated, thus the use of Alias in the Declare line. I used Microsoft's Dependency Walker to discover to what extent the names had been mangled.
• A reference to SCRRUN.DLL was added to the project, making possible the use of the FileSystemObject.
• Bob6 barges past the limit set for the string by VB, so things get a bit unstable. I'm still working through how to pass strings back.

Declare Sub Bob1 Lib "bo_blib.dll" Alias "_Bob1@0" () Declare Function Bob2 Lib "bo_blib.dll" Alias "_Bob2@0" () As Long Declare Function Bob3 Lib "bo_blib.dll" Alias "_Bob3@4" (ByVal i As Long) As Long Declare Sub Bob4 Lib "bo_blib.dll" Alias "_Bob4@4" (ByVal ptr As Long) Declare Function Bob5 Lib "bo_blib.dll" Alias "_Bob5@4" (ByVal ptr As Long) As Long Declare Sub Bob6 Lib "bo_blib.dll" Alias "_Bob6@4" (ByVal ptr As Long) Dim oFSO As New Scripting.FileSystemObject Dim oStream As Scripting.TextStream Sub main() Dim s As String Set oStream = oFSO.OpenTextFile("c:\temp\hua.txt", ForReading, False, TristateTrue) s = oStream.ReadLine oStream.Close Bob1 Debug.Print Bob2 Debug.Print Bob3(21) Bob4 (StrPtr(s)) Debug.Print Bob5(StrPtr(s)) Bob6 StrPtr(s) MsgBox s End Sub

By the way, if you think my code sucks, say so. I'm a total newb when it comes to Ada. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

© Copyright Bruce M. Axtens., 2007

[Protium] Splitting

Here's a short script for splitting a file. The file in this case is the perl language data file from the PLEAC website. pleac_perl.data contains sections marked with "# ^^PLEAC^^_" followed by a number. The section applies until the next section is marked. The script splits each section out of pleac_perl.data into pleac_perl_number.p. I'm working through these files and re-expressing the intent of the perl code in Protium.

<@ DEFAREFLE>pleac</@> <@ DEFFLELIT>pleac|C:\Documents and Settings\All Users\Documents\Projects\PLEAC\pleac_perl.data</@> <@ ITEENUFLELIT>pleac| <@ LETVARELTFLE>aLine|...</@> <@ TSTRXPVARLIT>aLine|# \^\^PLEAC\^\^_(\d+\.\d+)</@> <@ IFF><@ LETVARKEY>number|__Reg1</@> <@ ACTSNKLIT>__Off</@> <@ ACTSNKEMMLIT>pleac_perl_&number;.p</@> </@> <@ SAYVAR>aLine</@> </@>

The code may be described as follows:

1. Define a work area, or alias, for the data file, calling it 'pleac'.
2. Open the text file within that work area, using define-file-lit.
3. Start a loop which iterates through an enumeration of the lines of data in the work area.
4. Let a variable contain the data in the current line of the work area.
5. Test whether the regular expression works for the current line.
6. If it does work, let a variable contain the number found, ...
7. ... turn off any output redirection, ...
8. ... and redirect output to the file 'pleac_perl_' + the number found (in the same directory as the script).
9. End of the if.
10. Output the contents of the line.
11. End of the iteration.

Simple ... and way powerful!

© Copyright Bruce M. Axtens, 2007

[Protium] 'Assert' as a User-Defined Syllable (UDS)

From time to time, during development, it helps to have an assert. That is, a means of checking whether you got the answer you were expecting, but without having to write lots of repetitive code in the process. To that end, therefore, I've come up with a UDS, an user defined syllable, which implements the concept (and demonstrates other Protium functionality as well.)

For the sake of clarity, I've put each syllable, or "opcode", in title case. This is not something that must be done; Protium cares not what case or mix of cases the instructions are in.

<@ DefUdsLitLit>ASR|__Transformer|<@ Sao> lhs=<@ LetVarPar>lhs|1</@> rhs=<@ LetVarPar>rhs|2</@> <@ IffNotExmVarVarLit>lhs|rhs| <@ LetResEkmLit>...|Assertion error: '&lhs;' <> '&rhs;'</@> </@> <@ Ign><@ Els> <@ LetResVar>...|lhs</@> </@></@> </@> </@>

A UDS is 'defined', thus the DEF at the beginning. An UDS has 3 parameters: the syllable itself, then the kind of UDS (more about that later), and then the Protium code which is processed each time the syllable is used. In this case, the syllable is ASR, the type is '__Transformer' and the code starts with <@ SAO> (more about SAO later, too).

Parameters may be passed to UDSes, and retrieved using PAR. In this case, the variable lhs is given the value of the first parameter, and the variable rhs the value of the second.

Next comes the test which forms the basis of an assert: does what is contained in lhs equal what is contained in rhs? The fourth line's opcodes implement this test: if not exact-match variable variable literal, with the arguments lhs, rhs and then another Protium instruction which is only evaluated if the test for exact-match fails.

If lhs does not match rhs, an EKM (Expand Macro Key And Memory) of the literal string "Assertion error: '&lhs;' <> '&rhs;'" is performed. lhs and rhs are bracketed by ampersand and comma, with the result that these symbols are replaced with the values of the variables themselves. The result is stored in the RES (the result) of the UDS, which is handed back to the calling code. Next comes a block wrapped in IGN. This is an artefact from the development of ASR. Code inside an IGN is ignored, that is, not executed. IGNs are predominantly used for documentation but can just as easily be used to isolate parts of the code.

<@ LetVarLit>string|Once a jolly swagman camped by a billabong</@> <@ SayAsrCapLit><@ SayActRmdVarLitLitLit>string|23|6|quatter</@>|Once a jolly squatter camped by a billabong</@> <@ LetVarLit>string|Once a jolly swagman camped by a billabong</@> <@ SayAsrCapLit><@ SayActRmdVarLitLitLit>string|23|6|quatter</@>|all your base are belong to us</@>

Here are two invocations of the ASR syllable. The first generates nothing because the actioned RMD, the reverse-mid, actually does convert "Once a jolly swagman camped by a billabong" into "Once a jolly squatter camped by a billabong". The second invocation gives the error message because there's no way that that reverse-mid is going to be able to produce "all your base are belong to us".

Now SAO, aside from being the name of an Arnott's biscuit, also stands for "Suppress All Output". Usually text outside the <@> and </@> of a Protium instruction is echoed to the relevant transput (read input-output device). SAO suppresses that echoing. This explains why you don't see 'lhs=' and 'rhs=' each time ASR is invoked. SAO also suppresses everything output by SAY.

Regarding __Transformer, every syllable opcode belongs to a particular group of syllables and each group has certain specific behaviours. Other groups include __Modifier, __Alternator, __Evaluator and __Locator. Read the friendly manual.

Finally, a word about testing. It was the developer's original design to separate testing from branching, and it was due to pressure from the Protium user community which forced the merging of the two into the form seen in most other programming languages. According to the original design, the test and branch code should have looked like this:

<@ TstNotExmVarVar>lhs|rhs</@> <@ IffLit> <@ LetResEkmLit>...|Assertion error: '&lhs;' <> '&rhs;'</@> </@>

Both ways of doing it work. I'm starting to come round to the idea that the original design is the better one, especially seeing that Protium supports ternary logic (true, false, unknown). More about that some other time.

This article can also be found at Isotopes of Hydrogen on the Protium Blue Forum.

© Copyright Bruce M. Axtens, 2007

[Protium] Templating

Finally, after much talk, here's some action on the Protium front. This the first posting in the 'Isotopes of Hydrogen' series, on the subject of Templating. IoH is housed at the Protium Blue Forum.

If you don't want to go through the process of forum registration, the article is reproduced below.

---

We're implementing a SOAP interface to Google's AdWords. There are a number of services and subroutines. The following code was developed to speed up the implementation by taking the service and subroutines names and turning them into VB6 subs.

<@ LETVARLIT>template| Sub &Function;(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "&Function;" URI = ADWORDS_API URL = &Service; oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub</@>

First there's the definition of template. Note that some parts of the template are Visual BASIC and some are something else: an ampersand, a word and a semicolon. These will be replaced with the text in the following list.

<@ LETVARLIT>params|TRAFFIC_ESTIMATOR_SERVICE checkKeywordTraffic estimateAdGroupList estimateCampaignList estimateKeywordList</@>

params contains, as a first item, the name of the service. After it are all the routines germane to that service. I got these by copying and pasting from Google's AdWords API website.

<@ LETCNDLSTVARLIT>L|params| </@>

This bit takes the variable params, and converts it to a list, splitting on newlines. CND means 'construct delimited'. The list is called L (really original, I know.)

<@ ITEENULSTLIT>L| <@ INILIT> <@ DEFMACELTLST>Service|L</@> </@> <@ ONGLIT> <@ DEFMACELTLST>Function|L</@> <@ SAYEKMVAR>template</@> </@> </@>

Next we iterate by enumeration of the L list. Here we see one of the special qualifiers that can be used with iteration, INI, that only fires on the first pass through the iteration and is ignored otherwise. In this case, its 'payload' is to define a macro where Service contains the current (in this case, the first) element of the L list.

ONG means 'ongoing' and fires on the second and subsequent iterations. The payload is in two parts. The first is to define another macro, Function, with the value of the current element of L. The second is to evaluate template, using EKM, substituting &Service; and &Function; with the values stored in the Service and Function macros.

By using INI, Service gets set only once. ONG ensures that Function will never contain the name of the service, and always contain the current name of the function.

An abbreviated sample of the output is below. There are 11 services and over 40 subs in total. Granted, there's still quite a bit of work to make these subs useful, but a lot of the hack work has been done by the computer, which is what it's there for.

Sub checkKeywordTraffic(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "checkKeywordTraffic" URI = ADWORDS_API URL = TRAFFIC_ESTIMATOR_SERVICE oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub ... Sub estimateKeywordList(oEnvelope As CoEnvelope, _ oHTTP As HTTPTransport, _ URL As String, _ URI As String, _ Method As String, _ sService As String, _ sMethod As String, _ dDate As Date) Method = "estimateKeywordList" URI = ADWORDS_API URL = TRAFFIC_ESTIMATOR_SERVICE oEnvelope.SetMethod Method, URI oEnvelope.Parameters.Create "service", sService oEnvelope.Parameters.Create "method", sMethod oEnvelope.Parameters.Create "date", dDate oHTTP.SOAPAction = Method End Sub

© Copyright Bruce M. Axtens, 2007

[Visual Basic 6] Boost again, but as a binary

As nice as the VBScript version of BOOST is, some people prefer a compiled binary. So, here's the VB6 version.

But first, credit where credit is due:
* Ultimate Packer for eXecutables which compresses binaries;
* Euphoria programming language website for the SETSUBSYS tool which I use to turn a GUI applications into a console ones;
* Experts Exchange for their ParseCommandLineValue function; and
* vb.mvps.org for their sample on how to make console applications

Okay, now to the code. The algorithm is very similar to the VBScript project, but there are some new things.

First the constants:

Option Explicit Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6

Here are two functions vital to making the application function appropriately in a command line environment. The first discovers the handle for StdOut. The second writes to a file handle, in this case the handle for StdOut.

After the function declarations is a user-defined wrapper. Interesting how the output of the WriteFile function is transmitted to the return value of the wrapper (the last argument in the call is the name of the wrapper function -- I'd never seen that before.)

'http://vb.mvps.org/samples/project.asp?id=console Private Declare Function GetStdOutHandle Lib "kernel32" _ Alias "GetStdHandle" _ (Optional ByVal HandleType As Long = -11) As Long Private Declare Function WriteFile Lib "kernel32" _ (ByVal hFile As Long, _ ByVal lpBuffer As String, _ ByVal cToWrite As Long, _ ByRef cWritten As Long, _ Optional ByVal lpOverlapped As Long) As Long 'To keep things simple, wrap these two APIs in a single helper function like so: Private Function ConsoleWrite(sText As String) As Long WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite End Function

This is the SetPriority function pulled straight out of the VBScript project. Notice I haven't even been polite enough to VB6 to specify sProcess As String and nPriority As Integer. I haven't typed any of the variables local to the function either. It doesn't matter: VB6 types them all as Variant and takes care of my carelessness (and I have put them in since.)

Function SetPriority(sProcess, nPriority) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) bDone = True Next SetPriority = bDone End Function

Next comes the Experts Exchange code for parsing the command line.

'http://www.experts-exchange.com/Programming/Programming_Languages/Q_20832956.html#9992009 Public Function ParseCommandLineValue(ByVal sCommandLine As String, ByVal sKey As String) As String Dim lPosFrom As Integer Dim lPosLen As Integer Dim sValue As String 'Initialize ParseCommandLineValue = "" If Trim(sKey) = "" Then Err.Raise vbObjectError, "Invalid key" End If 'Get Datasource lPosFrom = InStr(1, sCommandLine, sKey, vbTextCompare) If lPosFrom > 0 Then 'Find the position of the Value after length of the Key lPosFrom = lPosFrom + Len(sKey) 'Get value sValue = Mid(sCommandLine, lPosFrom) 'till end 'Find where next value starts lPosLen = InStr(lPosFrom, sCommandLine, "/") If lPosLen > 0 Then 'last value of the command line lPosLen = lPosLen - lPosFrom Else 'more values after this one lPosLen = Len(sValue) End If 'Return sValue = Mid(sCommandLine, lPosFrom, lPosLen) ParseCommandLineValue = sValue End If End Function

Now the Main. For ease of access to the relevant values for the SetPriority function, I've used a Collection. I could have used VBScript's Dictionary (by adding a reference to SCRRUN.DLL in the Projects menu) but the Collection works well enough.

Sub Main() 'http://vb.mvps.org/samples/project.asp?id=console Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim cPriorities As New Collection cPriorities.Add LOW_PRIORITY, "1" cPriorities.Add BELOWNORMAL_PRIORITY, "2" cPriorities.Add NORMAL_PRIORITY, "3" cPriorities.Add ABOVENORMAL_PRIORITY, "4" cPriorities.Add HIGH_PRIORITY, "5" cPriorities.Add REALTIME_PRIORITY, "6"

Now we parse the commandline and output a message about syntax if things aren't correctly specified there.

sCommand = Command() sProcess = Trim(ParseCommandLineValue(sCommand, "/process:")) sLevel = Trim(ParseCommandLineValue(sCommand, "/level:")) If sProcess = "" Or sLevel = "" Then ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost /process:{processname} /level:{runlevel}" & vbNewLine & _ "Run levels:" & vbNewLine & _ vbTab & "1 = LOW_PRIORITY" & vbNewLine & _ vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _ vbTab & "6 = REALTIME_PRIORITY" & vbNewLine) End End If

Assuming that the commandline is okay, we then attempt to figure out the runlevel value from the user-supplied specification, and show an appropriate error if it doesn't make sense.

On Error Resume Next nLevel = cPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite ("Invalid selection of runlevel.") End End If On Error GoTo 0

And, finally, where it is all made to happen. If everything's set up right and there is in fact a process running that matches what's stored in sProcess, then it gets boosted and the user is informed. If there's no match, the message says that the process wasn't boosted.

ConsoleWrite (sProcess & IIF(SetPriority(sProcess, nLevel), _ " boosted", " not boosted") & " to priority " & sLevel & _ " (" & nLevel & ").") End Sub

Having compiled the code to an .EXE, I used the setsubsys tool to change the binary from a GUI app to a console app

setsubsys boost.exe /C

I also compressed it using UPX,

upx -9 boost.exe

taking a 24576 byte application and leaving me with an 8192 byte one.

If anyone's interested in downloading the BOOST binary (which now contains a KILL_PROCESS 'level'), please leave a comment to that effect and I'll put up a download link.

By the way, if you think my code sucks, say so. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

[VBScript] Boost - changing process priority using WMI

I have little sh script on my iBook which changes the priority of a given process so that the OS services it more frequently, giving the impression of faster execution. Below is a re-implementation in VBScript of a similar tool for Windows. First a few constants and the arrays that handle the commandline options.

Option Explicit Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6 Dim aNames Dim aValues aNames = Array( "LOW", "BELOWNORMAL", "NORMAL", "ABOVENORMAL", "HIGH", "REALTIME" ) aValues = Array( LOW_PRIORITY, BELOWNORMAL_PRIORITY, NORMAL_PRIORITY, ABOVENORMAL_PRIORITY, HIGH_PRIORITY, REALTIME_PRIORITY )

Next, the real meat of this tool: the Windows Management Interface (WMI) call which takes a string and a numeric defining the process name and the priority level.

Function SetPriority( sProcess, nPriority ) Dim sComputer Dim oWMIService Dim cProcesses Dim oProcess Dim bDone bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess in cProcesses oProcess.SetPriority( nPriority ) bDone = True Next SetPriority = bDone End Function

Next a few less inspiring routines: IIF (available in VB but not in VBScript), ArrayOffset, and HelpText.

Function IIF( bCondition, vTrue, vFalse ) Dim vResult If bCondition = True Then vResult = vTrue Else vResult = vFalse End If IIF = vResult End Function Function ArrayOffset( sItem, aList ) Dim i Dim u Dim nResult nResult = -1 For i = 0 To UBound( aList ) If sItem = aList( i ) Then nResult = i Exit For End If Next ArrayOffset = nResult End Function Sub HelpText WScript.Echo "Syntax:" WScript.Echo vbTab & "Boost {appName} /L:{priority}" WScript.Echo vbTab & "priority: LOW | BELOWNORMAL | NORMAL | ABOVENORMAL | HIGH | REALTIME" WScript.Echo WScript.Echo vbTab & "E.g. boost cscript.exe /l:realtime" End Sub

Finally the main routine, which uses Named and Unnamed Arguments to handle command line parameters. The name of the process is pulled out of the command line using an Unnamed Argument, and the text representation of the priority is pulled out using a Named Argument ("L"). If the priority is acceptable the name and priority are passed to the SetPriority routine.

If WScript.Arguments.Unnamed.Count = 0 Or WScript.Arguments.Named.Count = 0 Then HelpText WScript.Quit End If Dim sApp, sPrio, nOffs sApp = WScript.Arguments( 0 ) sPrio = WScript.Arguments.Named.Item("L") nOffs = ArrayOffset( UCase( sPrio ), aNames ) If nOffs = -1 Then WScript.Echo "The",sPrio,"priority cannot be assigned to",sApp HelpText Else WScript.Echo sApp, _ IIF( SetPriority( sApp, aValues( nOffs ) ), _ "boosted to " & aNames( nOffs ) & " priority", _ "not boosted" ) End If

A further refinement of this tool might be to provide for one other possibility for /L: 'KILL' or 'TERMINATE'. By way of comparison here's the original sh script.

#!/bin/sh ps axxw | grep $1 | grep -v grep | grep -v boost sudo renice -20 `ps axww | grep $1 | grep -v grep | grep -v boost | awk '{print $1}'`

[Observation] A Programmer's Bill of Rights

A Programmer's Bill of Rights

by Diarmuid J. Pigott

To be able to instruct a computer in their own native language

• Have variables, field names, and attributes in their own native language
• Have the programming lexemes semantically significant in their own language
• Have programmatic components interrelated in a manner significant in their own language
• Not to have to learn a foreign language to get by

To be able to share their work with other people without loss of expressivity or meaning

© Copyright Diarmuid J. Pigott, 2007

[VBScript] Configure

Below is retake on the Include subroutine which heads up the vast majority of my scripts. This incarnation puts a wrapper around Include and is called, for want of a better word, Configure. This subroutine takes no parameters at all. Rather, it builds up a filename based on WScript.ScriptFullName with ".cfg" tagged on, reads it in and then hands it over to ExecuteGlobal. This means that the .cfg file must contain functioning VBScript code.

Provided the .cfg sits side-by-side with the .vbs, the .vbs should work. And if you change locations, change the .cfg code. If the .cfg can't be found, you get an error message. I haven't put in any error trapping yet.

Had fun with "With"/"End With" on this one.

So in the .vbs we have

Sub Configure With CreateObject("Scripting.FileSystemObject") With .OpenTextFile(WScript.ScriptFullName & ".cfg") ExecuteGlobal .ReadAll End With End With End Sub Configure

and in the .cfg we have (for example)

MsgBox "Hello from " & WScript.ScriptFullName

[Observation] freshmeat, no. CodePlex, yes?

Seems that freshmeat don't want Windows-only projects. So it may be CodePlex you'll find the project on. More details when they come to hand.

[Delphi] COM of libiconv

I have just finished my first serious bit of Delphi programming, using Turbo Delphi Explorer. As a RAD/IDE it's pretty good. However, given the limitations of the Explorer version, I'll upgrade to the Pro version fairly soon.

COMlibiconv is an in-process COM object and was born out of the company's need to convert some multibyte encodings into Unicode. It's based on DIConverters, a unit made available by Ralf Junker of The Delphi Inspiration. DIConverters is licensed as LGPL. COMlibiconv will also be LGPL.

(Did I mention that I'm working again? No? Okay, well now I work as a software engineer for Strapper Technologies, of Fremantle, WA, Australia, makers of the Protium language.)

I'll be posting version 1.0 of the project up on Freshmeat by the end of next week, God willing.

COMlibiconv appears to work. I've used it in VBScript, late-bound, as

Set o = CreateObject( "Comlibiconv.Converters" )

and I think my boss has used it, early-bound, in VB6.

At this stage the methods and properties exposed are as follows (taken from the source):

type TConverters = class(TAutoObject, IConverters) protected function iconv_toUnicode(const sEncoding, inString: WideString; startingAt, finishingAfter: Integer): OleVariant; safecall; function Get_ErrorCode: Integer; safecall; function Get_Success: WordBool; safecall; function Aliases(nIndex: Integer): OleVariant; safecall; function Get_Count: Integer; safecall; function CNames(nIndex: Integer): OleVariant; safecall; end;

The function iconv_toUnicode takes a string defining the name of the multibyte encoding, the string to be converted, and two integers stating where to start and when to finish. I should probably give those default values so that the method can be called with just the encoding and the string.

ErrorCode contains an integer value which, when Success is false, represents what went wrong. An enumeration of possible error values is indicated and may make it into the next version.

Aliases gives all the various names for an encoding, indexed by a number from zero to the number of encodings (which can be found using Count).

CNames is also indexed in a similar way, and returns what I have called the 'CName' of the encoding. It's stuff that was in the DIConverters unit. I haven't found a use for it, but included it anyway.

The next version will, God willing, contain a method to allow conversions from Unicode back to multibyte.

If you're interested in this, and it hasn't appeared on Freshmeat by 18th November 2006, write a comment to remind me.

© Copyright Bruce M. Axtens, 2006

[Observations] Microsoft Changes Attitude Toward FOSS?

After years of looking on FOSS as a disease, Microsoft have started talking with, and indeed collaborating with, the FOSS commmunity. For some the change is too unreal, with many taking a cynical, unbelieving attitude. For others, it's a godsend.

Check out Port 25's posting about a recent cooperation between Microsoft and Mozilla, titled Why I invited Mozilla

Then, if you have the time and bandwidth, there's a 1 hour video interview with Bill Hilf of the Open Source Software Lab at Microsoft

It seems almost too good to be true. What do you think?

[Observations] Wardriving

Last night I went war ... er ... bussing. From part way through the 879's route as far as the stop nearest home, there must have been over 30 hot spots. At least three weren't encrypted, and "offered" subnets to the passerby.

I'm on an 879 again this morning (2006-09-07, Thursday, after 09:00.) We haven't gone three kilometres yet and already NetStumbler has a list of over 50 hits. About half have WEP and the rest don't. And again about 1 in 10 of the total are open to the public.

Pardon my naivety, but is this the usual state of affairs?

It introduces an interesting ethical issue: no one can stop you stealing another's bandwidth if they don't take steps to protect it. It seems that you can sit in a tree outside their front gate, downloading to your heart's content and they wouldn't know it, until their ISP bills them for exceeding their download allowance, or they ring the ISP to ask why they've been shaped only to be told that one day last week they downloaded 5G of something or other.

NetStumbler's own help file says, under the heading "Wardriving", "... To avoid using the networks that you observe, go to the Network Control Panel and unbind TCP/IP from your wireless LAN card." (Inevitably?) ethics aren't mentioned.

[Later, 09:30] On the way into the Busport (inner city Perth) the list expanded rather dramatically. Some of the SSID's are more meaningful: PCEC_Dimension_Data and BHPB_NiW_Avaya_Voip, for instance. The name "metromesh" keeps coming up ... eight times so far. I wonder what that's all about?

Waiting for a 36 to take me to Midland. May start cycling there next week ... only about 30 kilometres each way.

Now working for Strapper Technologies. More about that later.

[VBScript] StandardLibrary.zip

As promised in the previous posting, Standard Library is now available as a ZIP. Thanks to Perth Linux Users Group for the storage space.

[VBScript] Standard Library

My apologies for the hiatus between entries. I have been struggling with the "black dog."

Recently, I was asked to make the Standard Library available, so here it it. For ease of digestion, I have segmented it, though you will find that some functions make use of routines in other segments. I will in due course make the whole file available in a single ZIP. Until then, you'll have to navigate as best you can.

Cheers, comments, creative criticism and corrections all gratefully received. It's been a few months since I last used the library; you may find the odd rough edge. (I have edited the file a little for publication, but only to remove references to previous employers' sites, and a few redundant comments.)

As knife manufacturers have no way of controlling how people use their knives, so I have no control over where and how you use the code on this weblog. I have tried as much as possible to acknowledge my sources. I would appreciate it if you also would do the same.

Okay, with that out of the way, let's begin.

I have adopted an Hungarian variable naming regime that is a bit different to the usual given in VBScript examples from Microsoft. Objects start with "o", collections with "c", strings with "s", numbers with "n", booleans with "b", dates with "d", arrays with "a", and variants with "v". I must confess, however, that I have not always followed my own standards.

First, a few symbols and standard objects.

'StandardLibrary.vbs

'based on original DLI_Lib.vbs 2005-12-12 Bruce M. Axtens v0.1

'***** SYMBOLS
Dim oFSO
Set oFSO = CreateObject( "Scripting.FileSystemobject" )

Dim oShell
Set oShell = CreateObject( "WScript.Shell" )

Dim oAppShell
Set oAppShell = CreateObject( "Shell.Application" )

Dim oDict
Set oDict = CreateObject( "Scripting.Dictionary" )

Dim oNetwork
Set oNetwork = CreateObject("WScript.Network")

Dim oProcess
Set oProcess = oShell.Environment( "PROCESS" )

Dim oVolatile
Set oVolatile = oShell.Environment("VOLATILE")

Dim oDSE
Set oDSE = GetObject( "LDAP://rootDSE" )

Dim oWMI

Const WF_APPEND = 1
Const WF_CREATE = 2

Const WF_FOR_APPENDING = 8
Const WF_FOR_WRITING = 2
Const WF_CREATE_NONEXISTING = True

Const adOpenForwardOnly = 0
Const adOpenStatic = 3
Const adLockOptimistic = 3

Next a symbol table class, similar to that used in CLIVE.

'***** CLASSES
Class Syms
    Private oVar

    Private Sub Class_Initialize()
        Set oVar = CreateObject( "Scripting.Dictionary" )
    End Sub

    Private Sub Class_Terminate()
        Dim i
        Set oVar = Nothing
    End Sub

    Public Sub Store( sName, vStuff )
        If oVar.Exists( sName ) = True Then
            oVar( sName ) = vStuff
        Else
            oVar.Add sName, vStuff
        End If
    End Sub

    Public Function Recall( sName )
        Dim vResult
        Dim vTemp

        If oVar.Exists( sName ) = True Then
            vResult = oVar( sName )
        Else
            vResult = Null
        End If
        Recall = vResult
    End Function

    Public Sub ClearList( aList )
        Dim i
        For i = 0 To UBound( aList )
            Store aList( i ), vbNullString
        Next
    End Sub

    Public Function SymTab()
        Dim aList
        Dim i
        Dim aKeys
        Dim aItems

        aKeys = oVar.Keys
        aItems = oVar.Items

        ReDim aList( oVar.Count - 1 )
        For i = 0 To oVar.Count - 1
            aList( i ) = aKeys( i ) & "=" & aItems( i )
        Next
        SymTab = Join( aList, vbNewLine )
    End Function

End Class

Next, String manipulation tools. There are lots of things in here: LeftOf, RightOf, CountFields, NthField, BeginsWith, EndsWith, Contains, ForceExtension, Subst, Subst2, DQ, Between, Wrap (which puts HTML markup around text), RemoveSpaces, Zerofill2, RightFill, and LeftFill.

'***** DATA MANIPULATION - STRING
Function LeftOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = Instr( sText, sItem )
    IF nPos >0 Then
        sResult = Left( sText, nPos -1 )
    End If
    LeftOf = sResult
End Function

Function RightOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = Instr( sText, sItem )
    IF nPos >0 Then
        sResult = Mid( sText, nPos + Len( sItem ) )
    End If
    RightOf = sResult
End Function

Function CountFields( strText, strDelim  )
    Dim nOffset, nFoundAt
    Dim nCounter

    nCounter = 1
    nOffset = 1

    Do
        nFoundAt = Instr( nOffset, strText, strDelim )
        If nFoundAt > 0 Then
                nCounter = nCounter + 1
                nOffset = nFoundAt + Len( strDelim )
        Else
            Exit Do
        End If
    Loop

    CountFields = nCounter
End Function

Function NthField( sText, sDelimiter, nReqdField )
    Dim nOffset, nFoundAt
    Dim nCounter
    Dim vResult

    nCounter = 1
    nOffset = 1
    vResult = -1
    If nReqdField >= 1 Then

        Do
            nFoundAt = Instr( nOffset, sText, sDelimiter )
            If nFoundAt > 0 Then
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset, nFoundAt - nOffset )
                    Exit Do
                Else
                    nCounter = nCounter + 1
                    nOffset = nFoundAt + Len( sDelimiter )
                End If
            Else
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset )
                End If
                Exit Do
            End If
        Loop
    End If
    NthField = vResult
End Function

Function BeginsWith( sText, sBeginning, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sBeginning = VBNullString Then
        bResult = True
    Else
        If sText <> VBNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Left( UCase( sText ), Len( sBeginning ) ) = UCase( sBeginning ) )
            Else
                bResult = ( Left( sText, Len( sBeginning ) ) = sBeginning )
            End If
        End If
    End If

    BeginsWith = bResult
End Function

Function EndsWith( sText, sEnding, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sEnding = VBNullString Then
        bResult = True
    Else
        If sText <> VBNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Right( UCase( sText ), Len( sEnding ) ) = UCase( sEnding ) )
            Else
                bResult = ( Right( sText, Len( sEnding ) ) = sEnding )
            End If
        End If
    End If

    EndsWith = bResult
End Function

Function Contains( sText, sChunk, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sChunk = VBNullString Then
        bResult = True
    Else
        If sText <> VBNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Instr( UCase( sText ), UCase( sChunk ) ) > 0 )
            Else
                bResult = ( Instr( sText, sChunk ) > 0 )
            End If
        End If
    End If

    Contains = bResult
End Function

Function ForceExtension( ByVal sFilename, ByVal sFileExtension )
    Dim sResult
    Dim nDotPos

    nDotPos = InStrRev( sFilename, "." )
    If nDotPos = 0 Then
        sResult = sFilename & sFileExtension
    Else
        sResult = Left( sFilename, nDotPos - 1 ) & sFileExtension
    End If
    ForceExtension = sResult
End Function

Function Subst( sText, aArgList )
    Dim sResult
    Dim sTemp
    Dim i

    sResult = sText

    For i = 0 To UBound( aArgList )
        sTemp = aArgList( i )
        If IsNull( sTemp ) Then
            sTemp = ""
        End If
        sResult = Replace( sResult, "[" & CStr( i + 1 ) & "]" , sTemp )
    Next

    Subst = sResult
End Function

Function Subst2( sText, aArgList )
    Dim sResult
    Dim i

    sResult = sText

    For i = 0 To UBound( aArgList )
        sResult = Replace( sResult, "[" & CStr( i + 1 ) & "]" , aArgList( i ) )
    Next

    sResult = Replace( sResult, "\n", vbNewLine )
    sResult = Replace( sResult, "\t", vbTab )

    Subst2 = sResult
End Function

Function DQ( s )
    DQ = Chr(34) & s & Chr(34)
End Function

Function Between( sText, sBegin, sEnd )
    Dim nBegin
    Dim nEnd

    nBegin = Instr( sText, sBegin )
    'no error checking yet
    nEnd = Instr( nBegin + Len( sBegin ), sText, sEnd )
    Between = Mid( sText, nBegin + Len( sBegin ), nEnd - nBegin - 1 )
End Function

Function Wrap( sTag, sContent )
    Dim aFirst
    aFirst = Split( sTag, " ", 2 )
    Log "{" & Join( aFirst, "," ) & "}"
    Wrap = "<" & sTag & ">" & sContent & "</" & aFirst( 0 ) & ">"
End Function

Function RemoveSpaces( sText )
    Dim sResult
    Dim s
    Dim i

    sResult = ""
    For i = 1 To Len( sText )
        s = Mid( sText, i, 1 )
        If s <> " " Then
            sResult = sResult & s
        End If
    Next
    RemoveSpaces = sResult
End Function

Function Zerofill2( nNum )
    Zerofill2 = Right( "00" & nNum, 2 )
End Function

Function RightFill( sText, nLen, sFill )
    RightFill = Left( sText & String( nLen, sFill ), nLen )
End Function

Function LeftFill( sText, nLen, sFill )
    LeftFill = Right( String( nLen, sFill ) & sText, nLen )
End Function

The one date manipulation function came out of a problem with encoding dates in Access. See the link for a fuller description.

'***** DATA MANIPULATION - DATE
Function dbDate(dDate)
    '~ http://www.aspfaq.com/show.asp?id=2260
    dbDate = year(dDate) & "-" & _
             zerofill2( month(dDate) ) & "-" & _
             zerofill2( day(dDate) ) & " " & _
             zerofill2( hour( dDate ) ) & ":" & _
             zerofill2( minute( dDate ) ) & ":" & _
             zerofill2( second( dDate ) )
End Function

Arrays: AAdd, InArray, StrInArray, AMax and Amin.

'***** DATA MANIPULATION - ARRAY
Function AAdd( ByRef aToThis, ByVal xAddThis )
    Dim nPos
    nPos = UBound( aToThis ) + 1
    ReDim Preserve aToThis( nPos )
    aToThis( nPos ) = xAddThis
    AAdd = nPos
End Function

Function InArray( sItem, aList )
    Dim i
    Dim u
    Dim bResult
    bResult = False
    u = UBound( aList )
    For i = 0 To u
        If sItem = aList( i ) Then
            bResult = True
            Exit For
        End If
    Next
    InArray = bResult
End Function

Function StrInArray( sItem, aList, bCaseInsens )
    Dim i
    Dim u
    Dim bResult
    bResult = False
    u = UBound( aList )
    For i = 0 To u
        If bCaseInsens = True Then
            bResult = ( LCase( sItem ) = LCase( aList( i ) ) )
        Else
            bResult = ( sItem = aList( i ) )
        End If
        If bResult = True Then Exit For
    Next
    StrInArray = bResult
End Function

Function AMax( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp > vResult Then
            vResult = vTemp
        End If
    Next
    AMax = vResult
End Function

Function AMin ( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp < vResult Then
            vResult = vTemp
        End If
    Next
    AMin = vResult
End Function

File manipulation code: CollectFiles, ReadFile, ReadFirstLine, Exists, WriteFile, Env and IncludeClass. Essentially wrappers around existing functionality, but with more flavour.

'***** DATA MANIPULATION - FILES
Function CollectFiles( sDirectory, sFileType )
    Dim aResult
    Dim oFolder
    Dim cItems
    Dim i
    Dim sItem
    Dim nCount

    aResult = Array()
    Set oFolder = oAppShell.Namespace(sDirectory)
    'On Error Resume Next
    Set cItems = oFolder.Items
    If Err.Number = 0 Then
        ReDim aResult( cItems.Count - 1 )
        nCount = 0
        For i = 0 To cItems.Count - 1
            sItem = cItems.Item( i )
            If EndsWith( sItem, sFileType, False ) Then
                aResult( nCount ) = sItem
                nCount = nCount + 1
            End If
        Next
    End If
    ReDim Preserve aResult( nCount - 1 )
    CollectFiles = aResult
End Function

Function ReadFile( FileName)
    Dim oStream
    Dim sData

    sData = VBNullString

    Set oStream = oFSO.OpenTextFile(FileName)
    sData = oStream.ReadAll
    oStream.Close

    ReadFile = sData
End Function

Function ReadFirstLine( FileName )
    Dim oStream
    Dim sData

    sData = VBNullString

    Set oStream = oFSO.OpenTextFile(FileName)
    sData = oStream.ReadLine
    oStream.Close

    ReadFirstLine = sData
End Function

Function Exists( sFile )
    Exists = oFSO.FileExists( sFile )
End Function

Sub WriteFile( sFilename, sContents, nMode )
    Dim oStream

    If nMode = WF_APPEND Then
        Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_APPENDING, WF_CREATE_NONEXISTING )
    ElseIf nMode = WF_CREATE Then
        Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_WRITING, WF_CREATE_NONEXISTING )
    Else
        Die "Mode incorrectly set for WriteFile2"
    End If

    oStream.Write sContents
    oStream.Close
End Sub

Function Env( strEnvVar )
    Dim oProcessEnvironment
    Dim sResult
    With CreateObject( "WScript.Shell" )
        Env = .Environment( "PROCESS" )( UCase( strEnvVar ) )
    End With
End Function

Sub IncludeClass( scriptName )
    Dim sScript
    Dim oStream
    'on error resume next
    err.clear
    With CreateObject( "Scripting.FileSystemobject" )
        Set oStream = .OpenTextFile( scriptName )
    End With
    If Err.Number > 0 Then
        MsgBox "Could not open " & scriptName
        WScript.Quit
    End If
    Err.Clear
    sScript = oStream.ReadAll()
    oStream.Close
    ExecuteGlobal sScript
    If Err.Number <> 0 Then
        Die "Error in loaded script"
    End If
    On Error Goto 0
End Sub

How do you classify the "mexican if"?

'***** DATA MANIPULATION - OTHER
Function IIF( bCondition, vTrue, vFalse )
    Dim vResult
    If bCondition = True Then
        vResult = vTrue
    Else
        vResult = vFalse
    End If
    IIF = vResult
End Function

Now we get into some serious Active Directory (AD) and Windows Management Interface (WMI) code. As much as possible I've included the relevant attributions for stuff I have lifted and/or adapted.

First, domain access: GetAvailableNTDomains

'***** DOMAINS
'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'----------------------------------------------------------------
' Function:     GetAvailableNTDomains
' Description:  Returns a listing of available NT Domains
' Parameters:   None
' Returns:      Variant array of NT Domain names.
'----------------------------------------------------------------
Public Function GetAvailableNTDomains()
  Dim objIADsContainer      ' ActiveDs.IADsContainer
  Dim objIADsDomain         ' ActiveDs.IADsDomain
  Dim vReturn               ' Variant

  ReDim vReturn(0)

  Set objIADsContainer = GetObject("WinNT:")
  For Each objIADsDomain In objIADsContainer
    If Trim(vReturn(0)) <> "" Then
      ReDim Preserve vReturn(UBound(vReturn) + 1)
    End If
    vReturn(UBound(vReturn)) = objIADsDomain.Name
  Next

  Set objIADsDomain = Nothing
  Set objIADsContainer = Nothing
  GetAvailableNTDomains = vReturn
End Function

Then computers: GetRemoteEnvironment, GetOnlineComputers, GetNetView, GetComputers, GetNBT, GetNBTA, GetDomainComputers, GetSpecs, ResolveIP, DetectTempFolder, and ExistsFolder.

'***** COMPUTERS
Function GetRemoteEnvironment( sComputer )
    Dim aResult
    Dim oWMI
    Dim cVars
    Dim oVar

    aResult = Array()

    Set oWMI = GetObject( "winmgmts:\\" & sComputer & "\root\cimv2")
    Set cVars = oWMI.ExecQuery( "Select * from Win32_Environment")
    For Each oVar in cVars
        AAdd aResult, oVar.SystemVariable & "^" & oVar.Name & "^" & oVar.VariableValue & "^" & oVar.Description & "^" & oVar.UserName
    Next
    GetRemoteEnvironment = aResult
End Function

Function GetOnlineComputers( sDomain )
    Dim sTemp
    Dim aTemp
    Dim aResult
    Dim i
    sTemp = GetNetView( sDomain )
    aTemp = Split( sTemp, vbNewLine )
    Redim aResult( UBound( aTemp ) - 6 )

    For i = 3 To UBound( aTemp ) - 3
        aResult( i - 3 ) = NthField( aTemp( i ), " ", 1 )
    Next

    GetOnlineComputers = aResult
End Function

Function GetNetView( sDomain )
    GetNetView = CaptureDOS( "%COMSPEC% /C NET VIEW /DOMAIN:" & sDomain, True )
End Function

Function GetComputers( sDomain )
    Dim oController
    Dim nCount
    Dim oComputer
    Dim aResult
    ReDim aResult( 5000 )

    Set oController = GetObject( "WinNT://" & sDomain )
    oController.Filter = Array( "Computer" )

    nCount = 0
    For Each oComputer In oController
        aResult( nCount ) = oComputer.Name
        nCount = nCount + 1
    Next
    ReDim Preserve aResult( nCount - 1 )
    GetComputers = aResult
End Function

Function GetNBT( sComputer )
    Dim sText
    Dim aText
    Dim i
    Dim sTemp
    Dim n
    Dim sResult

    sResult = ""

    sText = CaptureDOS( "%COMSPEC% /c nbtstat -a " & sComputer, True )
    aText = Split( sText, vbNewLine )

    If Instr( aText( 4 ), "Host not found." ) = 0 Then
        n = 0
        For i = 0 To UBound( aText )
            sTemp = Replace( RTrim( LTrim( aText( i ) ) ), vbCR, "" )
            aText( i ) = sTemp
        Next

        Dim sIP
        Dim sLine
        Dim sMac

        sIP = Between( aText( 2 ), "[", "]" )

        n = 7
        Do While True
            If Len( aText( n ) ) = 0 Then
                Exit Do
            End If
            sLine = aText( n )
            n = n + 1
        Loop

        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )

        sMac = Split( aText( n + 1 ), " = ")( 1 )
        sResult = sIP & "^" & sMac & "^" & Split( sLine, " " )( 0 )
    End If
    GetNBT = sResult
End Function

Function GetNBTA( sIPAddr )
    Dim sText
    Dim aText
    Dim i
    Dim sTemp
    Dim n
    Dim sResult

    sResult = ""

    sText = CaptureDOS( "%COMSPEC% /c nbtstat -A " & sIPAddr, True )
    aText = Split( sText, vbNewLine )

    If Instr( aText( 4 ), "Host not found." ) = 0 Then
        n = 0
        For i = 0 To UBound( aText )
            sTemp = Replace( RTrim( LTrim( aText( i ) ) ), vbCR, "" )
            aText( i ) = sTemp
        Next

        Dim sIP
        Dim sLine
        Dim sMac

        sIP = Between( aText( 2 ), "[", "]" )

        n = 7
        Do While True
            If Len( aText( n ) ) = 0 Then
                Exit Do
            End If
            sLine = aText( n )
            n = n + 1
        Loop

        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )
        sLine = Replace( sLine, "  ", " " )

        sMac = Split( aText( n + 1 ), " = ")( 1 )
        sResult = sIP & "^" & sMac & "^" & Split( sLine, " " )( 0 )
    End If
    GetNBTA = sResult
End Function

'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'----------------------------------------------------------------
' Function:     GetDomainComputers
' Description:  Returns a listing of NT Computer Accounts for a
'           given domain
' Parameters:   ByVal strDomain - Name of an NT Domain to retrieve
'           the list of Computer from.
' Returns:      Variant array of NT Computer names for the
'           specified domain.
'----------------------------------------------------------------
Public Function GetDomainComputers(ByVal strDomain)
   Dim objIADsContainer          ' ActiveDs.IADsDomain -
   '   Container object
   Dim objIADsComputer           ' ActiveDs.IADsComputer
   Dim vReturn                   ' Variant

   ' connect to the computer.
   Set objIADsContainer = GetObject("WinNT://" & strDomain)

   ' set the filter to retrieve only objects of class Computer
   objIADsContainer.Filter = Array("Computer")

   ReDim vReturn(0)
   For Each objIADsComputer In objIADsContainer
      If Trim(vReturn(0)) <> "" Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsComputer.Name
   Next

   GetDomainComputers = vReturn
   Set objIADsComputer = Nothing
   Set objIADsContainer = Nothing
End Function

Function GetSpecs( sComputer )
    Dim cItems
    Dim sQuery
    Dim oItem
    Dim sResult

    sResult = ""

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\CIMV2")
    If Err.Number = 0 Then
        sQuery = "SELECT Manufacturer, Model, Name, SystemType, TotalPhysicalMemory, DomainRole FROM Win32_ComputerSystem"
        Set cItems = oWMI.ExecQuery( sQuery )
        For Each oItem in cItems
            With oItem
                sResult =                 Trim( .Manfacturer )
                sResult = sResult & "^" & Trim( .Model )
                sResult = sResult & "^" & Trim( .Name )
                sResult = sResult & "^" & Trim( .SystemType )
                sResult = sResult & "^" & Trim( Int( ( ( .TotalPhysicalMemory ) / 1024 ) / 1024 ) ) & " MB"

                Select Case .DomainRole
                    Case 0
                        sResult = sResult & "^" & "Standalone Workstation"
                    Case 1
                        sResult = sResult & "^" & "Member Workstation"
                    Case 2
                        sResult = sResult & "^" & "Standalone Server"
                    Case 3
                        sResult = sResult & "^" & "Member Server"
                    Case 4
                        sResult = sResult & "^" & "Backup Domain Controller"
                    Case 5
                        sResult = sResult & "^" & "Primary Domain Controller"
                End Select
            End With
        Next
        Err.Clear
        On Error GoTo 0
    End If
    GetSpecs = sResult
End Function

Function ResolveIP( sName )
    Dim sHost
    Dim sTarget
    Dim cPingResults
    Dim oPingResult
    Dim sResult

    sResult = vbNullString
    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

Function DetectTempFolder( sDir )
    Dim sTemp1
    Dim sTemp2
    Dim sResult

    sTemp1 = "c:\Windows\Temp"
    sTemp2 = "c:\TEMP"
    sResult = vbNullString

    If ExistsFolder( V.Recall( "COMPUTERNAME" ), sTemp1 ) Then
        sResult = "\\" & V.Recall( "COMPUTERNAME" ) & Replace( sTemp1, "c:\", "\C$\" )
    ElseIf ExistsFolder( V.Recall( "COMPUTERNAME" ), sTemp2 ) Then
        sResult = "\\" & V.Recall( "COMPUTERNAME" ) & Replace( sTemp2, "c:\", "\C$\" )
    Else
        '
    End If
    DetectTempFolder = sResult

End Function

Function ExistsFolder( sComputer, sDir )
    Dim oWMI
    Dim cFiles
    Dim oFile
    Dim sUNC

    sUNC = Replace( sDir, "\", "\\" )

    Set oWMI = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")

    Set cFiles = oWMI.ExecQuery _
        ("Select * from CIM_Directory Where name = '" & sUNC & "'")

    ExistsFolder = cFiles.Count > 0
End Function

Also user-specific tools: GetOUofUser, GetLoginProfiles, GetMac, GetComputerUsers, GetComputerUsers2, GetDomainUser, and GetNameAndDescription.

'***** USERS
Function GetOUofUser( sDomain, sUsername )
    Dim sResult
    sResult = vbNullString

    On Error Resume Next

    Const ADS_SCOPE_SUBTREE = 2

    Set oConnection = CreateObject("ADODB.Connection")
    Set oCommand =   CreateObject("ADODB.Command")
    oConnection.Provider = "ADsDSOObject"
    oConnection.Open "Active Directory Provider"
    Set oCommand.ActiveConnection = oConnection

    oCommand.Properties("Page Size") = 1000
    oCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

    oCommand.CommandText = _
        "SELECT distinguishedName FROM 'LDAP://" & sDomain & "' WHERE objectCategory='user' " & _
            "AND sAMAccountName='" & sUsername & "'"
    Set oRecordSet = oCommand.Execute

    oRecordSet.MoveFirst
    Do Until oRecordSet.EOF
        sResult = oRecordSet.Fields("distinguishedName").Value
        oRecordSet.MoveNext
    Loop

    Set oRecordSet = Nothing
    Set oCommand = Nothing
    Set oConnection = Nothing

    GetOUofUser = sResult
End Function

Function GetLoginProfiles( sComputer )
    Dim cItems
    Dim oItem
    Dim aResult
    ReDim aResult( -1 )

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
    If Err.Number = 0 Then
        Set cItems = oWMI.ExecQuery("Select * from Win32_NetworkLoginProfile",,48)
        For Each oItem in cItems
            AAdd aResult, oItem.Name
        Next

    End If
    Err.Clear
    On Error Goto 0

    GetLoginProfiles = aResult
End Function

Function GetMac( sDevice )
    Dim cItems
    Dim oItem
    Dim sResult

    sResult = vbNullString

    On Error Resume Next
    Set oWMI = GetObject("winmgmts:\\" & sDevice & "\root\cimv2")
    If Err.Number = 0 Then
        Set cItems = oWMI.ExecQuery( "Select * from Win32_NetworkAdapterConfiguration" )
        For Each oItem in cItems
            sResult = sResult &  oItem.Caption & "~" & oItem.MACAddress & "^"
        Next

        sResult = Mid( sResult, 1, Len( sResult ) - 1 )
    End If
    Err.Clear
    On Error Goto 0

    GetMac = sResult
End Function

'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'----------------------------------------------------------------
' Function:     GetComputerUsers
' Description:  This function will return the names of the users
'                 for a specified computer or domain
' Parameters:   ByVal strComputerName - Name of an NT Computer or
'                 domain to retrieve the list of Users from.
' Returns:      Variant array of user account for the specified
'           computer
'----------------------------------------------------------------
Function GetComputerUsers(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsUser           'As ActiveDs.IADsUser
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' Connect to the computer or domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' apply a filter to retrieve only objects of class User
   objIADsContainer.Filter = Array("User")

   ' iterate all user objects within the container
   For Each objIADsUser In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsUser.Name
   Next

   Set objIADsUser = Nothing
   Set objIADsContainer = Nothing
   GetComputerUsers = vReturn
End Function

Function GetComputerUsers2(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsUser           'As ActiveDs.IADsUser
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' Connect to the computer or domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' apply a filter to retrieve only objects of class User
   objIADsContainer.Filter = Array("User")

   ' iterate all user objects within the container
   For Each objIADsUser In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsUser.Name & "^" & objIADsUser.FullName
   Next

   Set objIADsUser = Nothing
   Set objIADsContainer = Nothing
   GetComputerUsers2 = vReturn
End Function

Function GetDomainUser( sComputer )
    Dim cProc
    Dim oProcess
    Dim sUser, sDomain
    Dim sResult

    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
            'Get currently logged on user and update CurrentUser element.
            '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).

            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

Function GetNameAndDescription( spDomain, sUsername )
    Dim sDomain
    Dim oIADSUser
    Dim sResult

    sResult = vbNullString

    If IsEmpty( spDomain ) Then
        sDomain = oNetWork.UserDomain
    Else
        sDomain = spDomain
    End If

    If Len( sUsername ) > 0 Then
        On Error Resume Next
        Set oIADSUser = GetObject( Subst( "WinNT://[1]/[2],user", Array( sDomain, sUsername ) ) )
        If Err.number = 0 Then
            sResult = oIADSUser.FullName & "^" & oIADSUser.Description
            Set oIADSUser = Nothing
        End If
        Err.Clear
        On Error Goto 0

    End If

    GetNameAndDescription = sResult
End Function

I didn't use them often, but there are function here for Group access as well: GetComputerGroups and GetGroups.

'***** GROUPS
'http://www.windowsitpro.com/WindowsScripting/Article/ArticleID/4734/4734.html
'---------------------------------------------------------------
' Function:     GetComputerGroups
' Description:  This function will return the names of
'                 the NT Groups for a specified computer.
' Parameters:   ByVal strComputerName - Name of an NT
'                 Computer or Domain to retrieve the list of
'           Groups from.
' Returns:      Variant array of NT Groups for the specified
'           computer
'----------------------------------------------------------------
Public Function GetComputerGroups(ByVal strComputerName)
   Dim objIADsContainer      'As ActiveDs.IADsContainer
   Dim objIADsGroup          'As ActiveDs.IADsGroup
   Dim vReturn               'As Variant
   ReDim vReturn(0)

   ' connect to the computer or Domain
   Set objIADsContainer = GetObject("WinNT://" & strComputerName)

   ' Set the filter on the container to retrieve only
   ' objects of Class Group
   objIADsContainer.Filter = Array("Group")

   ' iterate through each group object in the container
   For Each objIADsGroup In objIADsContainer
      If Trim(vReturn(0)) <> vbNullString Then
         ReDim Preserve vReturn(UBound(vReturn) + 1)
      End If
      vReturn(UBound(vReturn)) = objIADsGroup.Name
   Next

   Set objIADsGroup = Nothing
   Set objIADsContainer = Nothing
   GetComputerGroups = vReturn
End Function

Function GetGroups()
    Dim objRecordSet
    Dim objCommand
    Dim objConnection
    Dim i
    Dim aList
    ReDim aList( 10000 )
    On Error Resume Next

    Const ADS_SCOPE_SUBTREE = 2

    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection

    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

    objCommand.CommandText = _
        "SELECT cn, name, ADsPath, description FROM 'LDAP://" & GetDefaultNamingContext() & "' WHERE " _
            & "objectCategory='group'"
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    i = 0
    Do Until objRecordSet.EOF
        aList( i ) = objRecordSet.Fields("cn").Value & "^" & objRecordSet.Fields("ADsPath").Value
        objRecordSet.MoveNext
        i = i + 1
    Loop

    Set objRecordSet = Nothing
    Set objcommand = Nothing
    Set objConnection = Nothing


    ReDim Preserve aList( i - 1 )
    GetGroups = aList
End Function

Okay, now we get onto the application control routines, starting with Excel: ExcelStart, ExcelNewSheet and ExcelColumnNames.

'***** SPREADSHEET
Dim oExcel

Sub ExcelStart( bHidden )
    Set oExcel = CreateObject("Excel.Application")
    If bHidden = True Then
        oExcel.Visible = False
        oExcel.Interactive = False
    Else
        oExcel.Visible = True
        oExcel.Interactive = True
    End If
End Sub

Dim oWorkbook
Dim oSheet

Sub ExcelNewSheet()
    Set oWorkbook = oExcel.Workbooks.Add()
    Set oSheet = oWorkbook.ActiveSheet
End Sub

Sub ExcelColumnNames( aHeadings )
    Dim i
    For i = 0 To UBound( aHeadings )
        oSheet.Cells( 1, i + 1 ).Value = aHeadings( i )
        oSheet.Cells( 1, i + 1 ).Font.Bold = True
    Next
End Sub

Then, Access routines: CreateDatabase, OpenDatabase, OpenRecordSet, CreateStructure and CreateIndex.

'***** DATABASE
Sub CreateDatabase( sFile )
    Dim oCatalog

    Set oCatalog = CreateObject( "ADOX.Catalog" )
    oCatalog.Create( "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Jet OLEDB:Engine Type=5;Data Source=" & sFile)

    Set oCatalog = Nothing
End Sub

function OpenDatabase( theFile )
    Dim oConnection
    On Error Resume Next
    Set oConnection = CreateObject( "ADODB.Connection" )
    oConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & theFile
    If Err.Number <> 0 Then
        Die "OpenDatabase", Err
    End If
    Err.Clear
    On Error GoTo 0
    Set OpenDatabase = oConnection
end function

Function OpenRecordSet( ByRef oDB, sQuery )
    Dim oRecordSet
    Set oRecordSet = CreateObject( "ADODB.RecordSet" )
    oRecordSet.Open sQuery, oDB, adOpenStatic, adLockOptimistic
    Set OpenRecordSet = oRecordSet
End Function

Sub CreateStructure( oDb, sSpec )
    On Error Resume Next
    oDb.Execute sSpec
    If Err.Number <> 0 Then
        Die "CreateStructure error", Err
    End If
End Sub

Sub CreateIndex( oDb, sSpec )
    On Error Resume Next
    oDb.Execute sSpec
    If Err.Number <> 0 Then
        Die "CreateIndex error", Err
    End If
End Sub

One lonely email-specific tool: ErrorEmail.

'***** EMAIL
Sub ErrorEmail( sTo, sSubj, sText )
    sTo = Escape(   sTo )
    sSubj= Escape(  sSubj )
    sText = Escape( sText )
    sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    oShell.Run sCmd
End Sub

Internet Explorer tools: ModalDialog, ModalText, ModalThing, ReadClipboard, WriteClipboard.

'***** WEBBROWSER
Function ModalDialog( sOption )
    Dim sHTML
    Dim sContainer
    Dim sFolder
    Dim sName

    sContainer = "<SELECT name=selID id=selID>[1]</SELECT><input type='submit' Value='Choose' onclick=subSet>"
    sHTML = Wrap( "HEAD", Wrap( "TITLE", "Selection Dialog" ) )
    sHTML = sHTML & Wrap( "SCRIPT language='VBScript'", Replace( "\nSub subSet()\nwindow.ReturnValue = selID.Value\nwindow.close\nEnd Sub\n", "\n", vbNewLine ) )
    sHTML = sHTML & Wrap( "BODY", Wrap( "CENTER", "Select Name from List:&nbsp;" & "[1]" ) )
    sHTML = Wrap( "HTML", sHTML )
    Log sHTML

    sContainer = Subst( sContainer, Array( sOption ) )
    Log sContainer

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )
    Log sHTML

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:80px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )
    Log sTemp
    ModalDialog = sTemp
End Function

Sub ModalText( sText )
    Dim sHTML
    Dim sContainer
    Dim sFolder
    Dim sName


    sHTML = Wrap( "HEAD", Wrap( "TITLE", "Display Dialog" ) )
    sHTML = sHTML & Wrap( "SCRIPT language='VBScript'", Replace( "\nSub ClipCopy()\ndocument.parentwindow.clipboardData.SetData """", taStuff.Value\nEnd Sub\n", "\n", vbNewLine ) )
    sHTML = sHTML & Wrap( "BODY", Wrap( "CENTER", Wrap( "TEXTAREA id='taStuff' name='taStuff' rows='5' cols='55'", sText ) ) )
    'sHTML = sHTML & Wrap( "CENTER", "<input type='button' Value='Copy to Clipboard' onclick=ClipCopy>")
    sHTML = Wrap( "HTML", sHTML )

    Log sHTML

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )
    Log sHTML

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:120px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )
    Log sTemp

End Sub

Sub ModalThing( sTitle, sMarkup )
    Dim sHTML
    Dim sFolder
    Dim sName


    sHTML = Wrap( "HEAD", _
                Wrap( "TITLE", _
                    sTitle _
                    ) _
                )

    sHTML = sHTML & Wrap( "BODY", sMarkup )
    sHTML = Wrap( "HTML", sHTML )

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sHTML = Subst( sHTML, Array( sContainer ) )

    WriteFile sFolder & "\" & sName, sHTML, WF_CREATE
    sTemp = window.showModalDialog( sFolder & "\" & sName, "", "dialogHeight:245px, dialogWidth:50px, center:yes, help:no, scroll:no, resizeable:no" )

End Sub

function ReadClipboard
' Reads Clipboard into a variable
' by Christoph Basedau, http://dev.remotenetworktechnology.com/wsh/rubegoldberg.htm
' modified by Bruce M. Axtens to read clipboard rather than write to it
    with createobject("internetexplorer.application")
        .navigate "about:blank"
        ReadClipboard = .document.parentwindow.clipboardData.getData ("text")
        .quit
    end with
end function

Sub WriteClipboard( sText )
' Reads Clipboard into a variable
' by Christoph Basedau, http://dev.remotenetworktechnology.com/wsh/rubegoldberg.htm
    with createobject("internetexplorer.application")
        .navigate "about:blank"
        .document.parentwindow.clipboardData.setData "text", sText
        .quit
    end with
end Sub

An LDAP function: GetDefaultNamingContext

'***** LDAP
Function GetDefaultNamingContext()
    GetDefaultNamingContext = oDSE.Get( "defaultNamingContext" )
End Function

A function, CaptureDOS. It runs a command in the CMD shell, captures the output to a text file, and then sucks the data into a string variable.

'***** DOS
Function CaptureDOS( sCommand, bSynch )
    Dim sFolder
    Dim sName
    Dim sTempFile
    Dim sResult

    sResult = vbNullString

    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sTempFile = oFSO.BuildPath( sFolder, sName )
    oShell.Run sCommand & "> " & DQ( sTempFile ), 0, bSynch
    sResult = ReadFile( sTempFile )
    oFSO.DeleteFile( sTempFile )
    CaptureDOS = sResult
End Function

Logging variables and functions: LogTo, Log, Die and Faint.

'***** LOGGING
Dim bIsLogging
Dim oLogStream
Dim bLog

Dim sLogFilename

bIsLogging = False
bLog = False

Sub LogTo( sFile )
    sLogFilename = sFile
End Sub

Sub Log( sMsg )
    Const STR_LOG_EXT = ".log"

   Dim sFilename
   Dim sLogname

    If IsEmpty( sLogFilename ) Then
        sFilename = "Scripting.log"
    Else
        sFilename = sLogFilename
    End If

    sLogname = ForceExtension( sFilename, STR_LOG_EXT )


    If bIsLogging = False Then
        If bLog = True Then
            'On Error Resume Next
            Set oLogStream = oFSO.OpenTextFile( sLogname, WF_FOR_APPENDING, True ) 
            If Err.Number <> 0 Then
                MsgBox Err.Description
            End If
            Err.Clear
            On Error Goto 0
            bIsLogging = True
        End If
    End If


    If bIsLogging = True Then oLogStream.WriteLine sMsg

End Sub

Sub Die( sPlace, oErr )
    Dim sMsg
    bLog = True
    LogTo WScript.ScriptFullName
    sMsg =  sPlace & "|" & oErr.Number & "|" & oErr.Source & "|" & oErr.Description
    Log sMsg
    MsgBox sMsg
    WScript.Echo sMsg
    WScript.Quit
End Sub

Sub Faint( sPlace, oErr )
    Dim sMsg
    bLog = True
    LogTo WScript.ScriptFullName
    sMsg =  sPlace & "|" & oErr.Number & "|" & oErr.Source & "|" & oErr.Description
    Log sMsg
    WScript.Quit
End Sub

Next comes a testing module which is only executed if the library itself is executed directly. For example:
    CSCRIPT StandardLibrary.vbs

Anything goes in this section, and the stuff below is what was in there the last time I tested the file, which was sometime in January 2006.

'***** TESTING
Dim sTemp
Dim aTemp
Dim sPC
Dim aComputers
Dim aDomains
Dim j
Dim vars

Dim aReport
ReDim aReport( 0 )

sPC = "PC00001"
If WScript.ScriptName = "StandardLibrary.vbs" Then
    WScript.Echo LeftOf( "my\\dog", "\\" )
    WScript.Echo RightOf( "my\\dog", "\\" )
    WScript.Quit
    IncludeClass "C:\Script\StandardSymbols.vbs"
    aTemp = GetRemoteEnvironment( sPC )
    For i = 0 To UBound( aTemp )
        WScript.Echo aTemp( i )
    Next

    aTemp =  GetOnlineComputers( "DOMAIN" )
    For i = 0 To UBound( aTemp )
        aadd aReport, i & " " & aTemp(i)
    Next
    'WScript.Echo Join( aTemp, vbNewLine & vbTab )
    'WScript.Quit
    If InArray( "\\" & sPC, aTemp ) Then
        aadd aReport, sPC & " is online"
    End If
    '~ WScript.Quit
    aadd aReport, Join( GetComputerUsers( "DOMAIN" ), vbNewLine & vbTab )
    aadd aReport, "GetMac of " & sPC & ": "
    aadd aReport,  GetMac( sPC )

    aDomains = GetAvailableNTDomains()
    For j = 0 To UBound( aDomains )
        aComputers = GetComputers( aDomains( j ) )
        For i = 0 To UBound( aComputers )
            aadd aReport,  aDomains( j ) & " " & aComputers( i )
        Next
    Next
    'With WScript
        aadd aReport,  "Between [ and ] in 'my[foo]': " & Between( "my[foo]", "[", "]" )
        aadd aReport,  "defaultNamingContext: " & oDSE.Get( "defaultNamingContext" )
        sTemp = GetDomainUser( sPC )
        aadd aReport,  "GetDomainUser " & sPC & ": " & sTemp
        If Left( sTemp, 1 ) <> "<" Then
            aTemp = Split( sTemp, "\" )
            aadd aReport,  "GetNameAndDescription " & sTemp & ": " & GetNameAndDescription( aTemp(0), aTemp(1) )
        End If
        aadd aReport,  "GetLoginProfiles " & sPC & ": " & Join( Split( GetLoginProfiles( sPC ), "^" ), vbNewLine & vbTab )
        aadd aReport,  "GetNBT of " & sPC & ": " & GetNBT( sPC )
    'End With
    WScript.Echo Join( aReport, vbNewLine )
    ErrorEmail "dog@cat.com", "StandardLibary tests", Join( aReport, vbNewLine )
End If

Okay, that's the end of it.

I don't know when I'll be doing VBScript again; I have designed the Sudoku solver but haven't coded it yet. I had thought of doing it as an HTA.

At the moment I'm looking into the ISIS database technology (a friend has developed a Win32 Unicode-enabled version), serial i/o, FreeBASIC, and xbScript.

I hope to recommence regular postings soon, likely in support of a new language, Protium. Until then.

© Copyright Bruce M. Axtens, 2006