       IDENTIFICATION DIVISION.
       PROGRAM-ID. MD5.
       AUTHOR.  Bill Gunshannon
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   Use the md5sum utility and pass the HASH back using
      **     a temp file.  Not elegant, but it works.
      ************************************************************

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Tmp-MD5 ASSIGN TO "/tmp/MD5"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Tmp-MD5
           DATA RECORD IS MD5-Rec.
       01  MD5-Rec       PIC X(32).

       WORKING-STORAGE SECTION.

       01 Eof                   PIC X     VALUE 'F'.
       01 Str1.
          05  Pre-cmd   PIC X(8)
              VALUE 'echo -n '.
          05  Str1-complete.
              10  Str1-Part1  PIC X(26)
                  VALUE  'The quick brown fox jumps'.
              10  Str1-Part2  PIC X(19)
                  VALUE  ' over the lazy dog'.
          05  Post-cmd    PIC X(20)
              VALUE  ' | md5sum > /tmp/MD5'.
       01  Str1-MD5          PIC X(32).

       PROCEDURE DIVISION.

       Main-Program.

           DISPLAY Str1-complete.
           PERFORM Get-MD5.
           DISPLAY Str1-MD5.

           STOP RUN.

       Get-MD5.

           CALL "SYSTEM" USING Str1.
           OPEN INPUT Tmp-MD5.
           READ Tmp-MD5 INTO Str1-MD5.
           CLOSE Tmp-MD5.
           CALL "CBL_DELETE_FILE" USING '/tmp/MD5'.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. MD5-DEMO.
       AUTHOR.  Bill Gunshannon
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   Use the md5sum utility and pass the HASH back using
      **     a temp file.  Not elegant, but it works.
      **   Same program but made MD5 a User Defined Function
      **     instead of a procedure.
      ************************************************************

       ENVIRONMENT DIVISION.

       CONFIGURATION SECTION.

       REPOSITORY.
          FUNCTION MD5.

       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01 Eof                   PIC X     VALUE 'F'.
       01 Str1.
          05  Pre-cmd   PIC X(8)
              VALUE 'echo -n '.
          05  Str1-complete.
              10  Str1-Part1  PIC X(26)
                  VALUE  'The quick brown fox jumps'.
              10  Str1-Part2  PIC X(19)
                  VALUE  ' over the lazy dog'.
          05  Post-cmd    PIC X(20)
              VALUE  ' | md5sum > /tmp/MD5'.
       01  Str1-MD5          PIC X(32).

       PROCEDURE DIVISION.

       Main-Program.

           DISPLAY Str1-complete.
      *    PERFORM Get-MD5.
           MOVE FUNCTION MD5(Str1) TO Str1-MD5.
           DISPLAY Str1-MD5.

           STOP RUN.

        END PROGRAM MD5-DEMO.

       IDENTIFICATION DIVISION.
       FUNCTION-ID. MD5.

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Tmp-MD5 ASSIGN TO "/tmp/MD5"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Tmp-MD5
           DATA RECORD IS MD5-Rec.
       01  MD5-Rec       PIC X(32).

       LINKAGE SECTION.
       01  Str1        PIC X(128).
       01  Str1-MD5    PIC X(32).

       PROCEDURE DIVISION USING Str1 RETURNING Str1-MD5.

           CALL "SYSTEM" USING FUNCTION TRIM(Str1).
           OPEN INPUT Tmp-MD5.
           READ Tmp-MD5 INTO Str1-MD5.
           CLOSE Tmp-MD5.
           CALL "CBL_DELETE_FILE" USING '/tmp/MD5'.
           GO-BACK.

        END FUNCTION MD5.

implement an MD5 encoding for a given string. The codes also include an optional validation using test values from IETF RFC (1321) for MD5. However, due to known weaknesses of MD5, alternatives like SHA-256 or SHA-3 are recommended for production-grade cryptography. If the solution is a library, refer to MD5/Implementation for a scratch implementation.


Works with: GNU Cobol version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. count-in-octal.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
    FUNCTION dec-to-oct
    .
DATA DIVISION.
WORKING-STORAGE SECTION.
01  i                                   PIC 9(18).

PROCEDURE DIVISION.
    PERFORM VARYING i FROM 1 BY 1 UNTIL i = 0
        DISPLAY FUNCTION dec-to-oct(i)
    END-PERFORM
    .
END PROGRAM count-in-octal.

IDENTIFICATION DIVISION.
FUNCTION-ID. dec-to-oct.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  rem                                 PIC 9.

01  dec                                 PIC 9(18).

LINKAGE SECTION.
01  dec-arg                             PIC 9(18).

01  oct                                 PIC 9(18).

PROCEDURE DIVISION USING dec-arg RETURNING oct.
    MOVE dec-arg TO dec *> Copy is made to avoid modifying reference arg.
    PERFORM WITH TEST AFTER UNTIL dec = 0
        MOVE FUNCTION REM(dec, 8) TO rem
        STRING rem, oct DELIMITED BY SPACES INTO oct
        DIVIDE 8 INTO dec
    END-PERFORM
    .
END FUNCTION dec-to-oct.

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.


       PROGRAM-ID. SWAP-DEMO.
       AUTHOR.  Bill Gunshannon.
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   A simple program to demonstrate the SWAP subprogram.
      **
      ************************************************************

       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01  Val1                 PIC X(72).
       01  Val2                 PIC X(72).

       PROCEDURE DIVISION.

       Main-Program.

          DISPLAY 'Enter a Value: ' WITH NO ADVANCING.
          ACCEPT Val1.
          DISPLAY 'Enter another Value: ' WITH NO ADVANCING.
          ACCEPT Val2.
          DISPLAY ' ' .
          DISPLAY 'First value: ' FUNCTION TRIM(Val1) .
          DISPLAY 'Second value: ' FUNCTION TRIM(Val2) .

           CALL "SWAP" USING BY REFERENCE Val1,  BY REFERENCE Val2.

          DISPLAY ' '.
          DISPLAY 'After SWAP '.
          DISPLAY ' '.
          DISPLAY 'First value: ' FUNCTION TRIM(Val1).
          DISPLAY 'Second value: ' FUNCTION TRIM(Val2).

           STOP RUN.

       END PROGRAM SWAP-DEMO.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. SWAP.
       AUTHOR.  Bill Gunshannon.
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   SWAP any Alphanumeric value.  Only limit is 72
      **     character size.  But that can be adjusted for
      **     whatever use one needs.
      ************************************************************

       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01  TEMP                  PIC X(72).

       LINKAGE SECTION.

       01  Field1                PIC X(72).
       01  Field2                PIC X(72).

       PROCEDURE DIVISION
               USING BY REFERENCE Field1, BY REFERENCE Field2.

       MOVE Field1 to TEMP.
       MOVE Field2 to Field1.
       MOVE TEMP to Field2.

       GOBACK.

       END PROGRAM SWAP.

implement a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. The function is designed to work with both statically and dynamically typed languages, with certain limitations based on language semantics and support for parametric polymorphism.


Works with: GnuCOBOL
       identification division.
       function-id. palindromic-test.

       data division.
       linkage section.
       01 test-text            pic x any length.
       01 result               pic x.
          88 palindromic       value high-value
                               when set to false low-value.

       procedure division using test-text returning result.

       set palindromic to false
       if test-text equal function reverse(test-text) then
           set palindromic to true
       end-if

       goback.
       end function palindromic-test.

implement a function to check if a given sequence of characters is a palindrome. It also supports Unicode characters. Additionally, it includes a second function to detect inexact palindromes, ignoring white-space, punctuation, and case-sensitivity. It may also be useful for testing a function.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Environment-Vars.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  home PIC X(75).

       PROCEDURE DIVISION.
*          *> Method 1.
           ACCEPT home FROM ENVIRONMENT "HOME"
           DISPLAY home

*          *> Method 2.
           DISPLAY "HOME" UPON ENVIRONMENT-NAME
           ACCEPT home FROM ENVIRONMENT-VALUE

           GOBACK
           .

"Demonstrates how to retrieve a process's environment variables such as PATH, HOME, or USER in a Unix system."


class stack
	dim tos
	dim stack()
	dim stacksize

	private sub class_initialize
		stacksize = 100
		redim stack( stacksize )
		tos = 0
	end sub

	public sub push( x )
		stack(tos) = x
		tos = tos + 1
	end sub

	public property get stackempty
		stackempty = ( tos = 0 )
	end property

	public property get stackfull
		stackfull = ( tos > stacksize )
	end property

	public property get stackroom
		stackroom = stacksize - tos
	end property

	public function pop()
		pop = stack( tos - 1 )
		tos = tos - 1
	end function

	public sub resizestack( n )
		redim preserve stack( n )
		stacksize = n
		if tos > stacksize then
			tos = stacksize
		end if
	end sub
end class

dim s
set s = new stack
s.resizestack 10
wscript.echo s.stackempty
dim i
for i = 1 to 10
	s.push rnd
	wscript.echo s.stackroom
	if s.stackroom = 0 then exit for
next
for i = 1 to 10
	wscript.echo s.pop
	if s.stackempty then exit for
next

implement a stack data structure with basic operations such as push (to add elements), pop (to remove and return the last added element), and empty (to check if the stack is empty). This stack follows a Last-In-First-Out (LIFO) access policy.


test_arr_1 = Array(1,2,3,4,5,6,7,8,9,10)
test_arr_2 = Array(1,2,3,4,5,6,7,8,9,10)

WScript.StdOut.Write "Scenario 1: Create a new array"
WScript.StdOut.WriteLine
WScript.StdOut.Write "Input: " & Join(test_arr_1,",")
WScript.StdOut.WriteLine
WScript.StdOut.Write "

select certain elements from an array into a new array in a generic way. Specifically, it selects all even numbers from an array. Optionally, it can also filter destructively by modifying the original array instead of creating a new one.


Works with: Windows Script Host version *
WScript.Echo StrReverse("asdf")

Reverses a given string while preserving Unicode combining characters. For instance, it transforms "asdf" to "fdsa" and "as⃝df̅" to "f̅ds⃝a".


Dim a, b, i

Do
    a = Int(Rnd * 20)
    WScript.StdOut.Write a
    If a = 10 Then Exit Do
    b = Int(Rnd * 20)
    WScript.Echo vbNullString, b
Loop

For i = 1 To 100000
    a = Int(Rnd * 20)
    WScript.StdOut.Write a
    If a = 10 Then Exit For
    b = Int(Rnd * 20)
    WScript.Echo vbNullString, b
Next

The code generates and prints random numbers from 0 to 19. If the generated number is 10, the loop stops. If not, a second random number is generated and printed before the loop restarts. The loop continues indefinitely if 10 is never generated as the first number. Demonstrates breaking out of loops in BASIC.


' Factors of a Mersenne number
    for i=1 to 59
        z=i
        if z=59 then z=929  ':) 61 turns into 929.
        if isPrime(z) then
            r=testM(z)
            zz=left("M" & z & space(4),4)
            if r=0 then
                Wscript.echo zz & " prime."
            else
                Wscript.echo zz & " not prime, a factor: " & r
            end if
        end if
    next

function modPow(base,n,div)
    dim i,y,z
    i = n : y = 1 : z = base
    do while i
        if i and 1 then y = (y * z) mod div
        z = (z * z) mod div
        i = i \ 2
    loop
    modPow= y
end function

function isPrime(x)
    dim i
    if x=2 or x=3 or _
       x=5 or x=7 _
                  then isPrime=1: exit function
    if x<11       then isPrime=0: exit function
    if x mod 2=0  then isPrime=0: exit function
    if x mod 3=0  then isPrime=0: exit function
    i=5
    do
        if (x mod i)     =0 or _
           (x mod (i+2)) =0 _
                  then isPrime=0: exit function
        if i*i>x  then isPrime=1: exit function
        i=i+6
    loop
end function

function testM(x)
    dim sqroot,k,q
    sqroot=Sqr(2^x)
    k=1
    do
        q=2*k*x+1
        if q>sqroot then exit do
        if (q and 7)=1 or (q and 7)=7 then
            if isPrime(q) then
                if modPow(2,x,q)=1 then
                    testM=q
                    exit function
                end if
            end if
        end if
        k=k+1
    loop
    testM=0
end function

implement a method to find a factor of a Mersenne number (in this case, M929). The method uses efficient algorithms to determine if a number divides 2P-1, including a self-implemented modPow operation. It also incorporates properties of Mersenne numbers to refine the process, such as the form of any factor q of 2P-1 and the conditions that q must meet. The method stops when 2kP+1 > sqrt(N). It only works on Mersenne numbers where P is prime.


Set objXMLDoc = CreateObject("msxml2.domdocument")

objXMLDoc.load("In.xml")

Set item_nodes = objXMLDoc.selectNodes("//item")
i = 1
For Each item In item_nodes
	If i = 1 Then
		WScript.StdOut.Write item.xml
		WScript.StdOut.WriteBlankLines(2)
		Exit For
	End If
Next

Set price_nodes = objXMLDoc.selectNodes("//price")
list_price = ""
For Each price In price_nodes
	list_price = list_price & price.text & ", "
Next
WScript.StdOut.Write list_price
WScript.StdOut.WriteBlankLines(2)

Set name_nodes = objXMLDoc.selectNodes("//name")
list_name = ""
For Each name In name_nodes
	list_name = list_name & name.text & ", "
Next
WScript.StdOut.Write list_name
WScript.StdOut.WriteBlankLines(2)

1. Retrieves the first "item" element from the XML document.
2. Prints out each "price" element from the XML document.
3. Gets an array of all the "name" elements from the XML document.


Function quicksort(arr,s,n)
	If n < 2 Then
		Exit Function
	End If
	t = s + n - 1
	l = s
	r = t
	p = arr(Int((l + r)/2))
	Do Until l > r
		Do While arr(l) < p
			l = l + 1
		Loop
		Do While arr(r) > p
			r = r -1
		Loop
		If l <= r Then
			tmp = arr(l)
			arr(l) = arr(r)
			arr(r) = tmp
			l = l + 1
			r = r - 1
		End If
	Loop
	If s < r Then
		Call quicksort(arr,s,r-s+1)
	End If
	If l < t Then
		Call quicksort(arr,l,t-l+1)
	End If
	quicksort = arr
End Function

myarray=Array(9,8,7,6,5,5,4,3,2,1,0,-1)
m = quicksort(myarray,0,12)
WScript.Echo Join(m,",")

implement the Quicksort algorithm to sort an array or list of elements. The algorithm works by choosing a pivot element and dividing the rest of the elements into two partitions - one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and joins them with the pivot to get the sorted array. The codes also include an optimized version of Quicksort that works in place by swapping elements within the array to avoid memory allocation of more arrays. The pivot selection method is not specified.


'YYYY-MM-DD format
WScript.StdOut.WriteLine Year(Date) & "-" & Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2)

'Weekday_Name, Month_Name DD, YYYY format
WScript.StdOut.WriteLine FormatDateTime(Now,1)

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007".


Function Dec2Bin(n)
	q = n
	Dec2Bin = ""
	Do Until q = 0
		Dec2Bin = CStr(q Mod 2) & Dec2Bin
		q = Int(q / 2)
	Loop
	Dec2Bin = Right("00000" & Dec2Bin,6)
End Function

Function PowerSet(s)
	arrS = Split(s,",")
	PowerSet = "{"
	For i = 0 To 2^(UBound(arrS)+1)-1
		If i = 0 Then
			PowerSet = PowerSet & "{},"
		Else
			binS = Dec2Bin(i)
			PowerSet = PowerSet & "{"
			c = 0
			For j = Len(binS) To 1 Step -1
				If CInt(Mid(binS,j,1)) = 1 Then
					PowerSet = PowerSet & arrS(c) & ","
				End If
				c = c + 1
			Next
			PowerSet = Mid(PowerSet,1,Len(PowerSet)-1) & "},"
		End If
	Next
	PowerSet = Mid(PowerSet,1,Len(PowerSet)-1) & "}"
End Function

WScript.StdOut.Write PowerSet("1,2,3,4")

implement a function that takes a set as input and returns its power set. The power set includes all subsets of the input set, including the empty set and the set itself. The function also demonstrates the handling of edge cases where the input set is empty or contains only the empty set.


'Arrays - VBScript - 08/02/2021

    'create a static array
    Dim a(3)   ' 4 items : a(0), a(1), a(2), a(3)
    'assign a value to elements
    For i = 1 To 3
        a(i) = i * i
    Next
    'and retrieve elements
	buf=""
    For i = 1 To 3
        buf = buf & a(i) & " "
    Next
    WScript.Echo buf

    'create a dynamic array
    Dim d()
    ReDim d(3)   ' 4 items : d(0), d(1), d(2), d(3)
    For i = 1 To 3
        d(i) = i * i
    Next
	buf=""
    For i = 1 To 3
        buf = buf & d(i) & " "
    Next
	WScript.Echo buf

	d(0) = 0
    'expand the array and preserve existing values
    ReDim Preserve d(4)   ' 5 items : d(0), d(1), d(2), d(3), d(4)
    d(4) = 16
	buf=""
    For i = LBound(d) To UBound(d)
        buf = buf & d(i) & " "
    Next
	WScript.Echo buf

	'create and initialize an array dynamicaly
    b = Array(1, 4, 9)
	'and retrieve all elements
	WScript.Echo Join(b,",")

	'Multi-Dimensional arrays
	'The following creates a 5x4 matrix
	Dim mat(4,3)

demonstrate the basic syntax of arrays in the specific language, including creating an array, assigning a value to it, and retrieving an element. It also showcases the use of both fixed-length and dynamic arrays, and the process of pushing a value into the array.


Dim MyWord
MyWord = UCase("alphaBETA")   ' Returns "ALPHABETA"
MyWord = LCase("alphaBETA")   ' Returns "alphabeta"

demonstrate the conversion of the string "alphaBETA" to upper-case and lower-case using the default string literal or ASCII encoding. The code also showcases additional case conversion functions such as swapping case or capitalizing the first letter if available in the language's library. Note that in some languages, the toLower and toUpper functions may not be reversible.


class topological
	dim dictDependencies
	dim dictReported
	dim depth

	sub class_initialize
		set dictDependencies = createobject("Scripting.Dictionary")
		set dictReported = createobject("Scripting.Dictionary")
		depth = 0
	end sub

	sub reset
		dictReported.removeall
	end sub

	property let dependencies( s )
		'assuming token tab token-list newline
		dim i, j ,k
		dim aList
		dim dep
		dim a1
		aList = Split( s, vbNewLine )
		'~ remove empty lines at end
		do while aList( UBound( aList ) ) = vbnullstring
			redim preserve aList( UBound( aList ) - 1 )
		loop

		for i = lbound( aList ) to ubound( aList )
			aList( i ) = Split( aList( i ), vbTab, 2 )
			a1 = Split( aList( i )( 1 ), " " )
			k = 0
			for j = lbound( a1) to ubound(a1)
				if a1(j) <> aList(i)(0) then
					a1(k) = a1(j)
					k = k + 1
				end if
			next
			redim preserve a1(k-1)
			aList(i)(1) = a1
		next
		for i = lbound( aList ) to ubound( aList )
			dep = aList(i)(0)
			if not dictDependencies.Exists( dep ) then
				dictDependencies.add dep, aList(i)(1)
			end if
		next

	end property

	sub resolve( s )
		dim i
		dim deps
		'~ wscript.echo string(depth,"!"),s
		depth = depth + 1
		if dictDependencies.Exists(s) then
			deps = dictDependencies(s)
			for i = lbound(deps) to ubound(deps)
				resolve deps(i)
			next
		end if
		if not seen(s) then
			wscript.echo s
			see s
		end if
		depth = depth - 1
	end sub

	function seen( key )
		seen = dictReported.Exists( key )
	end function

	sub see( key )
		dictReported.add key, ""
	end sub

	property get keys
		keys = dictDependencies.keys
	end property
end class

dim toposort
set toposort = new topological
toposort.dependencies = "des_system_lib	std synopsys std_cell_lib des_system_lib dw02 dw01 ramlib ieee" & vbNewLine & _
	"dw01	ieee dw01 dware gtech" & vbNewLine & _
	"dw02	ieee dw02 dware" & vbNewLine & _
	"dw03	std synopsys dware dw03 dw02 dw01 ieee gtech" & vbNewLine & _
	"dw04	dw04 ieee dw01 dware gtech" & vbNewLine & _
	"dw05	dw05 ieee dware" & vbNewLine & _
	"dw06	dw06 ieee dware" & vbNewLine & _
	"dw07	ieee dware" & vbNewLine & _
	"dware	ieee dware" & vbNewLine & _
	"gtech	ieee gtech" & vbNewLine & _
	"ramlib	std ieee" & vbNewLine & _
	"std_cell_lib	ieee std_cell_lib" & vbNewLine & _
	"synopsys	"

dim k
for each k in toposort.keys
	wscript.echo "----- " & k
	toposort.resolve k
	wscript.echo "-----"
	toposort.reset
next

----- des_system_lib
std
synopsys
ieee
std_cell_lib
dware
dw02
gtech
dw01
ramlib
des_system_lib
-----
----- dw01
ieee
dware
gtech
dw01
-----
----- dw02
ieee
dware
dw02
-----
----- dw03
std
synopsys
ieee
dware
dw02
gtech
dw01
dw03
-----
----- dw04
ieee
dware
gtech
dw01
dw04
-----
----- dw05
ieee
dware
dw05
-----
----- dw06
ieee
dware
dw06
-----
----- dw07
ieee
dware
dw07
-----
----- dware
ieee
dware
-----
----- gtech
ieee
gtech
-----
----- ramlib
std
ieee
ramlib
-----
----- std_cell_lib
ieee
std_cell_lib
-----
----- synopsys
synopsys
-----

The code implements a function that performs a topological sort on VHDL libraries based on their dependencies. It ensures that no library is compiled before the ones it depends on. The function also handles cases of self-dependencies and flags un-orderable dependencies. It uses either Kahn's 1962 topological sort or depth-first search algorithm for sorting.


Function StartsWith(s1,s2)
	StartsWith = False
	If Left(s1,Len(s2)) = s2 Then
		StartsWith = True
	End If
End Function

Function Contains(s1,s2)
	Contains = False
	If InStr(1,s1,s2) Then
		Contains = True & " at positions "
		j = 1
		Do Until InStr(j,s1,s2) = False
			Contains = Contains & InStr(j,s1,s2) & ", "
			If j = 1 Then
				If Len(s2) = 1 Then
					j = j + InStr(j,s1,s2)
				Else
					j = j + (InStr(j,s1,s2) + (Len(s2) - 1))
				End If
			Else
				If Len(s2) = 1 Then
					j = j + ((InStr(j,s1,s2) - j) + 1)
				Else
					j = j + ((InStr(j,s1,s2) - j) + (Len(s2) - 1))
				End If
			End If
		Loop
	End If
End Function

Function EndsWith(s1,s2)
	EndsWith = False
	If Right(s1,Len(s2)) = s2 Then
		EndsWith = True
	End If
End Function

WScript.StdOut.Write "Starts with test, 'foo' in 'foobar': " & StartsWith("foobar","foo")
WScript.StdOut.WriteLine
WScript.StdOut.Write "Contains test, 'o' in 'fooooobar': " & Contains("fooooobar","o")
WScript.StdOut.WriteLine
WScript.StdOut.Write "Ends with test, 'bar' in 'foobar': " & EndsWith("foobar","bar")

The code checks if a given string starts with, contains, or ends with a second string. It also prints the location of the match and handles multiple occurrences of the second string within the first string.


'ANSI Clock

'ansi escape functions
ans0=chr(27)&"["
sub cls()  wscript.StdOut.Write ans0 &"2J"&ans0 &"?25l":end sub
sub torc(r,c,s)  wscript.StdOut.Write ans0 & r & ";" & c & "f"  & s :end sub

'bresenham
Sub draw_line(r1,c1, r2,c2,c)
  Dim x,y,xf,yf,dx,dy,sx,sy,err,err2
  x =r1    : y =c1
  xf=r2    : yf=c2
  dx=Abs(xf-x) : dy=Abs(yf-y)
  If x<xf Then sx=+1: Else sx=-1
  If y<yf Then sy=+1: Else sy=-1
  err=dx-dy
  Do
    torc x,y,c
    If x=xf And y=yf Then Exit Do
    err2=err+err
    If err2>-dy Then err=err-dy: x=x+sx
    If err2< dx Then err=err+dx: y=y+sy
  Loop
End Sub

const pi180=0.017453292519943
'center of the clock
const r0=13
const c0=26

'angles
nangi=-30*pi180
aangi=-6*pi180
ang0=90*pi180

'lengths of hands
lh=7
lm=9
ls=9
ln=12

while 1
     cls

    'dial
    angn=ang0+nangi
    for i=1 to 12
      torc r0-cint(ln*sin(angn)),cint(c0+2*ln*cos(angn)),i
      angn=angn+nangi
    next

    'get time and display it in numbers
    t=now()
    torc 1,1, hour(t) &":"& minute(t) &":"& second(t)

    'angle for each hand
    angh=ang0+hour(t) *nangi
    angm=ang0+minute(t) *aangi
    angS=ang0+second(t) *aangi

    'draw them
    draw_line r0,c0,cint(r0-ls*sin(angs)),cint(c0+2*ls*cos(angs)),"."
    draw_line r0,c0,cint(r0-lm*sin(angm)),cint(c0+2*lm*cos(angm)),"*"
    draw_line r0,c0,cint(r0-lh*sin(angh)),cint(c0+2*lh*cos(angh)),"W"
    torc r0,c0,"O"

    'wait one second
    wscript.sleep(1000)
wend

The code is designed to create a simple, animated clock or timekeeping device. It displays the passage of seconds, with changes occurring every second and cycling periodically. The clock syncs with the system clock for accuracy but does not consume excessive CPU resources. The code is clear, concise, and avoids unnecessary complexity. It uses system or language-specific timers, signals, or events rather than constant polling. The animation is achieved using ANSI codes in VBScript and is compatible with Windows 10 and above.


For i=1 To 8
	WScript.StdOut.WriteLine triples(10^i)
Next

Function triples(pmax)
	prim=0 : count=0 : nmax=Sqr(pmax)/2 : n=1
	Do While n <= nmax
		m=n+1 : p=2*m*(m+n)
		Do While p <= pmax
			If gcd(m,n)=1 Then
				prim=prim+1
				count=count+Int(pmax/p)
			End If
			m=m+2
			p=2*m*(m+n)
		Loop
		n=n+1
	Loop
	triples = "Max Perimeter: " & pmax &_
				", Total: " & count &_
				", Primitive: " & prim
End Function

Function gcd(a,b)
	c = a : d = b
	Do
		If c Mod d > 0 Then
			e = c Mod d
			c = d
			d = e
		Else
			gcd = d
			Exit Do
		End If
	Loop
End Function

The code calculates the number of Pythagorean triples (a, b, c) where a, b, and c are positive integers, a < b < c, and a^2 + b^2 = c^2, with a perimeter (a + b + c) no larger than 100. It also determines the number of these triples that are primitive, meaning a, b, and c are co-prime. The code is also optimized to handle large values up to a maximum perimeter of 100,000,000.


filepath = "SPECIFY FILE PATH HERE"

Set objfso = CreateObject("Scripting.FileSystemObject")
Set objdict = CreateObject("Scripting.Dictionary")
Set objfile = objfso.OpenTextFile(filepath,1)

txt = objfile.ReadAll

For i = 1 To Len(txt)
	char = Mid(txt,i,1)
	If objdict.Exists(char) Then
		objdict.Item(char) = objdict.Item(char) + 1
	Else
		objdict.Add char,1
	End If
Next

For Each key In objdict.Keys
	WScript.StdOut.WriteLine key & " = " & objdict.Item(key)
Next

objfile.Close
Set objfso = Nothing
Set objdict = Nothing

Open a text file, count the frequency of each letter, and differentiate between counting all characters or only letters A to Z.


' Align columns - RC - VBScript
	Const nr=16, nc=16
	ReDim d(nc),t(nr), wor(nr,nc)
	i=i+1: t(i) = "Given$a$text$file$of$many$lines,$where$fields$within$a$line$"
	i=i+1: t(i) = "are$delineated$by$a$single$'dollar'$character,$write$a$program"
	i=i+1: t(i) = "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$"
	i=i+1: t(i) = "column$are$separated$by$at$least$one$space."
	i=i+1: t(i) = "Further,$allow$for$each$word$in$a$column$To$be$either$left$"
	i=i+1: t(i) = "justified,$right$justified,$or$center$justified$within$its$column."
	For r=1 to nr
		If t(r)="" Then Exit For
		w=xRTrim(t(r),"$")
		m=Split(w,"$")
		For c=1 To UBound(m)+1
			wor(r,c)=m(c-1)
			If Len(wor(r,c))>d(c) Then d(c)=Len(wor(r,c))
		Next 'c
		If c>cols Then cols=c
	Next 'r
	rows=r-1
	tt=Array("Left","Right","Center")
	For n=1 To 3
		Wscript.Echo
		Wscript.Echo "*****" & tt(n-1) & "*****"
		For r=1 To rows
			w=""
			For c=1 To cols
				x=wor(r,c): s=Space(d(c))
				Select Case n
					Case 1: w=w &" "& Left   (x & s,d(c))
					Case 2: w=w &" "& Right  (s & x,d(c))
					Case 3: w=w &" "& xCentre(x,d(c)," ")
				End Select 'n
			Next 'c
			Wscript.Echo Mid(w,2)
		Next 'r
	Next 'n

Function xCentre(c, n, Pad)
    Dim j
    If n > Len(c) Then
		j = (n - Len(c)) \  2
		If (n - Len(c)) Mod 2 <> 0 Then j = j + 1
		xCentre = Mid(String(j, Pad) & c & String(j, Pad), 1, n)
    Else
		xCentre = c
    End If
End Function 'xCentre

Function xRTrim(c, Pad)
	Dim i2, l, cc
	cc = "": l = Len(c)
	If l > 0 Then
		i2 = l
		Do While (Mid(c, i2, 1) = Pad And i2 > 1)
			i2 = i2 - 1
		Loop
		If i2 = 1 And Mid(c, i2, 1) = Pad Then i2 = 0
		If i2 > 0 Then cc = Mid(c, 1, i2)
	End If
	xRTrim = cc
End Function 'xRTrim

The code reads a text file with lines separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. It also allows each word in a column to be left, right, or center justified. The minimum space between columns is computed from the text, not hard-coded. Trailing dollar characters or consecutive spaces at the end of lines do not affect the alignment. The output is suitable for viewing in a mono-spaced font on a plain text editor or basic terminal.


x = 6 : y = 2 : z = 3

Sub cuboid(nx, ny, nz)
   WScript.StdOut.WriteLine "Cuboid " & nx & " " & ny & " " & nz & ":"
   lx = X * nx : ly = y * ny : lz = z * nz

   'define the array
   Dim area(): ReDim area(ly+lz, lx+ly)
   For i = 0 to ly+lz
      For j = 0 to lx+ly : area(i,j) = " " : Next
   Next

   'drawing lines
   For i = 0 to nz-1 : drawLine area, lx,      0,    Z*i, "-" : Next
   For i = 0 to ny   : drawLine area, lx,    y*i, lz+y*i, "-" : Next
   For i = 0 to nx-1 : drawLine area, lz,    x*i,      0, "|" : Next
   For i = 0 to ny   : drawLine area, lz, lx+y*i,    y*i, "|" : Next
   For i = 0 to nz-1 : drawLine area, ly,     lx,    z*i, "/" : Next
   For i = 0 to nx   : drawLine area, ly,    x*i,     lz, "/" : Next

   'output the cuboid (in reverse)
   For i = UBound(area,1) to 0 Step -1
      linOut = ""
      For j = 0 to UBound(area,2) : linOut = linOut & area(i,j) : Next
      WScript.StdOut.WriteLine linOut
   Next
End Sub

Sub drawLine(arr, n, sx, sy, c)
   Select Case c
      Case "-"
         dx = 1 : dy = 0
      Case "|"
         dx = 0 : dy = 1
      Case "/"
         dx = 1 : dy = 1
   End Select
   For i = 0 to n
      xi = sx + (i * dx) : yi = sy + (i * dy)
      If arr(yi, xi) = " " Then
         arr(yi, xi) = c
      Else
         arr(yi, xi) = "+"
      End If
   Next
End Sub

cuboid 2,3,4

generate a graphical or ASCII art representation of a cuboid with dimensions 2x3x4, ensuring three faces are visible, and allowing for either static or rotational projection.


Set objConn = CreateObject("ADODB.Connection")
Set objCmd = CreateObject("ADODB.Command")
objConn.Provider = "ADsDSOObject"
objConn.Open

Establish a connection to either an Active Directory or Lightweight Directory Access Protocol server.


option explicit

function rot13(a)
  dim b,n1,n,i
  b=""
  for i=1 to len(a)
    n=asc(mid(a,i,1))
    if n>=65 and n<= 91 then
       n1=(((n-65)+13)mod 26)+65
    elseif n>=97 and n<= 123 then
       n1=(((n-97)+13)mod 26)+97
    else
        n1=n
    end if
    b=b & chr(n1)
  next
  rot13=b
end function

const a="The quick brown fox jumps over the lazy dog."
dim b,c
wscript.echo a
b=rot13(a)
wscript.echo b
c=rot13(b)
wscript.echo c

implement a rot-13 function that replaces every letter of the ASCII alphabet with the letter which is "rotated" 13 characters around the 26 letter alphabet. The function should work on both upper and lower case letters, preserve case, and pass all non-alphabetic characters without alteration. Optionally, the function can be wrapped in a utility program that performs rot-13 encoding line-by-line for every line of input in each file listed on its command line or acts as a filter on its standard input.


Option Explicit
Dim i, j, s
For i = 1 To 5
    s = ""
    For j = 1 To i
        s = s + "*"
    Next
    WScript.Echo s
Next

demonstrate how to use nested for loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop, resulting in a pattern of increasing asterisks.


Implementationoption explicit

class List
	private theList
	private nOccupiable
	private nTop

	sub class_initialize
		nTop = 0
		nOccupiable = 100
		redim theList( nOccupiable )
	end sub

	public sub store( x )
		if nTop >= nOccupiable then
			nOccupiable = nOccupiable + 100
			redim preserve theList( nOccupiable )
		end if
		theList( nTop ) = x
		nTop = nTop + 1
	end sub

	public function recall( n )
		if n >= 0 and n <= nOccupiable then
			recall = theList( n )
		else
			err.raise vbObjectError + 1000,,"Recall bounds error"
		end if
	end function

	public sub replace( n, x )
		if n >= 0 and n <= nOccupiable then
			theList( n )  = x
		else
			err.raise vbObjectError + 1001,,"Replace bounds error"
		end if
	end sub

	public property get listCount
		listCount = nTop
	end property

end class

function halve( n )
	halve = int( n / 2 )
end function

function twice( n )
	twice = int( n * 2 )
end function

function iseven( n )
	iseven = ( ( n mod 2 ) = 0 )
end function

function multiply( n1, n2 )
	dim LL
	set LL = new List

	dim RR
	set RR = new List

	LL.store n1
	RR.store n2

	do while n1 <> 1
		n1 = halve( n1 )
		LL.store n1
		n2 = twice( n2 )
		RR.store n2
	loop

	dim i
	for i = 0 to LL.listCount
		if iseven( LL.recall( i ) ) then
			RR.replace i, 0
		end if
	next

	dim total
	total = 0
	for i = 0 to RR.listCount
		total = total + RR.recall( i )
	next

	multiply = total
end functionInvocationwscript.echo multiply(17,34)

The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. These functions are used to implement the Ethiopian multiplication method, which multiplies two integers using only addition, doubling, and halving operations. The multiplication process involves creating a table, discarding rows with even numbers in the left column, and summing the remaining values in the right column.


randomize timer
fail=array("Wrong number of chars","Only figures 0 to 9 allowed","Two or more figures are the same")
p=dopuzzle()
wscript.echo "Bulls and Cows. Guess my 4 figure number!"
do
 do
  wscript.stdout.write vbcrlf & "your move ": s=trim(wscript.stdin.readline)
  c=checkinput(s)
  if not isarray (c) then wscript.stdout.write fail(c) :exit do
  bu=c(0)
  wscript.stdout.write "bulls: " & c(0) & " | cows: " & c(1)
 loop while 0
loop until bu=4
wscript.stdout.write vbcrlf & "You won! "

function dopuzzle()
  dim b(10)
  for i=1 to 4
    do
      r=fix(rnd*10)
    loop until b(r)=0
    b(r)=1:dopuzzle=dopuzzle+chr(r+48)
  next
end function

function checkinput(s)
  dim c(10)
  bu=0:co=0
  if len(s)<>4 then checkinput=0:exit function
  for i=1 to 4
    b=mid(s,i,1)
    if instr("0123456789",b)=0 then checkinput=1 :exit function
		if c(asc(b)-48)<>0 then checkinput=2 :exit function
    c(asc(b)-48)=1
    for j=1 to 4
      if asc(b)=asc(mid(p,j,1)) then
        if i=j then bu=bu+1 else co=co+1
      end if
    next
  next
  checkinput=array(bu,co)
end function

The code generates a random four-digit number from 1 to 9 without duplication. It prompts the user for guesses, rejects malformed guesses, and calculates a score based on the guess. The score is determined by the number of bulls and cows, where a bull is a correct digit in the correct place and a cow is a correct digit in the wrong place. The game ends when the user's guess matches the randomly generated number.


WScript.Echo DotProduct("1,3,-5","4,-2,-1")

Function DotProduct(vector1,vector2)
	arrv1 = Split(vector1,",")
	arrv2 = Split(vector2,",")
	If UBound(arrv1) <> UBound(arrv2) Then
		WScript.Echo "The vectors are not of the same length."
		Exit Function
	End If
	DotProduct = 0
	For i = 0 To UBound(arrv1)
		DotProduct = DotProduct + (arrv1(i) * arrv2(i))
	Next
End Function

Implement a function to calculate the dot product of two vectors of arbitrary length. The function multiplies corresponding elements from each vector and sums the products. The vectors must be of the same length. Example vectors used are [1, 3, -5] and [4, -2, -1].


filepath = "SPECIFY PATH TO TEXT FILE HERE"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objInFile = objFSO.OpenTextFile(filepath,1,False,0)

Do Until objInFile.AtEndOfStream
	line = objInFile.ReadLine
	WScript.StdOut.WriteLine line
Loop

objInFile.Close
Set objFSO = Nothing

"Continuously read words or lines from a text stream until there is no more data available."


the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


arr = Array("710889",_
            "B0YBKJ",_
	    "406566",_
	    "B0YBLH",_
	    "228276",_
	    "B0YBKL",_
	    "557910",_
            "B0YBKR",_
	    "585284",_
	    "B0YBKT",_
	    "12345",_
	    "A12345",_
	    "B00030")

For j = 0 To UBound(arr)
	WScript.StdOut.Write arr(j) & getSEDOLCheckDigit(arr(j))
	WScript.StdOut.WriteLine
Next

Function getSEDOLCheckDigit(str)
	If Len(str) <> 6 Then
		getSEDOLCheckDigit = " is invalid. Only 6 character strings are allowed."
		Exit Function
	End If
	Set mult = CreateObject("Scripting.Dictionary")
	With mult
		.Add "1","1" : .Add "2", "3" : .Add "3", "1"
		.Add "4","7" : .Add "5", "3" : .Add "6", "9"
	End With
	total = 0
	For i = 1 To 6
		s  = Mid(str,i,1)
		If s = "A" Or s = "E" Or s = "I" Or s = "O" Or s = "U" Then
			getSEDOLCheckDigit = " is invalid. Vowels are not allowed."
			Exit Function
		End If
		If Asc(s) >= 48 And Asc(s) <=57 Then
			total = total + CInt(s) * CInt(mult.Item(CStr(i)))
		Else
			total = total + (Asc(s) - 55) * CInt(mult.Item(CStr(i)))
		End If
	Next
	getSEDOLCheckDigit = (10 - total Mod 10) Mod 10
End Function

The code takes a list of 6-digit SEDOLs as input, calculates the checksum digit for each SEDOL, and appends it to the end. It also validates each input to ensure it is correctly formed according to SEDOL string rules.


shades = Array(".", ":", "!", "*", "o", "e", "&", "#", "%", "@")
light = Array(30, 30, -50)

Sub Normalize(v)
   length = Sqr(v(0)*v(0) + v(1)*v(1) + v(2)*v(2))
   v(0) = v(0)/length : v(1) = v(1)/length : v(2) = v(2)/length
End Sub

Function Dot(x, y)
   d = x(0)*y(0) + x(1)*y(1) + x(2)*y(2)
   If d < 0 Then Dot = -d Else Dot = 0 End If
End Function

'floor function is the Int function
'ceil function implementation
Function Ceil(x)
    Ceil = Int(x)
    If Ceil <> x Then Ceil = Ceil + 1 End if
End Function

Sub DrawSphere(R, k, ambient)
   Dim i, j, intensity, inten, b, x, y
   Dim vec(3)
   For i = Int(-R) to Ceil(R)
      x = i + 0.5
      line = ""
      For j = Int(-2*R) to Ceil(2*R)
         y = j / 2 + 0.5
         If x * x + y * y <= R*R Then
            vec(0) = x
            vec(1) = y
            vec(2) = Sqr(R * R - x * x - y * y)
            Normalize vec
            b = dot(light, vec)^k + ambient
            intensity = Int((1 - b) * UBound(shades))
            If intensity < 0 Then intensity = 0 End If
            If intensity >= UBound(shades) Then
               intensity = UBound(shades)
            End If
            line = line & shades(intensity)
         Else
            line = line & " "
         End If
      Next
      WScript.StdOut.WriteLine line
   Next
End Sub

Normalize light
DrawSphere 20, 4, 0.1
DrawSphere 10,2,0.4

"Generates a graphical or ASCII art representation of a sphere, with either static or rotational projection."


Function stripchars(s1,s2)
	For i = 1 To Len(s1)
		If InStr(s2,Mid(s1,i,1)) Then
			s1 = Replace(s1,Mid(s1,i,1),"")
		End If
	Next
	stripchars = s1
End Function

WScript.StdOut.Write stripchars("She was a soul stripper. She took my heart!","aei")

"Function to remove specific characters from a given string"


'The Function
Function FizzBuzz(range, mapping)
    data = Array()

    'Parse the mapping and put to "data" array
    temp = Split(mapping, ",")
    ReDim data(UBound(temp),1)
    For i = 0 To UBound(temp)
        map = Split(temp(i), " ")
        data(i, 0) = map(0)
        data(i, 1) = map(1)
    Next

    'Do the loop
    For i = 1 to range
        noMatch = True
        For j = 0 to UBound(data, 1)
            If (i Mod data(j, 0)) = 0 Then
                WScript.StdOut.Write data(j, 1)
                noMatch = False
            End If
        Next
        If noMatch Then WScript.StdOut.Write i
        WScript.StdOut.Write vbCrLf
    Next
End Function

'The Main Thing
WScript.StdOut.Write "Range? "
x = WScript.StdIn.ReadLine
WScript.StdOut.Write "Mapping? "
y = WScript.StdIn.ReadLine
WScript.StdOut.WriteLine ""
FizzBuzz x, y

Sample Run:
\Desktop>cscript /nologo fizzbuzz.vbs
Range? 20
Mapping? 3 Fizz,5 Buzz,7 Baxx

1
2
Fizz
4
Buzz
Fizz
Baxx
8
Fizz
Buzz
11
Fizz
13
Baxx
FizzBuzz
16
17
Fizz
19
Buzz

\Desktop>

implement a generalized version of FizzBuzz that takes a maximum number and a list of factor-word pairs as inputs from the user. The code prints numbers from 1 to the maximum number, replacing multiples of each factor with the corresponding word. For numbers that are multiples of multiple factors, the associated words are printed in ascending order of their factors.


Creates a string variable with a specific text value, prepends another string literal to it, and displays the content of the variable. If possible, the operation is performed without referring to the variable twice in one expression.


randomize
MyNum=Int(rnd*10)+1
Do
	x=x+1
	YourGuess=InputBox("Enter A number from 1 to 10")
	If not Isnumeric(YourGuess) then
		msgbox YourGuess &" is not numeric. Try again."
	ElseIf CInt(YourGuess)>10 or CInt(YourGuess)<1 then
		msgbox YourGuess &" is not between 1 and 10. Try Again."
	ElseIf CInt(YourGuess)=CInt(MyNum) then
		MsgBox "Well Guessed!"
		wscript.quit
	ElseIf Cint(YourGuess)<>CInt(Mynum) then
		MsgBox "Nope. Try again."
	end If

	if x > 20 then
		msgbox "I take pity on you"
		wscript.quit
	end if
loop

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


Function ASCII_Sequence(range)
	arr = Split(range,"..")
	For i = Asc(arr(0)) To Asc(arr(1))
		ASCII_Sequence = ASCII_Sequence & Chr(i) & " "
	Next
End Function

WScript.StdOut.Write ASCII_Sequence(WScript.Arguments(0))
WScript.StdOut.WriteLine

generate a sequence of all lower case ASCII characters from a to z. This is done in a reliable coding style suitable for large programs, using strong typing if available. The code avoids manual enumeration of characters to prevent bugs. It also demonstrates how to access a similar sequence from the standard library if it exists.


Option Explicit
Dim bin
bin=Array("    ","   I","  I ","  II"," I  "," I I"," II "," III","I   ","I  I","I I ","I II"," I  ","II I","III ","IIII")

Function num2bin(n)
 Dim s,i,n1,n2
 s=Hex(n)
 For i=1 To Len(s)
   n1=Asc(Mid(s,i,1))
   If n1>64 Then n2=n1-55 Else n2=n1-48
   num2bin=num2bin & bin(n2)
 Next
 num2bin=Replace(Replace(LTrim(num2bin)," ","0"),"I",1)
 End Function

 Sub print(s):
     On Error Resume Next
     WScript.stdout.WriteLine (s)
     If  err= &h80070006& Then WScript.Echo " Please run this script with CScript": WScript.quit
 End Sub
 print num2bin(5)
 print num2bin(50)
 print num2bin(9000)

generate a sequence of binary digits for a given non-negative integer, without leading zeros or any other whitespace, radix, or sign markers. The output is displayed line by line. The function can use built-in radix functions or a user-defined function.


Set ofso = CreateObject("Scripting.FileSystemObject")
Set config = ofso.OpenTextFile(ofso.GetParentFolderName(WScript.ScriptFullName)&"\config.txt",1)

config_out = ""

Do Until config.AtEndOfStream
	line = config.ReadLine
	If Left(line,1) <> "#" And Len(line) <> 0 Then
		config_out = config_out & parse_var(line) & vbCrLf
	End If
Loop

WScript.Echo config_out

Function parse_var(s)
	'boolean false
	If InStr(s,";") Then
		parse_var = Mid(s,InStr(1,s,";")+2,Len(s)-InStr(1,s,";")+2) & " = FALSE"
	'boolean true
	ElseIf UBound(Split(s," ")) = 0 Then
		parse_var = s & " = TRUE"
	'multiple parameters
	ElseIf InStr(s,",") Then
		var = Left(s,InStr(1,s," ")-1)
		params = Split(Mid(s,InStr(1,s," ")+1,Len(s)-InStr(1,s," ")+1),",")
		n = 1 : tmp = ""
		For i = 0 To UBound(params)
			parse_var = parse_var & var & "(" & n & ") = " & LTrim(params(i)) & vbCrLf
			n = n + 1
		Next
	'single var and paramater
	Else
		parse_var = Left(s,InStr(1,s," ")-1) & " = " & Mid(s,InStr(1,s," ")+1,Len(s)-InStr(1,s," ")+1)
	End If
End Function

config.Close
Set ofso = Nothing

read a configuration file and set variables based on the contents. It ignores lines starting with a hash or semicolon and blank lines. It sets variables 'fullname', 'favouritefruit', 'needspeeling', and 'seedsremoved' based on the file entries. It also stores multiple parameters from the 'otherfamily' entry into an array.


Library: Microsoft.XmlHTTP

Option Explicit

Const sURL="http://rosettacode.org/"

Dim oHTTP
Set oHTTP = CreateObject("Microsoft.XmlHTTP")

On Error Resume Next
oHTTP.Open "GET", sURL, False
oHTTP.Send ""
If Err.Number = 0 Then
     WScript.Echo oHTTP.responseText
Else
     Wscript.Echo "error " & Err.Number & ": " & Err.Description
End If

Set oHTTP = Nothing

Accesses and prints the content of a specified URL using HTTP protocol. The code is based on the Microsoft.XmlHttp object method for retrieving HTML web pages with VBScript. Note that handling HTTPS requests is not included in this code.


Function Luhn_Test(cc)
	cc = RevString(cc)
	s1 = 0
	s2 = 0
	For i = 1 To Len(cc)
		If i Mod 2 > 0 Then
			s1 = s1 + CInt(Mid(cc,i,1))
		Else
			tmp = CInt(Mid(cc,i,1))*2
			If  tmp < 10 Then
				s2 = s2 + tmp
			Else
				s2 = s2 + CInt(Right(CStr(tmp),1)) + 1
			End If
		End If
	Next
	If Right(CStr(s1 + s2),1) = "0" Then
		Luhn_Test = "Valid"
	Else
		Luhn_Test = "Invalid"
	End If
End Function

Function RevString(s)
	For i = Len(s) To 1 Step -1
		RevString = RevString & Mid(s,i,1)
	Next
End Function

WScript.Echo "49927398716 is " & Luhn_Test("49927398716")
WScript.Echo "49927398717 is " & Luhn_Test("49927398717")
WScript.Echo "1234567812345678 is " & Luhn_Test("1234567812345678")
WScript.Echo "1234567812345670 is " & Luhn_Test("1234567812345670")

The code validates credit card numbers using the Luhn test. It reverses the input number, calculates the sum of odd and even positioned digits (with even digits being doubled and if the result is greater than nine, the digits of the result are summed). If the total sum ends in zero, the number is deemed valid. The code tests this functionality on four given numbers.


Works with: Windows Script Host version *
' VBScript has a String() function that can repeat a character a given number of times
' but this only works with single characters (or the 1st char of a string):
WScript.Echo String(10, "123")	' Displays "1111111111"

' To repeat a string of chars, you can use either of the following "hacks"...
WScript.Echo Replace(Space(10), " ", "Ha")
WScript.Echo Replace(String(10, "X"), "X", "Ha")

The code takes a string or a character as input and repeats it a specified number of times. For example, if the input is "ha" and 5, the output will be "hahahahaha". Similarly, if the input is "*" and 5, the output will be "*****".


text = "I need more coffee!!!"
Set regex = New RegExp
regex.Global = True
regex.Pattern = "\s"
If regex.Test(text) Then
	WScript.StdOut.Write regex.Replace(text,vbCrLf)
Else
	WScript.StdOut.Write "No matching pattern"
End If

Input:
I need more coffee!!!

"Matches a string with a regular expression and substitutes a part of the string using another regular expression, also replaces white spaces with line breaks."


option explicit
dim a, b
wscript.stdout.write "A? "
a = wscript.stdin.readline
wscript.stdout.write "B? "
b = wscript.stdin.readline

a = int( a )
b = int( b )

wscript.echo "a + b=", a + b
wscript.echo "a - b=", a - b
wscript.echo "a * b=", a * b
wscript.echo "a / b=", a / b
wscript.echo "a \ b=", a \ b
wscript.echo "a mod b=", a mod b
wscript.echo "a ^ b=", a ^ b
Another
option explicit
dim a, b
wscript.stdout.write "A? "
a = wscript.stdin.readline
wscript.stdout.write "B? "
b = wscript.stdin.readline

a = int( a )
b = int( b )

dim op
for each op in split("+ - * / \ mod ^", " ")
	wscript.echo "a",op,"b=",eval( "a " & op & " b")
next
C:\foo>arithmetic.vbs
A? 45
B? 11
a + b= 4511
a - b= 34
a * b= 495
a / b= 4.09090909090909
a \ b= 4
a mod b= 1
a ^ b= 1.5322783012207E+18

take two integers as input from the user and display their sum, difference, product, integer quotient, remainder, and exponentiation. The code also indicates how the quotient is rounded and the sign of the remainder. It does not include error handling. A bonus feature is an example of the integer `divmod` operator. The code is inspired by Python and is designed to give the same output for the same input. Variables in the code may be converted from integer to other types if necessary.


Function CountSubstring(str,substr)
	CountSubstring = 0
	For i = 1 To Len(str)
		If Len(str) >= Len(substr) Then
			If InStr(i,str,substr) Then
				CountSubstring = CountSubstring + 1
				i = InStr(i,str,substr) + Len(substr) - 1
			End If
		Else
			Exit For
		End If
	Next
End Function

WScript.StdOut.Write CountSubstring("the three truths","th") & vbCrLf
WScript.StdOut.Write CountSubstring("ababababab","abab") & vbCrLf

function CountSubstring(str,substr)
  with new regexp
     .pattern=substr
     .global=true
     set m=.execute(str)
  end with
  CountSubstring =m.count
end function
WScript.StdOut.Writeline CountSubstring("the three truths","th")
WScript.StdOut.Writeline CountSubstring("ababababab","abab")

The code defines a function to count the number of non-overlapping occurrences of a specific substring within a given string. The function takes two arguments, the main string and the substring to search for, and returns an integer count. The function does not count overlapping substrings and matches from left-to-right or right-to-left to yield the highest number of non-overlapping matches.


Sub Move(n,fromPeg,toPeg,viaPeg)
	If n > 0 Then
		Move n-1, fromPeg, viaPeg, toPeg
		WScript.StdOut.Write "Move disk from " & fromPeg & " to " & toPeg
		WScript.StdOut.WriteBlankLines(1)
		Move n-1, viaPeg, toPeg, fromPeg
	End If
End Sub

Move 4,1,2,3
WScript.StdOut.Write("Towers of Hanoi puzzle completed!")

"Implement a recursive solution to solve the Towers of Hanoi problem, based on the BASIC256 version."


Function binomial(n,k)
	binomial = factorial(n)/(factorial(n-k)*factorial(k))
End Function

Function factorial(n)
	If n = 0 Then
		factorial = 1
	Else
		For i = n To 1 Step -1
			If i = n Then
				factorial = n
			Else
				factorial = factorial * i
			End If
		Next
	End If
End Function

'calling the function
WScript.StdOut.Write "the binomial coefficient of 5 and 3 = " & binomial(5,3)
WScript.StdOut.WriteLine

The code calculates any binomial coefficient using the provided formula. It is specifically designed to output the binomial coefficient of 5 choose 3, which is 10. It also includes tasks for generating combinations and permutations, both with and without replacement.


The code calculates the character and byte length of a string, correctly handling encodings like UTF-8 and UTF-16. It accurately counts Unicode code points as individual characters, not user-visible graphemes or code unit counts. It also provides the string length in graphemes if possible. It returns the number of bytes required to store a string in memory and the length of the string, returning null if the string is null.


Function TopNTail(s,mode)
    Select Case mode
        Case "top"
            TopNTail = Mid(s,2,Len(s)-1)
        Case "tail"
            TopNTail = Mid(s,1,Len(s)-1)
        Case "both"
            TopNTail = Mid(s,2,Len(s)-2)
    End Select
End Function

WScript.Echo "Top: UPRAISERS = " & TopNTail("UPRAISERS","top")
WScript.Echo "Tail: UPRAISERS = " & TopNTail("UPRAISERS","tail")
WScript.Echo "Both: UPRAISERS = " & TopNTail("UPRAISERS","both")

The code demonstrates how to remove the first, last, and both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16, referencing logical characters, not code units. It doesn't necessarily support all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


Dim grid(9, 9)
Dim gridSolved(9, 9)

Public Sub Solve(i, j)
    If i > 9 Then
        'exit with gridSolved = Grid
        For r = 1 To 9
	    For c = 1 To 9
	        gridSolved(r, c) = grid(r, c)
	    Next 'c
        Next 'r
        Exit Sub
    End If
    For n = 1 To 9
        If isSafe(i, j, n) Then
          nTmp = grid(i, j)
          grid(i, j) = n
          If j = 9 Then
                Solve i + 1, 1
          Else
                Solve i, j + 1
          End If
          grid(i, j) = nTmp
        End If
    Next 'n
End Sub 'Solve

Public Function isSafe(i, j, n)
    If grid(i, j) <> 0 Then
        isSafe = (grid(i, j) = n)
        Exit Function
    End If
    'grid(i,j) is an empty cell. Check if n is OK
    'first check the row i
    For c = 1 To 9
        If grid(i, c) = n Then
            isSafe = False
            Exit Function
        End If
    Next 'c
    'now check the column j
    For r = 1 To 9
        If grid(r, j) = n Then
            isSafe = False
            Exit Function
        End If
    Next 'r
    'finally, check the 3x3 subsquare containing grid(i,j)
    iMin = 1 + 3 * Int((i - 1) / 3)
    jMin = 1 + 3 * Int((j - 1) / 3)
    For r = iMin To iMin + 2
        For c = jMin To jMin + 2
            If grid(r, c) = n Then
                isSafe = False
                Exit Function
            End If
        Next 'c
    Next 'r
    'all tests were OK
    isSafe = True
End Function 'isSafe

Public Sub Sudoku()
    'main routine
   Dim s(9)
    s(1) = "001005070"
    s(2) = "920600000"
    s(3) = "008000600"
    s(4) = "090020401"
    s(5) = "000000000"
    s(6) = "304080090"
    s(7) = "007000300"
    s(8) = "000007069"
    s(9) = "010800700"
    For i = 1 To 9
        For j = 1 To 9
            grid(i, j) = Int(Mid(s(i), j, 1))
        Next 'j
    Next 'j
    'print problem
    Wscript.echo "Problem:"
    For i = 1 To 9
	    c=""
        For j = 1 To 9
            c=c & grid(i, j) & " "
        Next 'j
	    Wscript.echo c
    Next 'i
    'solve it!
    Solve 1, 1
    'print solution
    Wscript.echo "Solution:"
    For i = 1 To 9
	    c=""
        For j = 1 To 9
            c=c & gridSolved(i, j) & " "
        Next 'j
	    Wscript.echo c
    Next 'i
End Sub 'Sudoku

Call sudoku

"Solves a partially filled 9x9 Sudoku grid and displays the result in a human-readable format. The solution is optimized for console mode with cscript and is adapted from a faster C solution. The implementation is guided by the Algorithmics of Sudoku and a Python Sudoku Solver Computerphile video."


Implementation
function shuffle( a )
	dim i
	dim r
	randomize timer
	for i = lbound( a ) to ubound( a )
		r = int( rnd * ( ubound( a ) + 1 )  )
		if r <> i then
			swap a(i), a(r)
		end if
	next
	shuffle = a
end function

sub swap( byref a, byref b )
	dim tmp
	tmp = a
	a = b
	b = tmp
end sub
Invocation
dim a
a = array( 1,2,3,4,5,6,7,8,9)
wscript.echo "before: ", join( a, ", " )
shuffle a
wscript.echo "after: ", join( a, ", " )
shuffle a
wscript.echo "after: ", join( a, ", " )
wscript.echo "--"
a = array( now(), "cow", 123, true, sin(1), 16.4 )
wscript.echo "before: ", join( a, ", " )
shuffle a
wscript.echo "after: ", join( a, ", " )
shuffle a
wscript.echo "after: ", join( a, ", " )

implement the Knuth shuffle (also known as the Fisher-Yates shuffle) algorithm. This algorithm randomly shuffles the elements of an array in-place. The shuffling process involves iterating from the last index of the array down to 1, and for each index, swapping the element at that index with an element at a random index within the range of 0 to the current index. If in-place modification of the array is not possible in the used programming language, the algorithm can be adjusted to return a new shuffled array. The algorithm can also be modified to iterate from left to right if needed.


Works with: Windows Script Host
strUserIn = InputBox("Enter Data")
Wscript.Echo strUserIn

"Implement functionality to accept a string and the integer 75000 as inputs from a graphical user interface."


	str = "IT WAS THE BEST OF TIMES, IT WAS THE WORST OF TIMES."

	Wscript.Echo str
	Wscript.Echo Rotate(str,5)
	Wscript.Echo Rotate(Rotate(str,5),-5)

	'Rotate (Caesar encrypt/decrypt) test <numpos> positions.
	'  numpos < 0 - rotate left
	'  numpos > 0 - rotate right
	'Left rotation is converted to equivalent right rotation

	Function Rotate (text, numpos)

		dim dic: set dic = CreateObject("Scripting.Dictionary")
		dim ltr: ltr = Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z")
		dim rot: rot = (26 + numpos Mod 26) Mod 26 'convert all to right rotation
		dim ch
		dim i

		for i = 0 to ubound(ltr)
			dic(ltr(i)) = ltr((rot+i) Mod 26)
		next

		Rotate = ""

		for i = 1 to Len(text)
			ch = Mid(text,i,1)
			if dic.Exists(ch) Then
				Rotate = Rotate & dic(ch)
			else
				Rotate = Rotate & ch
			end if
		next

	End Function

implement both encoding and decoding functionalities of a Caesar cipher. The key for the cipher is an integer between 1 and 25, which determines the rotation of the alphabet letters. The encoding process replaces each letter with the next 1st to 25th letter in the alphabet, with a wrap from Z to A. The cipher is identical to Vigenère cipher with a key of length 1 and Rot-13 with key 13. All left rotations are converted to equivalent right rotations before translation.


Function LCM(a,b)
	LCM = POS((a * b)/GCD(a,b))
End Function

Function GCD(a,b)
	Do
		If a Mod b > 0 Then
			c = a Mod b
			a = b
			b = c
		Else
			GCD = b
			Exit Do
		End If
	Loop
End Function

Function POS(n)
	If n < 0 Then
		POS = n * -1
	Else
		POS = n
	End If
End Function

i = WScript.Arguments(0)
j = WScript.Arguments(1)

WScript.StdOut.Write "The LCM of " & i & " and " & j & " is " & LCM(i,j) & "."
WScript.StdOut.WriteLine

calculate the least common multiple (LCM) of two integers m and n. The LCM is the smallest positive integer that has both m and n as factors. If either m or n is zero, the LCM is zero. The LCM can be calculated by iterating all the multiples of m until finding one that is also a multiple of n, or by using the formula lcm(m, n) = |m × n| / gcd(m, n), where gcd is the greatest common divisor. The LCM can also be found by merging the prime decompositions of both m and n.


    '''''''''''''''''''''''''''''''''''''''''''''
    ' Rosetta Code/Rank Languages by Popularity '
    '          VBScript Implementation          '
    '...........................................'

'API Links (From C Code)
URL1 = "http://www.rosettacode.org/mw/api.php?format=json&action=query&generator=categorymembers&gcmtitle=Category:Programming%20Languages&gcmlimit=500&prop=categoryinfo&rawcontinue"
URL2 = "http://www.rosettacode.org/mw/api.php?format=json&action=query&generator=categorymembers&gcmtitle=Category:Programming%20Languages&gcmlimit=500&prop=categoryinfo&gcmcontinue="

'Get Contents of the API from the Web...
Function ScrapeGoat(link)
    On Error Resume Next
    ScrapeGoat = ""
    Err.Clear
    Set objHttp = CreateObject("Msxml2.ServerXMLHTTP")
    objHttp.Open "GET", link, False
    objHttp.Send
    If objHttp.Status = 200 And Err = 0 Then ScrapeGoat = objHttp.ResponseText
    Set objHttp = Nothing
End Function

'HACK: Setup HTML for help of my partner/competitor that is better than me, JavaScript...
Set HTML = CreateObject("HtmlFile")
Set HTMLWindow = HTML.ParentWindow

    ''''''''''''''''''''
    ' Main code begins '
    '..................'

On Error Resume Next

isComplete = 0    ' 1 -> Complete Already
cntLoop = 0       ' Counts Number of Loops Done
Set outputData = CreateObject("Scripting.Dictionary")

Do
    'Scrape Data From API
    If cntLoop = 0 Then strData = ScrapeGoat(URL1) Else strData = ScrapeGoat(URL2 & gcmCont)
    If Len(strData) = 0 Then
        Set HTML = Nothing
        WScript.StdErr.WriteLine "Processing of data stopped because API query failed."
        WScript.Quit(1)
    End If

    'Parse JSON HACK
    HTMLWindow.ExecScript "var json = " & strData, "JavaScript"
    Set ObjJS = HTMLWindow.json

    Err.Clear    'Test if Query is Complete Already
    batchCompl = ObjJS.BatchComplete
    If Err.Number = 438 Then
        'Query not yet complete. Get gcmContinue instead.
        gcmCont = ObjJS.[Query-Continue].CategoryMembers.gcmContinue
    Else
        isComplete = 1    'Yes!
    End If

    'HACK #2: Put all language page ids into a JS array to be accessed by VBScript
    HTMLWindow.ExecScript "var langs=new Array(); for(var lang in json.query.pages){langs.push(lang);}" & _
                          "var nums=langs.length;", "JavaScript"
    Set arrLangs = HTMLWindow.langs
    arrLength = HTMLWindow.nums

    For i = 0 to arrLength - 1
        BuffStr = "ObjJS.Query.Pages.[" & Eval("arrLangs.[" & i & "]") & "]"
        EachStr = Eval(BuffStr & ".title")

        Err.Clear
        CntLang =  Eval(BuffStr & ".CategoryInfo.Pages")
        If InStr(EachStr, "Category:") = 1 And Err.Number = 0 Then
            outputData.Add Replace(EachStr, "Category:", "", 1, 1), CntLang
        End If
    Next

    cntLoop = cntLoop + 1
Loop While isComplete = 0
'The outputData now contains the data we need. We should now sort and print it!

'Make a 2D array with copy of outputData
arrRelease = Array()
ReDim arrRelease(UBound(outputData.Keys), 1)

outKeys = outputData.Keys
outItem = outputData.Items
For i = 0 To UBound(outKeys)
    arrRelease(i, 0) = outKeys(i)
    arrRelease(i, 1) = outItem(i)
Next

'Bubble Sort (Greatest to Least Number of Examples)
For i = 0 to UBound(arrRelease, 1)
    For j = 0 to UBound(arrRelease, 1) - 1
        If arrRelease(j, 1) < arrRelease(j + 1, 1) Then
            temp1 = arrRelease(j + 1, 0)
            temp2 = arrRelease(j + 1, 1)
            arrRelease(j + 1, 0) = arrRelease(j, 0)
            arrRelease(j + 1, 1) = arrRelease(j, 1)
            arrRelease(j, 0) = temp1
            arrRelease(j, 1) = temp2
        End If
    Next
Next

'Save contents to file instead to support Unicode Names
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set txtOut = objFSO.CreateTextFile(".\OutVBRC.txt", True, True)

txtOut.WriteLine "As of " & Now & ", RC has " & UBound(arrRelease) + 1 & " languages."
txtOut.WriteLine ""
For i = 0 to UBound(arrRelease)
    txtOut.WriteLine arrRelease(i, 1) & " Examples - " & arrRelease(i, 0)
Next

'Successfully Done :)
Set HTML = Nothing
Set objFSO = Nothing
WScript.Quit(0)

Some Parts of Output as of December 31, 2016:
As of 12/31/2016 11:52:05 PM, RC has 624 languages.

917 Examples - Racket
906 Examples - Python
894 Examples - Tcl
859 Examples - J
853 Examples - Perl 6
819 Examples - Zkl
813 Examples - Ruby
796 Examples - C
776 Examples - Java
774 Examples - Go
766 Examples - Haskell
760 Examples - REXX
755 Examples - Perl
750 Examples - D

.
.
.

0 Examples - SheerPower 4GL
0 Examples - Script Basic
0 Examples - VRML
0 Examples - Thistle
0 Examples - UserRPL
0 Examples - WML
0 Examples - VAX Assembly

The code sorts and ranks popular computer programming languages based on the number of members in their respective Rosetta Code categories. It retrieves data either through web scraping or using the API method. The code also includes optional functionality for filtering incorrect results. The sorted and ranked results are saved in a Unicode encoded text file named "OutVBRC.txt".


WScript.Echo Join(Split("Hello,How,Are,You,Today", ","), ".")

Sub Main()
    Dim parseMe As String, parsed As Variant
    parseMe = "Hello,How,Are,You,Today"

    parsed = Split(parseMe, ",")

    Dim L0 As Long, outP As String
    outP = parsed(0)
    For L0 = 1 To UBound(parsed)
        outP = outP & "." & parsed(L0)
    Next

    MsgBox outP
End Sub

"Tokenizes a string by commas into an array, then displays the words separated by a period. No need to know the number of tokens in advance as the array is automatically built."


The function checks if a given string can be interpreted as a numeric value (including floating point and negative numbers) in the syntax of the language, returning true if it is and false if not.


Library: Microsoft.XmlHTTP

Option Explicit

Const sURL="https://sourceforge.net/"

Dim oHTTP
Set oHTTP = CreateObject("Microsoft.XmlHTTP")

On Error Resume Next
oHTTP.Open "GET", sURL, False
oHTTP.Send ""
If Err.Number = 0 Then
     WScript.Echo oHTTP.responseText
Else
     Wscript.Echo "error " & Err.Number & ": " & Err.Description
End If

Set oHTTP = Nothing

send a GET request to the URL "https://www.w3.org/" without authentication, check the host certificate for validity, and print the retrieved resource to the console. It's a contrast to the tasks of HTTP Request and HTTPS request with authentication. The codes are based on the method of retrieving HTML web pages with VBScript via the Microsoft.XmlHttp object.


Works with: Windows Script Host version *
' Read the list of paths (newline-separated) into an array...
strPaths = Split(WScript.StdIn.ReadAll, vbCrLf)

' Split each path by the delimiter (/)...
For i = 0 To UBound(strPaths)
	strPaths(i) = Split(strPaths(i), "/")
Next

With CreateObject("Scripting.FileSystemObject")

	' Test each path segment...
	For j = 0 To UBound(strPaths(0))

		' Test each successive path against the first...
		For i = 1 To UBound(strPaths)
			If strPaths(0)(j) <> strPaths(i)(j) Then Exit For
		Next

		' If we didn't make it all the way through, exit the block...
		If i <= UBound(strPaths) Then Exit For

		' Make sure this path exists...
		If Not .FolderExists(strPath & strPaths(0)(j) & "/") Then Exit For
		strPath = strPath & strPaths(0)(j) & "/"

	Next

End With

' Remove the final "/"...
WScript.Echo Left(strPath, Len(strPath) - 1)

The code finds the common directory path from a given set of directory paths using a specified directory separator character. It tests the functionality using '/' as the directory separator and three specific strings as input paths. The code ensures the returned path is a valid directory, not just the longest common string.


Dim client
Dim result
Set client = CreateObject("MSSOAP.SoapClient")
client.MSSoapInit "http://example.com/soap/wsdl"
result = client.soapFunc("hello")
result = client.anotherSoapFunc(34234)

The code establishes a SOAP client to access and call the functions soapFunc() and anotherSoapFunc() from the WSDL located at http://example.com/soap/wsdl. Note, the task and corresponding code may require further clarification.


Works with: Windows Script Host version *
For i = 1 To 100
	If i Mod 15 = 0 Then
		WScript.Echo "FizzBuzz"
	ElseIf i Mod 5 = 0 Then
		WScript.Echo "Buzz"
	ElseIf i Mod 3 = 0 Then
		WScript.Echo "Fizz"
	Else
		WScript.Echo i
	End If
Next
Works with: Windows Script Host version *
With WScript.StdOut
	For i = 1 To 100
		If i Mod 3 = 0 Then .Write "Fizz"
		If i Mod 5 = 0 Then .Write "Buzz"
		If .Column = 1 Then .WriteLine i Else .WriteLine ""
	Next
End With

print numbers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'.


option explicit

' Raster graphics class in VBSCRIPT by Antoni Gual
'--------------------------------------------
' An array keeps the image allowing to set pixels, draw lines and boxes in it.
' at class destroy a bmp file is saved to disk and the default viewer is called
' The class can work with 8 and 24 bit bmp. With 8 bit uses a built-in palette or can import a custom one

'Declaration :
' Set MyObj = (New ImgClass)(name,width,height, orient,bits_per_pixel,palette_array)
' name:path and name of the file created
' width, height of the canvas
' orient is the way the coord increases, 1 to 4 think of the 4 cuadrants of the caterian plane
'    1 X:l>r Y:b>t   2 X:r>l Y:b>t  3 X:r>l Y:t>b   4 X:l>r  Y:t>b
' bits_per_pixel can bs only 8 and 24
' palette array only to substitute the default palette for 8 bits, else put a 0
' it sets the origin at the corner of the image (bottom left if orient=1)

Class ImgClass
  Private ImgL,ImgH,ImgDepth,bkclr,loc,tt
  private xmini,xmaxi,ymini,ymaxi,dirx,diry
  public ImgArray()  'rgb in 24 bit mode, indexes to palette in 8 bits
  private filename
  private Palette,szpal

  Public Property Let depth (x)
  if depth=8 or depth =24 then
    Imgdepth=depth
  else
    Imgdepth=8
  end if
  bytepix=imgdepth/8
  end property

  Public Property Let Pixel (x,y,color)
  If (x>=ImgL) or x<0 then exit property
  if y>=ImgH or y<0 then exit property
  ImgArray(x,y)=Color
  End Property

  Public Property Get Pixel (x,y)
  If (x<ImgL) And (x>=0) And (y<ImgH) And (y>=0) Then
    Pixel=ImgArray(x,y)
  End If
  End Property

  Public Property Get ImgWidth ()
  ImgWidth=ImgL-1
  End Property

  Public Property Get ImgHeight ()
  ImgHeight=ImgH-1
  End Property

  'constructor (fn,w*2,h*2,32,0,0)
  Public Default Function Init(name,w,h,orient,dep,bkg,mipal)
  'offx, offy posicion de 0,0. si ofx+ , x se incrementa de izq a der, si offy+ y se incrementa de abajo arriba
  dim i,j
  ImgL=w
  ImgH=h
  tt=timer
  set0 0,0   'origin blc positive up and right
  redim imgArray(ImgL-1,ImgH-1)
  bkclr=bkg
  if bkg<>0 then
    for i=0 to ImgL-1
      for j=0 to ImgH-1
        imgarray(i,j)=bkg
      next
    next
  end if
  Select Case orient
    Case 1: dirx=1 : diry=1
    Case 2: dirx=-1 : diry=1
    Case 3: dirx=-1 : diry=-1
    Case 4: dirx=1 : diry=-1
  End select
  filename=name
  ImgDepth =dep
  'load user palette if provided
  if imgdepth=8 then
    loadpal(mipal)
  end if
  set init=me
  end function

  private sub loadpal(mipale)
    if isarray(mipale) Then
      palette=mipale
      szpal=UBound(mipale)+1
    Else
      szpal=256
    'Default palette recycled from ATARI

   End if
  End Sub
  public sub set0 (x0,y0) 'origin can be changed during drawing
    if x0<0 or x0>=imgl or y0<0 or y0>imgh then err.raise 9
    xmini=-x0
    ymini=-y0
    xmaxi=xmini+imgl-1
    ymaxi=ymini+imgh-1

  end sub

  Private Sub Class_Terminate
  if err <>0 then wscript.echo "Error " & err.number
  wscript.echo "writing bmp to file"
    savebmp
    wscript.echo "opening " & filename
    CreateObject("Shell.Application").ShellExecute filename
  wscript.echo timer-tt & " seconds"
  End Sub

 'writes a 32bit integr value as binary to an utf16 string
 function long2wstr( x)  'falta muy poco!!!
      dim k1,k2,x1
      k1=  (x and &hffff&)' or (&H8000& And ((X And &h8000&)<>0)))
      k2=((X And &h7fffffff&) \ &h10000&) Or (&H8000& And (x<0))
      long2wstr=chrw(k1) & chrw(k2)
    end function

    function int2wstr(x)
        int2wstr=ChrW((x and &h7fff) or (&H8000 And (X<0)))
    End Function

  Public Sub SaveBMP
    'Save the picture to a bmp file
    Dim s,ostream, x,y,loc

    const hdrs=54 '14+40
    dim bms:bms=ImgH* 4*(((ImgL*imgdepth\8)+3)\4)  'bitmap size including padding
    dim palsize:if (imgdepth=8) then palsize=szpal*4 else palsize=0

    with  CreateObject("ADODB.Stream") 'auxiliary ostream, it creates an UNICODE with bom stream in memory
      .Charset = "UTF-16LE"    'o "UTF16-BE"
      .Type =  2' adTypeText
      .open

      'build a header
      'bmp header: VBSCript does'nt have records nor writes binary values to files, so we use strings of unicode chars!!
      'BMP header
      .writetext ChrW(&h4d42)                           ' 0 "BM" 4d42
      .writetext long2wstr(hdrs+palsize+bms)            ' 2 fiesize
      .writetext long2wstr(0)                           ' 6  reserved
      .writetext long2wstr (hdrs+palsize)               '10 image offset
       'InfoHeader
      .writetext long2wstr(40)                          '14 infoheader size
      .writetext long2wstr(Imgl)                        '18 image length
      .writetext long2wstr(imgh)                        '22 image width
      .writetext int2wstr(1)                            '26 planes
      .writetext int2wstr(imgdepth)                     '28 clr depth (bpp)
      .writetext long2wstr(&H0)                         '30 compression used 0= NOCOMPR

      .writetext long2wstr(bms)                         '34 imgsize
      .writetext long2wstr(&Hc4e)                       '38 bpp hor
      .writetext long2wstr(&hc43)                       '42 bpp vert
      .writetext long2wstr(szpal)                       '46  colors in palette
      .writetext long2wstr(&H0)                         '50 important clrs 0=all

      'write bitmap
      'precalc data for orientation
       Dim x1,x2,y1,y2
       If dirx=-1 Then x1=ImgL-1 :x2=0 Else x1=0:x2=ImgL-1
       If diry=-1 Then y1=ImgH-1 :y2=0 Else y1=0:y2=ImgH-1

      Select Case imgdepth

      Case 32
        For y=y1 To y2  step diry
          For x=x1 To x2 Step dirx
           'writelong fic, Pixel(x,y)
           .writetext long2wstr(Imgarray(x,y))
          Next
        Next

      Case 8
        'palette
        For x=0 to szpal-1
          .writetext long2wstr(palette(x))  '52
        Next
        'image
        dim pad:pad=ImgL mod 4
        For y=y1 to y2 step diry
          For x=x1 To x2 step dirx*2
             .writetext chrw((ImgArray(x,y) and 255)+ &h100& *(ImgArray(x+dirx,y) and 255))
          Next
          'line padding
          if pad and 1 then .writetext  chrw(ImgArray(x2,y))
          if pad >1 then .writetext  chrw(0)
         Next

      Case Else
        WScript.Echo "ColorDepth not supported : " & ImgDepth & " bits"
      End Select

      'use a second stream to save to file starting past the BOM  the first ADODB.Stream has added
      Dim outf:Set outf= CreateObject("ADODB.Stream")
      outf.Type    = 1 ' adTypeBinary
      outf.Open
      .position=2              'remove bom (1 wchar)
      .CopyTo outf
      .close
      outf.savetofile filename,2   'adSaveCreateOverWrite
      outf.close
    end with
  End Sub
End Class

function mandelpx(x0,y0,maxit)
   dim x,y,xt,i,x2,y2
   i=0:x2=0:y2=0
   Do While i< maxit
     i=i+1
     xt=x2-y2+x0
     y=2*x*y+y0
     x=xt
     x2=x*x:y2=y*y
     If (x2+y2)>=4 Then Exit do
   loop
   if i=maxit then
      mandelpx=0
   else
     mandelpx = i
   end if
end function

Sub domandel(x1,x2,y1,y2)
 Dim i,ii,j,jj,pix,xi,yi,ym
 ym=X.ImgHeight\2
 'get increments in the mandel plane
 xi=Abs((x1-x2)/X.ImgWidth)
 yi=Abs((y2-0)/(X.ImgHeight\2))
 j=0
 For jj=0.  To y2 Step yi
   i=0
   For ii=x1 To x2 Step xi
      pix=mandelpx(ii,jj,256)
      'use simmetry
      X.imgarray(i,ym-j)=pix
      X.imgarray(i,ym+j)=pix
      i=i+1
   Next
   j=j+1
 next
End Sub

'main------------------------------------
Dim i,x
'custom palette
dim pp(255)
for i=1 to 255
   pp(i)=rgb(0,0,255*(i/255)^.25)  'VBS' RGB function is for the web, it's bgr for Windows BMP !!
next

dim fn:fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\mandel.bmp"
Set X = (New ImgClass)(fn,580,480,1,8,0,pp)
domandel -2.,1.,-1.2,1.2
Set X = Nothing

generate and draw the Mandelbrot set using various algorithms and functions.


Function sum_and_product(arr)
	sum = 0
	product = 1
	For i = 0 To UBound(arr)
		sum = sum + arr(i)
		product = product * arr(i)
	Next
	WScript.StdOut.Write "Sum: " & sum
	WScript.StdOut.WriteLine
	WScript.StdOut.Write "Product: " & product
	WScript.StdOut.WriteLine
End Function

myarray = Array(1,2,3,4,5,6)
sum_and_product(myarray)

Calculate the sum and product of all integers in an array.


Function pick_random(arr)
	Set objRandom = CreateObject("System.Random")
	pick_random = arr(objRandom.Next_2(0,UBound(arr)+1))
End Function

WScript.Echo pick_random(Array("a","b","c","d","e","f"))

demonstrate how to select a random element from a list.


Function RegExTest(str,patrn)
    Dim regEx
    Set regEx = New RegExp
    regEx.IgnoreCase = True
    regEx.Pattern = patrn
    RegExTest = regEx.Test(str)
End Function

Function URLDecode(sStr)
    Dim str,code,a0
    str=""
    code=sStr
    code=Replace(code,"+"," ")
    While len(code)>0
        If InStr(code,"%")>0 Then
            str = str & Mid(code,1,InStr(code,"%")-1)
            code = Mid(code,InStr(code,"%"))
            a0 = UCase(Mid(code,2,1))
            If a0="U" And RegExTest(code,"^%u[0-9A-F]{4}") Then
                str = str & ChrW((Int("&H" & Mid(code,3,4))))
                code = Mid(code,7)
            ElseIf a0="E" And RegExTest(code,"^(%[0-9A-F]{2}){3}") Then
                str = str & ChrW((Int("&H" & Mid(code,2,2)) And 15) * 4096 + (Int("&H" & Mid(code,5,2)) And 63) * 64 + (Int("&H" & Mid(code,8,2)) And 63))
                code = Mid(code,10)
            ElseIf a0>="C" And a0<="D" And RegExTest(code,"^(%[0-9A-F]{2}){2}") Then
                str = str & ChrW((Int("&H" & Mid(code,2,2)) And 3) * 64 + (Int("&H" & Mid(code,5,2)) And 63))
                code = Mid(code,7)
            ElseIf (a0<="B" Or a0="F") And RegExTest(code,"^%[0-9A-F]{2}") Then
                str = str & Chr(Int("&H" & Mid(code,2,2)))
                code = Mid(code,4)
            Else
                str = str & "%"
                code = Mid(code,2)
            End If
        Else
            str = str & code
            code = ""
        End If
    Wend
    URLDecode = str
End Function

url = "http%3A%2F%2Ffoo%20bar%C3%A8%2F"
WScript.Echo "Encoded URL: " & url & vbCrLf &_
	"Decoded URL: " & UrlDecode(url)

provide a function to convert URL-encoded strings back into their original unencoded form. It includes test cases for strings like "http%3A%2F%2Ffoo%20bar%2F", "google.com/search?q=%60Abdu%27l-Bah%C3%A1", and "%25%32%35".


option explicit

 const dt = 0.15
 const length=23
 dim ans0:ans0=chr(27)&"["
 dim Veloc,Accel,angle,olr,olc,r,c
const r0=1
const c0=40
 cls
 angle=0.7
 while 1
    wscript.sleep(50)
    Accel = -.9 * sin(Angle)
    Veloc = Veloc + Accel * dt
    Angle = Angle + Veloc * dt

    r = r0 + int(cos(Angle) * Length)
    c = c0+ int(2*sin(Angle) * Length)
    cls
    draw_line r,c,r0,c0
    toxy r,c,"O"

    olr=r :olc=c
wend

sub cls()  wscript.StdOut.Write ans0 &"2J"&ans0 &"?25l":end sub
sub toxy(r,c,s)  wscript.StdOut.Write ans0 & r & ";" & c & "f"  & s :end sub

Sub draw_line(r1,c1, r2,c2)  'Bresenham's line drawing
  Dim x,y,xf,yf,dx,dy,sx,sy,err,err2
  x =r1    : y =c1
  xf=r2    : yf=c2
  dx=Abs(xf-x) : dy=Abs(yf-y)
  If x<xf Then sx=+1: Else sx=-1
  If y<yf Then sy=+1: Else sy=-1
  err=dx-dy
  Do
    toxy x,y,"."
    If x=xf And y=yf Then Exit Do
    err2=err+err
    If err2>-dy Then err=err-dy: x=x+sx
    If err2< dx Then err=err+dx: y=y+sy
  Loop
End Sub 'draw_line

simulate and animate a simple gravity pendulum using a dynamic graphical display. The animation is created in a text mode as VbScript doesn't support graphics mode and should be called from cscript.


Set objNetwork = CreateObject("WScript.Network")
WScript.Echo objNetwork.ComputerName

"Determines and outputs the hostname of the current system where the routine is running."


	s1="Hello"
	s2=s1 & " World!"
	WScript.Echo s2

initialize a string variable, concatenate it with another string literal, and display the content of the variables.


Function UrlEncode(url)
	For i = 1 To Len(url)
		n = Asc(Mid(url,i,1))
		If (n >= 48 And n <= 57) Or (n >= 65 And n <= 90) _
			Or (n >= 97 And n <= 122) Then
			UrlEncode = UrlEncode & Mid(url,i,1)
		Else
			ChrHex = Hex(Asc(Mid(url,i,1)))
                        For j = 0 to (Len(ChrHex) / 2) - 1
			    UrlEncode = UrlEncode & "%" & Mid(ChrHex,(2*j) + 1,2)
                        Next
		End If
	Next
End Function

WScript.Echo UrlEncode("http://foo baré/")

provide a function to convert a given string into URL encoding. This function encodes all characters except 0-9, A-Z, and a-z into their corresponding hexadecimal code preceded by a percent symbol. ASCII control codes, symbols, and extended characters are all converted. The function also supports variations including lowercase escapes and different encoding standards such as RFC 3986 and HTML 5. An optional feature is the use of an exception string for symbols that don't need conversion. For example, "http://foo bar/" is encoded as "http%3A%2F%2Ffoo%20bar%2F".


Const adInteger = 3
Const adVarChar = 200

function charcnt(s,ch)
charcnt=0
for i=1 to len(s)
  if mid(s,i,1)=ch then charcnt=charcnt+1
next
end function

set fso=createobject("Scripting.Filesystemobject")
dim a(122)

sfn=WScript.ScriptFullName
sfn= Left(sfn, InStrRev(sfn, "\"))
set f=fso.opentextfile(sfn & "unixdict.txt",1)

'words to dictionnary using acronym as key
set d=createobject("Scripting.Dictionary")

while not f.AtEndOfStream
  erase a :cnt=0
  s=trim(f.readline)

	'tally chars
  for i=1 to len(s)
   n=asc(mid(s,i,1))
   a(n)=a(n)+1
  next

  'build the anagram
  k=""
  for i= 48 to 122
    if a(i) then k=k & string(a(i),chr(i))
  next

	'add to dict
  if d.exists(k) then
    b=d(k)
    d(k)=b & " " & s
  else
    d(k)=s
  end if
wend

'copy dictionnary to recorset to be able to sort it .Add nr of items as a new field
Set rs = CreateObject("ADODB.Recordset")
rs.Fields.Append "anag", adVarChar, 30
rs.Fields.Append "items", adInteger
rs.Fields.Append "words", adVarChar, 200
rs.open
for each k in d.keys
 rs.addnew
 rs("anag")=k
 s=d(k)
 rs("words")=s
 rs("items")=charcnt(s," ")+1
 rs.update
next
d.removeall

'do the query
rs.sort="items DESC, anag ASC"
rs.movefirst
it=rs("items")
while rs("items")=it
  wscript.echo  rs("items") & " (" &rs("anag") & ") " & rs("words")
  rs.movenext
wend
rs.close

5 (abel) abel able bale bela elba
5 (acert) caret carte cater crate trace
5 (aegln) angel angle galen glean lange
5 (aeglr) alger glare lager large regal
5 (aeln) elan lane lean lena neal
5 (eilv) evil levi live veil vile

"Find the largest sets of anagrams from a given word list (http://wiki.puzzlers.org/pub/wordlists/unixdict.txt) using a dictionary and a recordset."


Option Explicit

Dim objFSO, DBSource

Set objFSO = CreateObject("Scripting.FileSystemObject")

DBSource = objFSO.GetParentFolderName(WScript.ScriptFullName) & "\postal_address.accdb"

With CreateObject("ADODB.Connection")
	.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBSource
	.Execute "CREATE TABLE ADDRESS (STREET VARCHAR(30) NOT NULL," &_
			"CITY VARCHAR(30) NOT NULL, STATE CHAR(2) NOT NULL,ZIP CHAR(5) NOT NULL)"
	.Close
End With

create a table in a database to store US postal addresses, including fields for a unique identifier, street address, city, state code, and zipcode. The codes also demonstrate how to establish a database connection in non-database languages.


Function Encrypt(text,key)
	text = OnlyCaps(text)
	key = OnlyCaps(key)
	j = 1
	For i = 1 To Len(text)
		ms = Mid(text,i,1)
		m = Asc(ms) - Asc("A")
		ks = Mid(key,j,1)
		k = Asc(ks) - Asc("A")
		j = (j Mod Len(key)) + 1
		c = (m + k) Mod 26
		c = Chr(Asc("A")+c)
		Encrypt = Encrypt & c
	Next
End Function

Function Decrypt(text,key)
	key = OnlyCaps(key)
	j = 1
	For i = 1 To Len(text)
		ms = Mid(text,i,1)
		m = Asc(ms) - Asc("A")
		ks = Mid(key,j,1)
		k = Asc(ks) - Asc("A")
		j = (j Mod Len(key)) + 1
		c = (m - k + 26) Mod 26
		c = Chr(Asc("A")+c)
		Decrypt = Decrypt & c
	Next
End Function

Function OnlyCaps(s)
	For i = 1 To Len(s)
		char = UCase(Mid(s,i,1))
		If Asc(char) >= 65 And Asc(char) <= 90 Then
			OnlyCaps = OnlyCaps & char
		End If
	Next
End Function

'testing the functions
orig_text = "Beware the Jabberwock, my son! The jaws that bite, the claws that catch!"
orig_key = "vigenerecipher"
WScript.StdOut.WriteLine "Original: " & orig_text
WScript.StdOut.WriteLine "Key: " & orig_key
WScript.StdOut.WriteLine "Encrypted: " & Encrypt(orig_text,orig_key)
WScript.StdOut.WriteLine "Decrypted: " & Decrypt(Encrypt(orig_text,orig_key),orig_key)

"Implement Vigenère cipher for both encryption and decryption, accommodating keys and text of unequal length. The code also capitalizes all characters and discards non-alphabetic ones. An alternate version uses RegExp for input filtering."


buffer = ""
For i = 2 To 8 Step 2
    buffer = buffer & i & " "
Next
WScript.Echo buffer

demonstrate a for-loop with a step-value greater than one.


Function order_list(arr1,arr2)
	order_list = "FAIL"
	n1 = UBound(arr1): n2 = UBound(arr2)
	n = 0 : p = 0
	If n1 > n2 Then
		max = n2
	Else
		max = n1
	End If
	For i = 0 To max
		If arr1(i) > arr2(i) Then
			n = n + 1
		ElseIf arr1(i) = arr2(i) Then
			p = p + 1
		End If
	Next
	If (n1 < n2 And n = 0) Or _
		 (n1 = n2 And n = 0 And p - 1 <> n1) Or _
		 (n1 > n2 And n = 0 And p = n2) Then
			order_list = "PASS"
	End If
End Function

WScript.StdOut.WriteLine order_list(Array(-1),Array(0))
WScript.StdOut.WriteLine order_list(Array(0),Array(0))
WScript.StdOut.WriteLine order_list(Array(0),Array(-1))
WScript.StdOut.WriteLine order_list(Array(0),Array(0,-1))
WScript.StdOut.WriteLine order_list(Array(0),Array(0,0))
WScript.StdOut.WriteLine order_list(Array(0),Array(0,1))
WScript.StdOut.WriteLine order_list(Array(0,-1),Array(0))
WScript.StdOut.WriteLine order_list(Array(0,0),Array(0))
WScript.StdOut.WriteLine order_list(Array(0,0),Array(1))
WScript.StdOut.WriteLine order_list(Array(1,2,1,3,2),Array(1,2,0,4,4,0,0,0))

"Function to compare and order two numerical lists lexicographically, returning true if the first list should be ordered before the second, and false otherwise."


Implementation
option explicit
'~ dim depth
function ack(m, n)
	'~ wscript.stdout.write depth & " "
	if m = 0 then
		'~ depth = depth + 1
		ack = n + 1
		'~ depth = depth - 1
	elseif m > 0 and n = 0 then
		'~ depth = depth + 1
		ack = ack(m - 1, 1)
		'~ depth = depth - 1
	'~ elseif m > 0 and n > 0 then
	else
		'~ depth = depth + 1
		ack = ack(m - 1, ack(m, n - 1))
		'~ depth = depth - 1
	end if

end function
Invocation
wscript.echo ack( 1, 10 )
'~ depth = 0
wscript.echo ack( 2, 1 )
'~ depth = 0
wscript.echo ack( 4, 4 )

Implement the Ackermann function, a non-primitive recursive function that takes two non-negative arguments and returns a rapidly growing value. The function should ideally support arbitrary precision due to the rapid growth of the function's output.


'N-queens problem - non recursive & structured - vbs - 24/02/2017
const l=15
dim a(),s(),u(): redim a(l),s(l),u(4*l-2)
for i=1 to l: a(i)=i: next
for n=1 to l
    m=0
    i=1
    j=0
    r=2*n-1
    Do
        i=i-1
        j=j+1
        p=0
        q=-r
        Do
            i=i+1
            u(p)=1
            u(q+r)=1
            z=a(j): a(j)=a(i): a(i)=z  'swap a(i),a(j)
            p=i-a(i)+n
            q=i+a(i)-1
            s(i)=j
            j=i+1
        Loop Until j>n Or u(p)<>0 Or u(q+r)<>0
        If u(p)=0 Then
            If u(q+r)=0 Then
                m=m+1  'm: number of solutions
                'x="": for k=1 to n: x=x&" "&a(k): next: msgbox x,,m
             End If
        End If
        j=s(i)
        Do While j>=n And i<>0
            Do
                z=a(j): a(j)=a(i): a(i)=z  'swap a(i),a(j)
                j=j-1
            Loop Until j<i
            i=i-1
            p=i-a(i)+n
            q=i+a(i)-1
            j=s(i)
            u(p)=0
            u(q+r)=0
        Loop
    Loop Until i=0
    wscript.echo n &":"& m
next 'n

"Code solves the N-queens puzzle for a board of size NxN, prints the solutions in raw format, and provides the number of solutions for small values of N as per OEIS: A000170."


Function ArrayConcat(arr1, arr2)
    ReDim ret(UBound(arr1) + UBound(arr2) + 1)
    For i = 0 To UBound(arr1)
        ret(i) = arr1(i)
    Next
    offset = Ubound(arr1) + 1
    For i = 0 To UBound(arr2)
        ret(i + offset) = arr2(i)
    Next
    ArrayConcat = ret
End Function

arr1 = array(10,20,30)
arr2 = array(40,50,60)
WScript.Echo "arr1 = array(" & Join(arr1,", ") & ")"
WScript.Echo "arr2 = array(" & Join(arr2,", ") & ")"
arr3 = ArrayConcat(arr1, arr2)
WScript.Echo "arr1 + arr2 = array(" & Join(arr3,", ") & ")"

demonstrate how to concatenate two arrays.


' Knapsack problem/0-1 - 13/02/2017
dim w(22),v(22),m(22)
data=array( "map", 9, 150, "compass", 13, 35, "water", 153, 200, _
 "sandwich", 50, 160 , "glucose", 15, 60, "tin", 68, 45, _
 "banana", 27, 60, "apple", 39, 40 , "cheese", 23, 30, "beer", 52, 10, _
 "suntan cream", 11, 70, "camera", 32, 30 , "T-shirt", 24, 15, _
 "trousers", 48, 10, "umbrella", 73, 40, "book", 30, 10 , _
 "waterproof trousers", 42, 70, "waterproof overclothes", 43, 75 , _
 "note-case", 22, 80, "sunglasses", 7, 20, "towel", 18, 12, "socks", 4, 50)
ww=400
xw=0:iw=0:iv=0
w(1)=iw:v(1)=iv
for i1=0 to 1:m(1)=i1:j=0
 if i1=1 then
  iw=w(1)+data(j*3+1):iv=v(1)+data(j*3+2)
  if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
 end if 'i1
 if iw<=ww then
  w(2)=iw: v(2)=iv
  for i2=0 to 1:m(2)=i2:j=1
   if i2=1 then
    iw=w(2)+data(j*3+1):iv=v(2)+data(j*3+2)
    if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
   end if 'i2
   if iw<=ww then
    w(3)=iw: v(3)=iv
    for i3=0 to 1:m(3)=i3:j=2
     if i3=1 then
      iw=w(3)+data(j*3+1):iv=v(3)+data(j*3+2)
      if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
     end if 'i3
     if iw<=ww then
      w(4)=iw: v(4)=iv
      for i4=0 to 1:m(4)=i4:j=3
       if i4=1 then
        iw=w(4)+data(j*3+1):iv=v(4)+data(j*3+2)
        if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
       end if 'i4
       if iw<=ww then
        w(5)=iw: v(5)=iv
        for i5=0 to 1:m(5)=i5:j=4
         if i5=1 then
          iw=w(5)+data(j*3+1):iv=v(5)+data(j*3+2)
          if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
         end if 'i5
         if iw<=ww then
          w(6)=iw: v(6)=iv
          for i6=0 to 1:m(6)=i6:j=5
           if i6=1 then
            iw=w(6)+data(j*3+1):iv=v(6)+data(j*3+2)
            if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
           end if 'i6
           if iw<=ww then
            w(7)=iw: v(7)=iv
            for i7=0 to 1:m(7)=i7:j=6
             if i7=1 then
              iw=w(7)+data(j*3+1):iv=v(7)+data(j*3+2)
              if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
             end if 'i7
             if iw<=ww then
              w(8)=iw: v(8)=iv
              for i8=0 to 1:m(8)=i8:j=7
               if i8=1 then
                iw=w(8)+data(j*3+1):iv=v(8)+data(j*3+2)
                if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
               end if 'i8
               if iw<=ww then
                w(9)=iw: v(9)=iv
                for i9=0 to 1:m(9)=i9:j=8
                 if i9=1 then
                  iw=w(9)+data(j*3+1):iv=v(9)+data(j*3+2)
                  if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                 end if 'i9
                 if iw<=ww then
                  w(10)=iw: v(10)=iv
                  for i10=0 to 1:m(10)=i10:j=9
                   if i10=1 then
                    iw=w(10)+data(j*3+1):iv=v(10)+data(j*3+2)
                    if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                   end if 'i10
                   if iw<=ww then
                    w(11)=iw: v(11)=iv
                    for i11=0 to 1:m(11)=i11:j=10
                     if i11=1 then
                      iw=w(11)+data(j*3+1):iv=v(11)+data(j*3+2)
                      if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                     end if 'i11
                     if iw<=ww then
                      w(12)=iw: v(12)=iv
                      for i12=0 to 1:m(12)=i12:j=11
                       if i12=1 then
                        iw=w(12)+data(j*3+1):iv=v(12)+data(j*3+2)
                        if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                       end if 'i12
                       if iw<=ww then
                        w(13)=iw: v(13)=iv
                        for i13=0 to 1:m(13)=i13:j=12
                         if i13=1 then
                          iw=w(13)+data(j*3+1):iv=v(13)+data(j*3+2)
                          if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                         end if 'i13
                         if iw<=ww then
                          w(14)=iw: v(14)=iv
                          for i14=0 to 1:m(14)=i14:j=13
                           if i14=1 then
                            iw=w(14)+data(j*3+1):iv=v(14)+data(j*3+2)
                            if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                           end if 'i14
                           if iw<=ww then
                            w(15)=iw: v(15)=iv
                            for i15=0 to 1:m(15)=i15:j=14
                             if i15=1 then
                              iw=w(15)+data(j*3+1):iv=v(15)+data(j*3+2)
                              if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                             end if 'i15
                             if iw<=ww then
                              w(16)=iw: v(16)=iv
                              for i16=0 to 1:m(16)=i16:j=15
                               if i16=1 then
                                iw=w(16)+data(j*3+1):iv=v(16)+data(j*3+2)
                                if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                               end if 'i16
                               if iw<=ww then
                                w(17)=iw: v(17)=iv
                                for i17=0 to 1:m(17)=i17:j=16
                                 if i17=1 then
                                  iw=w(17)+data(j*3+1):iv=v(17)+data(j*3+2)
                                  if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                 end if 'i17
                                 if iw<=ww then
                                  w(18)=iw: v(18)=iv
                                  for i18=0 to 1:m(18)=i18:j=17
                                   if i18=1 then
                                    iw=w(18)+data(j*3+1):iv=v(18)+data(j*3+2)
                                    if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                   end if 'i18
                                   if iw<=ww then
                                    w(19)=iw: v(19)=iv
                                    for i19=0 to 1:m(19)=i19:j=18
                                     if i19=1 then
                                      iw=w(19)+data(j*3+1):iv=v(19)+data(j*3+2)
                                      if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                     end if 'i19
                                     if iw<=ww then
                                      w(20)=iw: v(20)=iv
                                      for i20=0 to 1:m(20)=i20:j=19
                                       if i20=1 then
                                        iw=w(20)+data(j*3+1):iv=v(20)+data(j*3+2)
                                        if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                       end if 'i20
                                       if iw<=ww then
                                        w(21)=iw: v(21)=iv
                                        for i21=0 to 1:m(21)=i21:j=20
                                         if i21=1 then
                                          iw=w(21)+data(j*3+1):iv=v(21)+data(j*3+2)
                                          if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                         end if 'i21
                                         if iw<=ww then
                                          w(22)=iw: v(22)=iv
                                          for i22=0 to 1:m(22)=i22:j=21
                                           nn=nn+1
                                           if i22=1 then
                                            iw=w(22)+data(j*3+1):iv=v(22)+data(j*3+2)
                                            if iv>xv and iw<=ww then xw=iw:xv=iv:l=m
                                           end if 'i22
                                           if iw<=ww then
                                           end if 'i22
                                          next:m(22)=0
                                         end if 'i21
                                        next:m(21)=0
                                       end if 'i20
                                      next:m(20)=0
                                     end if 'i19
                                    next:m(19)=0
                                   end if 'i18
                                  next:m(18)=0
                                 end if 'i17
                                next:m(17)=0
                               end if 'i16
                              next:m(16)=0
                             end if 'i15
                            next:m(15)=0
                           end if 'i14
                          next:m(14)=0
                         end if 'i13
                        next:m(13)=0
                       end if 'i12
                      next:m(12)=0
                     end if 'i11
                    next:m(11)=0
                   end if 'i10
                  next:m(10)=0
                 end if 'i9
                next:m(9)=0
               end if 'i8
              next:m(8)=0
             end if 'i7
            next:m(7)=0
           end if 'i6
          next:m(6)=0
         end if 'i5
        next:m(5)=0
       end if 'i4
      next:m(4)=0
     end if 'i3
    next:m(3)=0
   end if 'i2
  next:m(2)=0
 end if 'i1
next:m(1)=0
for i=1 to 22
 if l(i)=1 then wlist=wlist&vbCrlf&data((i-1)*3)
next
Msgbox mid(wlist,3)&vbCrlf&vbCrlf&"weight="&xw&vbCrlf&"value="&xv,,"Knapsack - nn="&nn

The code determines the optimal combination of items a tourist can carry in his knapsack, given a maximum weight limit of 4kg. It considers the weight and value of each item, ensuring the total weight does not exceed the limit while maximizing the total value. The solution is non-recursive and runs 13 times faster than its recursive counterpart. Only whole units of any item can be taken.


' Sort a list of object identifiers - VBScript
function myCompare(x,y)
	dim i,b
	sx=split(x,".")
	sy=split(y,".")
	b=false
	for i=0 to ubound(sx)
		if i > ubound(sy) then b=true: exit for
		select case sgn(int(sx(i))-int(sy(i)))
			case  1: b=true:  exit for
			case -1: b=false: exit for
		end select
	next
	myCompare=b
end function

function bubbleSort(t)
	dim i,n
	n=ubound(t)
	do
		changed=false
		n= n-1
		for i=0 to n
			if myCompare(t(i),t(i+1)) then
				tmp=t(i): t(i)=t(i+1): t(i+1)=tmp
				changed=true
			end if
		next
	loop until not changed
	bubbleSort=t
end function

a=array( _
	"1.3.6.1.4.1.11.2.17.19.3.4.0.10", _
	"1.3.6.1.4.1.11.2.17.5.2.0.79", _
	"1.3.6.1.4.1.11.2.17.19.3.4.0.4", _
	"1.3.6.1.4.1.11150.3.4.0.1", _
	"1.3.6.1.4.1.11.2.17.19.3.4.0.1", _
	"1.3.6.1.4.1.11150.3.4.0")
bubbleSort a
wscript.echo join(a,vbCrlf)

sort a list of Object Identifiers (OIDs) in their natural lexicographical order. The OIDs are strings of non-negative integers separated by dots.