Programming corner wildboy85: July 2015

Sunday, July 26, 2015

Bubble sort with supertotal in excel VBA

Hello,

So i decided, as i am a good guy, to reprogram my supertotal bubble sort in excel vba

Not that i am a good guy, but everyone think excel is a god, so i had to...

It will generate 3 excel tables with the dataset example (wich you can replace with a sql query)
It will still generate a log file starting with ZZZ
It will still generate a html file with all the tables

Requirements:
microsoft excel 2013
.xlsm extension (file with macro)
Activation of vba macros if excel present a warning

26/07/2015 19:48:14 Start of bubble sort example

TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting

Index	item	quantity	description
10b.2c.33b	bolt	18	this is a bolt
11a.1c.3b	bolt	1	this is a bolt
1a.2c.33b	bolt	45	this is a bolt
1b.2c.33	bolt	12	this is a bolt
1c.2c	bolt	5	this is a bolt
1z.10c.3b	bolt	2	this is a bolt

TABLE 02 Split all the values to get only numbers and calculate a supertotal

split01	split02	split03	Number	Letter	Number	Letter	Number	Letter	Supertotal
10b	2c	33b	10	2	2	3	33	2	1,1003003004034E+19
11a	1c	3b	11	1	1	3	3	2	1,2002002004004E+19
1a	2c	33b	1	1	2	3	33	2	2,002003004034E+18
1b	2c	33	1	2	2	3	33	0	2,003003004034E+18
1c	2c		1	3	2	3	0	0	2,004003004001E+18
1z	10c	3b	1	26	10	3	3	2	2,027011004004E+18

TABLE 03 sorted after all was converted to number to make a supertotal

Index	item	quantity	description	Supertotal verification (not in DS)
1a.2c.33b	bolt	45	this is a bolt	2,002003004034E+18
1b.2c.33	bolt	12	this is a bolt	2,003003004034E+18
1c.2c	bolt	5	this is a bolt	2,004003004001E+18
1z.10c.3b	bolt	2	this is a bolt	2,027011004004E+18
10b.2c.33b	bolt	18	this is a bolt	1,1003003004034E+19
11a.1c.3b	bolt	1	this is a bolt	1,2002002004004E+19

---------------------- excel VBA macro (alt F11, add module, insert this code) ---------------------

Sub bubblesort01()

'=== bubblesort_wildboy85.vbs
'=== requirement: wscript.exe
'=== very fast bubble sort
'=== by wildboy85 (sergefournier @ hotmail.com)

'=== objects needed
Set objFSo = CreateObject("Scripting.FileSystemObject")
Set objshe = CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")

'=== register base constants
Const hkcr = &H80000000 'HKEY_CLASSES_ROOT
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const hklm = &H80000002 'HKEY_LOCAL_MACHINE
Const hku = &H80000003 'HKEY_USERS
Const hkcc = &H80000005 'HKEY_CURRENT_CONFIG

Const ForReading = 1
Const adVarChar = 200
Const MaxCharacters = 255
Const adDouble = 5

'=== actual drive, actual directory, and "\"
'thepath = Application.ActiveWorkbook.path
thepath = Application.ActiveWorkbook.FullName
p = InStrRev(thepath, "\")
basedir = Left(thepath, p)
filnam = Right(thepath, Len(thepath) - p)

'=== log what we do, in same directory as the script
logall = 1
htmlout = 1

If logall = 1 Then
'=== debug log, get this file name, remove end, change start for ZZZ
'=== remove .vbs
path01 = Left(thepath, Len(thepath) - (Len(thepath) - InStr(thepath, ".") + 1))
name01 = Right(path01, Len(path01) - InStrRev(path01, "\"))
logname01 = "zzz_" & name01 & ".txt"
'=== always have a nice error trapping
err01 = 0: err02 = ""
On Error Resume Next
Set file02 = objFSo.OpenTextFile(logname01, 2, True)
err01 = Err: err02 = Err.Description
On Error GoTo 0
End If
If err01 = 0 Then
logall = 1
Else
'=== flag to tell our program to not write in log file if there is not log file open
logall = 0 '=== could not open logfile, no log
End If

'=== html output file, we want a nice table as output
If htmlout = 1 Then
path01 = Left(thepath, Len(thepath) - (Len(thepath) - InStr(thepath, ".") + 1))
name01 = Right(path01, Len(path01) - InStrRev(path01, "\"))
logname01 = name01 & "_output.html"
'=== always have a nice error trapping
err01 = 0: err02 = ""
On Error Resume Next
Set file03 = objFSo.OpenTextFile(logname01, 2, True)
err01 = Err: err02 = Err.Description
On Error GoTo 0
End If

If err01 = 0 Then
htmlout = 1
Else
'=== flag to tell our program to not write in log file if there is not log file open
htmlout = 0 '=== could not open logfile, no log
End If

If logall = 1 Then file02.WriteLine Date & " " & Time & " START Bubble sort wildboy85"

'=== the dataset could come from a database, but here we will add data ourseleves as an example
Set dataset01 = CreateObject("ADODB.Recordset")

dataset01.Fields.Append "Index", adVarChar, MaxCharacters
If logall = 1 Then file02.WriteLine Date & " " & Time & " First field appended"

dataset01.Fields.Append "item", adVarChar, MaxCharacters
dataset01.Fields.Append "quantity", adDouble
dataset01.Fields.Append "description", adVarChar, MaxCharacters

'dataset01.Fields.Append "supertotal DS", adVarChar, MaxCharacters

dataset01.Open

'=== accessing the column by name is slow, it would be faster by name if we have big loop
dataset01.AddNew
dataset01("Index") = "11a.1c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 1
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1z.10c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 2
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1a.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 45
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1b.2c.33"
dataset01("item") = "bolt"
dataset01("quantity") = 12
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1c.2c"
dataset01("item") = "bolt"
dataset01("quantity") = 5
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "10b.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 18
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.movefirst
'=== how many field? (columns)
fieldscount01 = dataset01.Fields.Count

'=== put the dataset demo in excel page (first) as a table
Dim myarray As Variant
array01 = dataset01.GetRows

'=== get number of rows (dimension 2 of the array)
On Error Resume Next
err01 = 0: err02 = ""
rowcount01 = UBound(array01, 2)
err01 = Err
err02 = Err.Description
On Error GoTo 0

If err01 = 0 Then

'=== 2 dimension in array, we continue (2 row of data is a minimum)
Set Sheet01 = Worksheets(1)

'=== delete old table01 if it exist
tablename01 = "table01"
On Error Resume Next
err01 = 0: err02 = ""
Sheet01.ListObjects(tablename01).Delete
err01 = Err
err02 = Err.Description
On Error GoTo 0

x = 1: y = 1

'=== columns names
For i = 0 To fieldscount01 - 1
Cells(y, x + i).Value = dataset01.Fields(i).Name
Next

'=== range01 include column title
Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
'=== range02 is data only
Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
Range02.Value = Application.WorksheetFunction.Transpose(array01)

Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01

If logall = 1 Then file02.WriteLine Date & " " & Time & " fieldcount: " & fieldscount01

If htmlout = 1 Then file03.WriteLine Date & " " & Time & " Start of bubble sort example<br><br>"

'=== this datasort will order our items badly, as if number 10 was smaller than number 1
dataset01.Sort = "index"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' excel table02 sorted with dataset sort command (as string)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'=== read dataset that was sorted as string
array01 = dataset01.GetRows

'=== delete old table01 if it exist
tablename01 = "table02"
On Error Resume Next
err01 = 0: err02 = ""
Sheet01.ListObjects(tablename01).Delete
err01 = Err
err02 = Err.Description
On Error GoTo 0

x = 1: y = (4 + rowcount01) * 1

'=== columns names
For i = 0 To fieldscount01 - 1
Cells(y, x + i).Value = dataset01.Fields(i).Name
Next

'=== range01 include column title
Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
'=== range02 is data only
Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
Range02.Value = Application.WorksheetFunction.Transpose(array01)

Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01

'=== html table
If htmlout = 1 Then file03.WriteLine " TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting<br>"
If htmlout = 1 Then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"

'=== fields names as columns titles of the table
If htmlout = 1 Then file03.WriteLine "<tr>"
For i = 0 To fieldscount01 - 1
If htmlout = 1 Then file03.WriteLine "<td>" & dataset01.Fields(i).Name & "</td>"
Next
If htmlout = 1 Then file03.WriteLine "</tr>"

dataset01.movefirst
linecount = 0
Dim ara02()

Do While Not (dataset01.EOF) '=== magica loop, row
ReDim Preserve ara02(fieldscount01 - 1, linecount)

If htmlout = 1 Then file03.WriteLine "<tr>"

'=== put all values in an array, because a dataset this basic cannot switch a line of data
For i = 0 To fieldscount01 - 1
value01 = dataset01.Fields(i).Value
If IsNull(value01) Then value01 = ""
value01 = Trim(value01)

If htmlout = 1 Then file03.WriteLine "<td>" & value01 & "</td>"

ara02(i, linecount) = value01
Next
If htmlout = 1 Then file03.WriteLine "</tr>"
linecount = linecount + 1
dataset01.movenext
Loop

If htmlout = 1 Then file03.WriteLine "</table><br>"

'=== now we will split the line we will use to do the sort by number and letter (converted to numbers)
fieldtosort01 = 0 '=== field 0 contain what we want to sort, example: 1a.2b.3c

'=== we assume we will have only 3 data to sort, 1a 2b 3c
dataset01.movefirst
If htmlout = 1 Then file03.WriteLine "<br>TABLE 02 Split all the values to get only numbers and calculate a supertotal"
If htmlout = 1 Then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
If htmlout = 1 Then file03.WriteLine "<tr><td>split01</td><td>split02</td><td>split03</td>"
If htmlout = 1 Then file03.WriteLine "<td>Number</td><td>Letter</td><td>Number</td><td>Letter</td><td>Number</td><td>Letter</td>"
If htmlout = 1 Then file03.WriteLine "<td>Supertotal</td></tr>"

'=== split the chain 1a.2b.3c by adding dots in case 2b.3c does not exist
Dim split(2)
linecount = 0
Dim ara01()

Do While Not (dataset01.EOF) '=== magica loop, row
ReDim Preserve ara01(6, linecount) '=== the last dimension can be redimensionned so we reversed the dimensions

If htmlout = 1 Then file03.WriteLine "<tr>" '=== html line change

value01 = dataset01.Fields(fieldtosort01).Value
'=== clean value in case of dbnull (dbnull cannot be processed)
If IsNull(value01) Then value01 = ""
value01 = Trim(value01)

'=== add dots at the end of string to later split at the dots and get string inbetween
'=== so if the string have no dots, the split will still work and resturn empty string instead of trying to trap errors
value01 = value01 & "...."
split(0) = Left(value01, Len(value01) - (Len(value01) - InStr(value01, ".") + 1))
leftover = Mid(value01, InStr(value01, ".") + 1, Len(value01))
split(1) = Left(leftover, Len(leftover) - (Len(leftover) - InStr(leftover, ".") + 1))
leftover = Mid(leftover, InStr(leftover, ".") + 1, Len(leftover))
split(2) = Left(leftover, Len(leftover) - (Len(leftover) - InStr(leftover, ".") + 1))
If htmlout = 1 Then file03.WriteLine "<td>" & split(0) & "</td><td>" & split(1) & "</td><td>" & split(2) & "</td>"

'=== we now do an array of 6 fields/columns
'=== field0 is 1, field1 is a, field2 is 2, field3 is b, field4 is 3, field5 is c (from 1a.2b.3c)
splitcount = 0
For x03 = 0 To 5 Step 2 'order01, order01 letter, order02, order02 letter, order03, order03 letter (letter --> integer)
'=== split the split to get 2 value, 1 for number, 1 for alpha (split the chain "1a", "2b", "3c")
data01 = Trim(split(splitcount))
len01 = Len(data01)
If len01 > 1 Then
alpha01 = 0
For i = 1 To len01
'=== is this digit alpha?
asc01 = Asc(Mid(data01, i, 1))
If (asc01 > 64 And asc01 < 91) Or (asc01 > 96 And asc01 < 123) Then
alpha01 = 1
'=== this is a letter
If i > 1 Then
val01 = CInt(Left(data01, i - 1))
Else

End If
'=== code de classement final
'if logall=1 then file02.WriteLine "value before: " & data01 & " After: " & val01 & " + " & asc01 & chr(9) & val01+asc01
If asc01 > 96 Then '=== uppercase A
asc01 = asc01 - 96
ElseIf asc01 > 64 Then '=== lowercase a
asc01 = asc01 - 64
End If

ara01(x03, linecount) = val01 '=== new ordering integer for this column

'=== create a new column to class by letter after this one
ara01(x03 + 1, linecount) = asc01

End If
Next
If alpha01 = 0 Then
'=== remove the 0 before
ara01(x03, linecount) = CInt(data01)
ara01(x03 + 1, linecount) = 0
End If
ElseIf len01 > 0 Then
'=== only 1 digit, so we assume it's a number (just to be faster)
ara01(x03, linecount) = data01 '=== new ordering integer for this column

'=== column to class by letter after this one (1 digit = no letter = 0)
ara01(x03 + 1, linecount) = 0
Else
'=== len is 0, we do nothing
ara01(x03, linecount) = 0
ara01(x03 + 1, linecount) = 0
End If
splitcount = splitcount + 1
'=== results, all numerics
If htmlout = 1 Then file03.WriteLine "<td>" & ara01(x03, linecount) & "</td><td>" & ara01(x03 + 1, linecount) & "</td>"

Next

'=== tricky part, doing a supertotal to sort only one number for all six fields/columns
supertotal = 0
mul01 = 5
super02 = ""
For x03 = 0 To 5
'=== do a super total for this line and the next for comparaison
super01 = (ara01(x03, linecount) + 1) * (1000 ^ (mul01 + 1))
supertotal = supertotal + super01
mul01 = mul01 - 1

'==== alphanumeric supertotal add 0 in front pf every digit, not working with dataset.sort either
'super02 = super02 & left("00000", 5-len((ara01(x03,linecount)+1))) & ara01(x03,linecount)+1

Next
'dataset01.fields("supertotal DS").value = super02

ara01(6, linecount) = supertotal
'dataset01.fields("supertotal DS").value = supertotal

If htmlout = 1 Then file03.WriteLine "<td>" & ara01(6, linecount) & "</td>"

linecount = linecount + 1
If htmlout = 1 Then file03.WriteLine "</tr>"
dataset01.movenext

'=== all supertotal must be computed before we can sort
'=== so this loop was to split numbers, letters and compute a supertotal with multiplicated by 1000^positioninfieldvalue(0-5) values
Loop

If htmlout = 1 Then file03.WriteLine "</table>"

'=== sorting loop, using supertotal
'=== we move through dataset at the same time we move in the array that contain supertotal at position 6

If logall = 1 Then file02.WriteLine Date & " " & Time & " START bubble sort with supertotal"

'=== using SORT command from dataset would have been easy now, but noooo, error argument, number to weird
'=== even if this a string, it cannot sort with dateset.sort command
'dataset01.Sort = "supertotal DS"

dataset01.movefirst
'set row = CreateObject("ADODB.Recordsetrow")

'=== exchange lines in dataset, is that possible?
'dataset01.rows(1) = dataset01.rows(0)
'http://www.w3schools.com/asp/ado_ref_recordset.asp

''''''''''''''''''''''''''''''''''''''''''
' bubble sort
''''''''''''''''''''''''''''''''''''''''''
Dim supertotal01(1)
ReDim ara01tempo(linecount - 1)
If logall = 1 Then file02.WriteLine Date & " " & Time & " Bubble order START"
'=== classement bulle, ligne par ligne, 6 fois

For bubble01 = linecount - 2 To 0 Step -1
For y03 = 0 To bubble01 '=== magica loop, row

'=== if supertotal after is smaller, we exchange them

If ara01(6, y03 + 1) < ara01(6, y03) Then
For x04 = 0 To fieldscount01 - 1
'=== save actual matrix x elements
ara01tempo(x04) = ara02(x04, y03)
ara02(x04, y03) = ara02(x04, y03 + 1) '=== go up one row in matrix
ara02(x04, y03 + 1) = ara01tempo(x04)
Next
'=== exchange supertotal also
supertotaltemp = ara01(6, y03)
ara01(6, y03) = ara01(6, y03 + 1)
ara01(6, y03 + 1) = supertotaltemp

End If
Next
Next

If logall = 1 Then file02.WriteLine Date & " " & Time & " END bubble sort"

'=== final result
If htmlout = 1 Then file03.WriteLine "<br>TABLE 03 sorted after all was converted to number to make a supertotal"
If htmlout = 1 Then file03.WriteLine "<br><table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"

'=== fields names as columns titles of the table
If htmlout = 1 Then file03.WriteLine "<tr>"
For i = 0 To fieldscount01 - 1
If htmlout = 1 Then file03.WriteLine "<td>" & dataset01.Fields(i).Name & "</td>"
Next
If htmlout = 1 Then file03.WriteLine "<td>Supertotal verification (not in DS)</td>"
If htmlout = 1 Then file03.WriteLine "</tr>"

For y = 0 To linecount - 1 '=== display results after bubble sort
If htmlout = 1 Then file03.WriteLine "<tr>"
For x = 0 To fieldscount01 - 1
If htmlout = 1 Then file03.WriteLine "<td>" & ara02(x, y) & "</td>"
Next

If htmlout = 1 Then file03.WriteLine "<td>" & ara01(6, y) & "</td>"
If htmlout = 1 Then file03.WriteLine "</tr>"

Next

''''''''''''''''''''''''''''''''''''''''''''''''''''''
' table03 sorted with 6 columns (split of the first column) and super total
''''''''''''''''''''''''''''''''''''''''''''''''''''''
array01 = ara02

If htmlout = 1 Then file03.WriteLine "</table>"

'=== delete old table01 if it exist
tablename01 = "table03"
On Error Resume Next
err01 = 0: err02 = ""
Sheet01.ListObjects(tablename01).Delete
err01 = Err
err02 = Err.Description
On Error GoTo 0

x = 1: y = (4 + rowcount01) * 2

'=== columns names
For i = 0 To fieldscount01 - 1
Cells(y, x + i).Value = dataset01.Fields(i).Name
Next

'=== range01 include column title
Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
'=== range02 is data only
Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
Range02.Value = Application.WorksheetFunction.Transpose(array01)

Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01

If logall = 1 Then file02.WriteLine ""
If logall = 1 Then file02.WriteLine Date & " " & Time & " END"

Else
'=== error array have onle one dimension
MsgBox ("ERROR array only have one dimension" & vbCrLf & "the dataset must have more than one line of data" & vbCrLf & "meaning, 2 dimensions")
End If

If logall = 1 Then file02.Close
If htmlout = 1 Then file03.Close

End Sub

Monday, July 13, 2015

Bubble sort vbs wsh script program by wildboy85

Hello,

Sorting data is easy
Doing it faster than with a regular bubble sort method is a little harder

Aa an example, we will use something not simple
6 columns to sort with numbers and letters
1a.2b.3c
This was originally for a BOM insertion (bill of material)
There is different categories of materials, (numbers) and different sub categories (letters)

We keep numbers + 1
We change letters to numbers + 1
We calculate a super total to sort them out in one bubble pass
On bubble pass is going from element 0 to elementmax - 1
Then another loop inside that will compare element now with element after and switch them if the element after's supertotal is smaller

This is a nested loop, that will loop a lot of time of there is a lot of elements
It would have done it 6 time is we had used a classic method to sort with 6 columns, like SQL do when you use ORDER BY field01, field02, field03, field04, field05, field06

By concatening the 6 field in one supertotal, we can bubble sort only once

This is a vb script
It will generate a log.txt
and a log.html with same start name as the script

Save it with notepad.exe
26/07/2015 19:48:14 Start of bubble sort example

TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting

Index	item	quantity	description
10b.2c.33b	bolt	18	this is a bolt
11a.1c.3b	bolt	1	this is a bolt
1a.2c.33b	bolt	45	this is a bolt
1b.2c.33	bolt	12	this is a bolt
1c.2c	bolt	5	this is a bolt
1z.10c.3b	bolt	2	this is a bolt

TABLE 02 Split all the values to get only numbers and calculate a supertotal

split01	split02	split03	Number	Letter	Number	Letter	Number	Letter	Supertotal
10b	2c	33b	10	2	2	3	33	2	1,1003003004034E+19
11a	1c	3b	11	1	1	3	3	2	1,2002002004004E+19
1a	2c	33b	1	1	2	3	33	2	2,002003004034E+18
1b	2c	33	1	2	2	3	33	0	2,003003004034E+18
1c	2c		1	3	2	3	0	0	2,004003004001E+18
1z	10c	3b	1	26	10	3	3	2	2,027011004004E+18

TABLE 03 sorted after all was converted to number to make a supertotal

Index	item	quantity	description	Supertotal verification (not in DS)
1a.2c.33b	bolt	45	this is a bolt	2,002003004034E+18
1b.2c.33	bolt	12	this is a bolt	2,003003004034E+18
1c.2c	bolt	5	this is a bolt	2,004003004001E+18
1z.10c.3b	bolt	2	this is a bolt	2,027011004004E+18
10b.2c.33b	bolt	18	this is a bolt	1,1003003004034E+19
11a.1c.3b	bolt	1	this is a bolt	1,2002002004004E+19

-------------------------------- bubblesort.vbs -------------------

'=== bubblesort_wildboy85.vbs
'=== requirement: wscript.exe
'=== very fast bubble sort
'=== by wildboy85 (sergefournier @ hotmail.com)

'=== objects needed
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objshe = CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")

'=== register base constants
Const hkcr = &H80000000 'HKEY_CLASSES_ROOT
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const hklm = &H80000002 'HKEY_LOCAL_MACHINE
Const hku = &H80000003 'HKEY_USERS
Const hkcc = &H80000005 'HKEY_CURRENT_CONFIG

Const ForReading = 1
Const adVarChar = 200
Const MaxCharacters = 255
Const adDouble = 5

'=== actual drive, actual directory, and "\"
thepath = WScript.ScriptFullName
p = instrRev(thepath,"\")
basedir = left(thepath,p)
filnam = right(thepath,len(thepath)-p)

'=== windows dir
WinDir = objfso.GetSpecialFolder(0)

'=== restart the script in 32 bits if we are on a 64 bits system
'=== some databases drivers are not yet available in 64 bits
a64 = windir & "\syswow64\wscript.exe"

if objFSO.fileEXISTS(a64) and instr(lcase(wscript.fullname),"syswow64")=0 then
'=== 64 bits system
argchain01 = ""
set args01 = Wscript.Arguments
if args01.count<>0 then
'=== when recalling this script in 32 bits, pass all the parameters
For Each arg01 in args01
argchain01 = argchain01 & " " & arg01
Next
end if
a = """" & a64 & """ """ & basedir & filnam & """" & argchain01
objshe.Run a,0, false
wscript.quit
end if

'=== log what we do, in same directory as the script
logall = 1
htmlout = 1

if logall=1 then
'=== debug log, get this file name, remove end, change start for ZZZ
'=== remove .vbs
path01 = left(thepath,len(thepath)-(len(thepath)-instr(thepath,".")+1))
name01 = right(path01,len(path01)-instrrev(path01,"\"))
logname01 = "zzz_" & name01 & ".txt"
'=== always have a nice error trapping
err01 = 0 : err02 = ""
on error resume next
Set File02 = objFSo.OpenTextFile(logname01, 2, true)
err01 = err : err02 = err.description
on error goto 0
end if
if err01 = 0 then
logall = 1
else
'=== flag to tell our program to not write in log file if there is not log file open
logall = 0 '=== could not open logfile, no log
end if

'=== html output file, we want a nice table as output
if htmlout=1 then
path01 = left(thepath,len(thepath)-(len(thepath)-instr(thepath,".")+1))
name01 = right(path01,len(path01)-instrrev(path01,"\"))
logname01 = name01 & "_output.html"
'=== always have a nice error trapping
err01 = 0 : err02 = ""
on error resume next
Set File03 = objFSo.OpenTextFile(logname01, 2, true)
err01 = err : err02 = err.description
on error goto 0
end if

if err01 = 0 then
htmlout = 1
else
'=== flag to tell our program to not write in log file if there is not log file open
htmlout = 0 '=== could not open logfile, no log
end if

if logall = 1 then file02.WriteLine date & " " & time & " START Bubble sort wildboy85"

'=== the dataset could come from a database, but here we will add data ourseleves as an example
set dataset01 = CreateObject("ADODB.Recordset")

dataset01.Fields.Append "Index", adVarChar, MaxCharacters
if logall = 1 then file02.WriteLine date & " " & time & " First field appended"

dataset01.Fields.Append "item", adVarChar, MaxCharacters
dataset01.Fields.Append "quantity", adDouble
dataset01.Fields.Append "description", adVarChar, MaxCharacters

'dataset01.Fields.Append "supertotal DS", adVarChar, MaxCharacters

dataset01.Open

'=== accessing the column by name is slow, it would be faster by name if we have big loop
dataset01.AddNew
dataset01("Index") = "1a.1c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 1
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1z.10c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 2
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1a.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 45
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1b.2c.33"
dataset01("item") = "bolt"
dataset01("quantity") = 12
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1c.2c"
dataset01("item") = "bolt"
dataset01("quantity") =5
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "10b.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 18
dataset01("description") = "this is a bolt"
dataset01.Update

'=== how many field? (columns)
fieldscount01 = dataset01.fields.count
if logall = 1 then file02.WriteLine date & " " & time & " fieldcount: " & fieldscount01

if htmlout = 1 then file03.WriteLine date & " " & time & " Start of bubble sort example<br><br>"

'=== this datasort will order our items badly, as if number 10 was smaller than number 1
dataset01.Sort = "index"

'=== html table
if htmlout = 1 then file03.WriteLine " TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting<br>"
if htmlout = 1 then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"

'=== fields names as columns titles of the table
if htmlout = 1 then file03.WriteLine "<tr>"
for i = 0 to fieldscount01-1
if htmlout = 1 then file03.WriteLine "<td>" & dataset01.fields(i).name & "</td>"
next
if htmlout = 1 then file03.WriteLine "</tr>"

dataset01.movefirst
linecount = 0
do while not (dataset01.eof) '=== magica loop, row
redim preserve ara02(fieldscount01-1, linecount)

if htmlout = 1 then file03.WriteLine "<tr>"

'=== put all values in an array, because a dataset this basic cannot switch a line of data
for i = 0 to fieldscount01-1
value01 = dataset01.fields(i).value
If IsNull(value01) then value01=""
value01 = Trim(value01)

if htmlout = 1 then file03.WriteLine "<td>" & value01 & "</td>"

ara02(i, linecount) = value01
next
if htmlout = 1 then file03.WriteLine "</tr>"
linecount = linecount + 1
dataset01.movenext
loop

if htmlout = 1 then file03.WriteLine "</table><br>"

'=== now we will split the line we will use to do the sort by number and letter (converted to numbers)
fieldtosort01 = 0 '=== field 0 contain what we want to sort, example: 1a.2b.3c

'=== we assume we will have only 3 data to sort, 1a 2b 3c
dataset01.movefirst
if htmlout = 1 then file03.WriteLine "<br>TABLE 02 Split all the values to get only numbers and calculate a supertotal"
if htmlout = 1 then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
if htmlout = 1 then file03.WriteLine "<tr><td>split01</td><td>split02</td><td>split03</td>"
if htmlout = 1 then file03.WriteLine "<td>Number</td><td>Letter</td><td>Number</td><td>Letter</td><td>Number</td><td>Letter</td>"
if htmlout = 1 then file03.WriteLine "<td>Supertotal</td></tr>"

'=== split the chain 1a.2b.3c by adding dots in case 2b.3c does not exist
dim split(2)
linecount = 0

do while not (dataset01.eof) '=== magica loop, row
redim preserve ara01(6,linecount) '=== the last dimension can be redimensionned so we reversed the dimensions

if htmlout = 1 then file03.WriteLine "<tr>" '=== html line change

value01 = dataset01.fields(fieldtosort01).value
'=== clean value in case of dbnull (dbnull cannot be processed)
If IsNull(value01) then value01=""
value01 = Trim(value01)

'=== add dots at the end of string to later split at the dots and get string inbetween
'=== so if the string have no dots, the split will still work and resturn empty string instead of trying to trap errors
value01 = value01 & "...."
split(0) = left(value01,len(value01)-(len(value01)-instr(value01,".")+1))
leftover = mid(value01,instr(value01,".")+1,len(value01))
split(1)= left(leftover,len(leftover)-(len(leftover)-instr(leftover,".")+1))
leftover = mid(leftover,instr(leftover,".")+1,len(leftover))
split(2) = left(leftover,len(leftover)-(len(leftover)-instr(leftover,".")+1))
if htmlout = 1 then file03.WriteLine "<td>" & split(0) & "</td><td>" & split(1) & "</td><td>" & split(2) & "</td>"

'=== we now do an array of 6 fields/columns
'=== field0 is 1, field1 is a, field2 is 2, field3 is b, field4 is 3, field5 is c (from 1a.2b.3c)
splitcount = 0
for x03 = 0 to 5 step 2 'order01, order01 letter, order02, order02 letter, order03, order03 letter (letter --> integer)
'=== split the split to get 2 value, 1 for number, 1 for alpha (split the chain "1a", "2b", "3c")
data01 = trim(split(splitcount))
len01 = len(data01)
if len01>1 then
alpha01 = 0
for i = 1 to len01
'=== is this digit alpha?
asc01 = ASC(mid(data01,i,1))
if (asc01>64 and ASC01<91) or (asc01 >96 and asc01 <123) then
alpha01 = 1
'=== this is a letter
if i>1 then
val01 = cint(left(data01,i-1))
else

end if
'=== code de classement final
'if logall=1 then file02.WriteLine "value before: " & data01 & " After: " & val01 & " + " & asc01 & chr(9) & val01+asc01
if asc01>96 then '=== uppercase A
asc01 = asc01 - 96
elseif asc01>64 then '=== lowercase a
asc01 = asc01 - 64
end if

ara01(x03,linecount) = val01 '=== new ordering integer for this column

'=== create a new column to class by letter after this one
ara01(x03+1,linecount) = asc01

end if
next
if alpha01 = 0 then
'=== remove the 0 before
ara01(x03,linecount) = cint(data01)
ara01(x03+1,linecount) = 0
end if
elseif len01>0 then
'=== only 1 digit, so we assume it's a number (just to be faster)
ara01(x03,linecount) = data01 '=== new ordering integer for this column

'=== column to class by letter after this one (1 digit = no letter = 0)
ara01(x03+1,linecount) = 0
else
'=== len is 0, we do nothing
ara01(x03,linecount) = 0
ara01(x03+1,linecount) = 0
end if
splitcount = splitcount + 1
'=== results, all numerics
if htmlout = 1 then file03.WriteLine "<td>" & ara01(x03,linecount) & "</td><td>" & ara01(x03+1,linecount) & "</td>"

next

'=== tricky part, doing a supertotal to sort only one number for all six fields/columns
supertotal = 0
mul01 = 5
super02 = ""
for x03 = 0 to 5
'=== do a super total for this line and the next for comparaison
super01 = (ara01(x03,linecount)+1)*(1000^(mul01+1))
supertotal = supertotal + super01
mul01 = mul01 - 1

'==== alphanumeric supertotal add 0 in front pf every digit, not working with dataset.sort either
'super02 = super02 & left("00000", 5-len((ara01(x03,linecount)+1))) & ara01(x03,linecount)+1

next
'dataset01.fields("supertotal DS").value = super02

ara01(6,linecount) = supertotal
'dataset01.fields("supertotal DS").value = supertotal

if htmlout = 1 then file03.WriteLine "<td>" & ara01(6,linecount) & "</td>"

linecount = linecount + 1
if htmlout = 1 then file03.WriteLine "</tr>"
dataset01.movenext

'=== all supertotal must be computed before we can sort
'=== so this loop was to split numbers, letters and compute a supertotal with multiplicated by 1000^positioninfieldvalue(0-5) values
loop

if htmlout = 1 then file03.WriteLine "</table>"

'=== sorting loop, using supertotal
'=== we move through dataset at the same time we move in the array that contain supertotal at position 6

if logall = 1 then file02.WriteLine date & " " & time & " START bubble sort with supertotal"

'=== using SORT command from dataset would have been easy now, but noooo, error argument, number to weird
'=== even if this a string, it cannot sort with dateset.sort command
'dataset01.Sort = "supertotal DS"

dataset01.movefirst
'set row = CreateObject("ADODB.Recordsetrow")

'=== exchange lines in dataset, is that possible?
'dataset01.rows(1) = dataset01.rows(0)
'http://www.w3schools.com/asp/ado_ref_recordset.asp

''''''''''''''''''''''''''''''''''''''''''
' bubble sort
''''''''''''''''''''''''''''''''''''''''''
dim supertotal01(1)
redim ara01tempo(linecount-1)
if logall=1 then file02.WriteLine date & " " & time & " Bubble order START"
'=== classement bulle, ligne par ligne, 6 fois

for bubble01 = linecount-2 to 0 step -1
for y03 = 0 to bubble01 '=== magica loop, row

'=== if supertotal after is smaller, we exchange them

if ara01(6,y03+1) < ara01(6,y03) then
for x04 = 0 to fieldscount01-1
'=== save actual matrix x elements
ara01tempo(x04) = ara02(x04,y03)
ara02(x04,y03) = ara02(x04,y03+1) '=== go up one row in matrix
ara02(x04,y03+1) = ara01tempo(x04)
next
'=== exchange supertotal also
supertotaltemp = ara01(6,y03)
ara01(6,y03) = ara01(6,y03+1)
ara01(6,y03+1) = supertotaltemp

end if
next
next

if logall = 1 then file02.WriteLine date & " " & time & " END bubble sort"

'=== final result
if htmlout = 1 then file03.WriteLine "<br>TABLE 03 sorted after all was converted to number to make a supertotal"
if htmlout = 1 then file03.WriteLine "<br><table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"

'=== fields names as columns titles of the table
if htmlout = 1 then file03.WriteLine "<tr>"
for i = 0 to fieldscount01-1
if htmlout = 1 then file03.WriteLine "<td>" & dataset01.fields(i).name & "</td>"
next
if htmlout = 1 then file03.WriteLine "<td>Supertotal verification (not in DS)</td>"
if htmlout = 1 then file03.WriteLine "</tr>"

for y = 0 to linecount-1 '=== display results after bubble sort
if htmlout = 1 then file03.WriteLine "<tr>"
for x = 0 to fieldscount01-1
if htmlout = 1 then file03.WriteLine "<td>" & ara02(x,y) & "</td>"
next

if htmlout = 1 then file03.WriteLine "<td>" & ara01(6,y) & "</td>"
if htmlout = 1 then file03.WriteLine "</tr>"

next

if htmlout = 1 then file03.WriteLine "</table>"

if logall = 1 then file02.WriteLine ""
if logall = 1 then file02.WriteLine date & " " & time & " END"

if logall = 1 then file02.close
if htmlout = 1 then file03.close