How to make Natural Sort in Classic ASP? [duplicate] - sorting

I want to sort below items using natural sorting:
"Z1","Z3","Z2","Z20","Z10"
After sorting, I am expecting the order below:
"Z1","Z2","Z3","Z10","Z20"
When I tried using array list,
Set oAlist=CreateObject("System.Collections.ArrayList")
oAlist.sort
I am getting a sorting result based on ASCII:
Z1,Z10,Z2,Z20,Z3
Please help me on how to do this natural sorting using vb script

For theory see here (follow the links!). Practical demo
recordset:
Option Explicit
Const adInteger = 3 ' 00000003
Const adVarChar = 200 ' 000000C8
Dim sInp : sInp = "Z1,Z3,Z2,Z20,Z10"
Dim aInp : aInp = Split(sInp, ",")
WScript.Echo "A:", Join(aInp)
Dim oRS : Set oRS = CreateObject("ADODB.Recordset")
oRS.Fields.Append "Word", adVarChar, 50
oRS.Fields.Append "Length", adInteger
oRS.Open
Dim sWord
For Each sWord In aInp
oRS.AddNew
oRS.Fields("Word").value = Left(sWord, 1)
oRS.Fields("Length").value = CInt(Mid(sWord, 2))
oRS.UpDate
Next
oRS.Sort = "Word, Length"
Dim aTable : aTable = oRS.GetRows()
ReDim aOut(UBound(aTable, 2))
Dim i
For i = 0 To UBound(aOut)
aOut(i) = aTable(0, i) & aTable(1, i)
Next
WScript.Echo "B:", Join(aOut)
ArrayList
Option Explicit
Dim sInp : sInp = "Z1,Z3,Z2,Z20,Z10,E1,D3,C2,B20,A10"
Dim aInp : aInp = Split(sInp, ",")
WScript.Echo "A:", Join(aInp)
Dim oNAL : Set oNAL = CreateObject( "System.Collections.ArrayList" )
Dim oSB : Set oSB = CreateObject( "System.Text.StringBuilder" )
Dim sWord
For Each sWord In aInp
oSB.AppendFormat_2 "{0}{1,4}", Left(sWord, 1), CInt(Mid(sWord, 2))
sWord = oSB.ToString()
oSB.Length = 0
oNAL.Add sWord
Next
oNAL.Sort
ReDim aOut(oNAL.Count - 1)
Dim i
For i = 0 To UBound(aOut)
aOut(i) = Left(oNAL(i), 1) & CInt(Mid(oNAL(i), 2))
Next
WScript.Echo "B:", Join(aOut)

Related

VBscript - How to save TXT in UTF-8

how can I write UTF-8 encoded strings to a textfile from VBScript? I have tried some variations but no success. So I need the text file saved in UTF-8 format. thanks in advance for your all help.
Output :
CN=™ser1 D˜,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;10.01.2012 01:00:00
CN=Gšbson ¦LU,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;20.12.2016 18:55:51
CN=™ZL €ET˜,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;27.08.2013
type ExpReport.txt (as you can see no special characters)
CN=ser1 D,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;10.01.2012 01:00:00
CN=Gbson LU,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;20.12.2016 18:55:51
CN=ZL ET,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;27.08.2013
cscript //nologo AcctsExpire.vbs > ExpReport.txt
Here is my code :
Option Explicit
Dim adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias
Dim lngDate, objDate, dtmAcctExp, k
' Obtain local time zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
& "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
lngBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If
' Use ADO to search the domain for all users.
Set adoConnection = CreateObject("ADODB.Connection")
Set adoCommand = CreateObject("ADODB.Command")
adoConnection.Provider = "ADsDSOOBject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection
' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
' Filter to retrieve all user objects with accounts
' that expire.
strFilter = "(&(objectCategory=person)(objectClass=user)" _
& "(!accountExpires=0)(!accountExpires=9223372036854775807))"
strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter _
& ";distinguishedName,accountExpires;subtree"
' Run the query.
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute
' Enumerate the recordset.
Do Until adoRecordset.EOF
strDN = adoRecordset.Fields("distinguishedName").Value
lngDate = adoRecordset.Fields("accountExpires")
Set objDate = lngDate
dtmAcctExp = Integer8Date(objDate, lngBias)
Wscript.Echo strDN & ";" & dtmAcctExp
adoRecordset.MoveNext
Loop
adoRecordset.Close
' Clean up.
adoConnection.Close
Function Integer8Date(ByVal objDate, ByVal lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function
Last Update :
Issue is resolved.
cscript //nologo AcctsExpire.vbs //U > ExpReport.txt
Also WSCRIPT AcctsExpire.vbs displays correct output.

edit my .txt doc using VBS

In VBScript, I would like to update a text file with new data and have it shown in a message box.
Below is what I have so far; what am I doing wrong?
Option Explicit
Dim oFso, Michael, John, Valery, Susane, Katterina
Dim oStream, oFolder, f, myArrayList
Const ForAppending = 8
Const ForReading = 1, ForWriting = 2
Set myArrayList = CreateObject("System.Collections.ArrayList")
myArrayList.Add "Misko, Janko, Vierka,"
'create '
Call WriteLineToFile
Function WriteLineToFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set f = oFso.CreateTextFile("D:\TestFile1.txt", 2, True)
f.WriteLine "Misko, Janko, Vierka,"
MsgBox "Subor C:\TestFile.txt bol " & "vytvoreny."
f.Close
Set f = Nothing
Set oFso = Nothing
MsgBox "Uspesne vytvoreny " & TestFile2.txt & "."
End Function
Option Explicit 'explicit declaration of all variables'
Dim oFso, f, sPath, sPath2, i, sTemp 'deklaracia'
Dim arrString
Const ForReading = 1, ForWriting = 2
sPath = "D:\TestFile1.txt" 'cesta ku datam'
sPath2 = "D:\TestFile2.txt"
arrString = Array("Marek", "Tomas") 'pole alebo polia'
ReDim arrString(2)
arrString(0) = "Misko"
arrString(1) = "Janko"
arrString(2) = "Vierka"
sTemp = "" 'empty pole pred runom'
For i = 0 To UBound(arrString) 'ide po upper bound '
If i = UBound(arrString) Then
sTemp = sTemp + arrString(i) 'odstrani ciarku na konci'
Else
sTemp = sTemp + arrString(i) + ", "
End If
Next
MsgBox sTemp
Call WriteLineToFile (sPath, sTemp) 'zavola sub routine'
ReDim Preserve arrString (4)
arrString(3) = "Zuzka"
arrString(4) = "Katka"
sTemp = ""
For i = 0 To UBound(arrString)
If i = UBound(arrString) Then
sTemp = sTemp + arrString(i)
Else
sTemp = sTemp + arrString(i) + ", "
End If
Next
MsgBox sTemp
Call WriteLineToFile (sPath2, sTemp)
Sub WriteLineToFile (sFilePath, sText)
Set oFso = CreateObject("Scripting.FileSystemObject")
Set f = oFso.CreateTextFile(sFilePath, 2, True)
'For i = 0 To UBound(arrString) - 1 'nepotrebne'
f.WriteLine sText
'Next
MsgBox "Subor " & sFilePath & " vytvoreny."
f.Close
Set f = Nothing
Set oFso = Nothing
End Sub

VBscript with lists

I am trying to write a VBScript which will read a text file and build a dictionary which contains lists. Let me explain with an example:
The input file would be a simple text file of the sort:
Male,Peter
Male,Chris
Male,Stewie
Male,Brian
Female,Lois
Female,Meg
When I run my script, I would like a dictionary with the first column as the key, and the second column as the values
{'Male':['Peter,Chris,Stewie,Brian']}
{'Female':['Lois,Meg']}
The lack of dynamic arrays or lists in VBScript is making this a real pain. Any suggestion how I might tackle this?
Cheers
VBScript can use the System.Collections.ArrayList class provided by the .NET framework.
Set d = CreateObject("Scripting.Dictionary")
d.Add "Male", CreateObject("System.Collections.ArrayList")
d.Add "Female", CreateObject("System.Collections.ArrayList")
d("Male").Add "Peter"
d("Male").Add "Chris"
'...
d("Female").Add "Lois"
d("Female").Add "Meg"
'...
For processing the input file take a look at the code provided by #Rich.
Just to say, I'm not compete with posted answers for repo-point ;)
If you can convert my post to comment, feel free to do that.
I like Ansgar's idea (+1) as it based on single Dictionary and that seems to me quite enough to get back easy what is stored inside.
The need of .Exists may come in use in 2 cases - (a) if we don't know how many genders we have, and (b) if we don't know how they looks like (pronunciation). The rest is similar to Ansgar's idea.
Option Explicit
Const cGender = 0
Const cName = 1
Dim sGender, sName, sLine
Dim oFSO, oFile, oDict
Dim arrLine
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDict = CreateObject("Scripting.Dictionary")
Set oFile = oFSO.OpenTextFile("persons_list.txt")
Do Until oFile.AtEndOfStream
sLine = oFile.ReadLine
If Len(sLine) Then
arrLine = Split(sLine, ",")
sGender = arrLine(cGender)
sName = arrLine(cName)
If Not oDict.Exists(sGender) Then
oDict.Add sGender, CreateObject("System.Collections.ArrayList")
End If
oDict(sGender).Add sName
End If
Loop
oFile.Close
Set oFile = Nothing
Set oFSO = Nothing
WScript.Echo "Genders:" & oDict.Count, vbNewLine & Join(oDict.Keys)
Dim sKey
For Each sKey In oDict
WScript.Echo sKey, oDict(sKey).Count, vbNewLine & Join(oDict(sKey).ToArray())
Next
I'm not too familiar with the dictionary object, but this might suffice?
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oDictionary = CreateObject("Scripting.Dictionary")
Const cGender = 0
Const cName = 1
Set oFile = oFso.OpenTextFile ("yourfile.txt", 1)
Do Until oFile.AtEndOfStream
sLine = oFile.Readline
If sLine <> "" Then
arrLine = split(sLine,",")
oDictionary.Add arrLine(cGender,0), arrLine(cName,0) 'hope i got these indexes the right way round
'or
oDictionary.Add arrLine(cGender), arrLine(cName) 'if its one dimentional
End If
Loop
As #Rich approach is faulty (-1) - you can't .Add a key twice and if you could, the names would be overwritten, not appended - and Ansgar's good idea (+1) is not really production ready without a hint wrt its practical use:
Const cGender = 0
Const cName = 1
Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject")
Dim dicDic : Set dicDic = CreateObject("Scripting.Dictionary")
Dim dicAl : Set dicAl = CreateObject("Scripting.Dictionary")
Dim dicCnt : Set dicCnt = CreateObject("Scripting.Dictionary")
Dim oFile, sLine, arrLine
Set oFile = oFS.OpenTextFile ("so14479571.txt")
Do Until oFile.AtEndOfStream
sLine = oFile.Readline()
If sLine <> "" Then
arrLine = Split(sLine,",")
dicCnt(arrLine(cGender)) = dicCnt(arrLine(cGender)) + 1
If Not dicDic.Exists(arrLine(cGender)) Then
Set dicDic(arrLine(cGender)) = CreateObject("Scripting.Dictionary")
End If
dicDic(arrLine(cGender))(arrLine(cName)) = Empty
If Not dicAl.Exists(arrLine(cGender)) Then
Set dicAl(arrLine(cGender)) = CreateObject("System.Collections.ArrayList")
End If
dicAl(arrLine(cGender)).Add arrLine(cName)
End If
Loop
Dim sKey, sKey2
WScript.Echo "genders:"
For Each sKey In dicCnt
WScript.Echo "", sKey, dicCnt(sKey)
Next
WScript.Echo "dic:"
For Each sKey In dicDic
WScript.Echo "", sKey
For Each sKey2 In dicDic(sKey)
WScript.Echo " ", sKey2
Next
Next
WScript.Echo "AL:"
For Each sKey In dicAl
WScript.Echo "", sKey & ":", Join(dicAl(sKey).ToArray())
Next
output:
genders:
Male 4
Female 2
dic:
Male
Peter
Chris
Stewie
Brian
Female
Lois
Meg
AL:
Male: Peter Chris Stewie Brian
Female: Lois Meg
The script should show:
How you can use assignment without .Exists for 'simple' values that can be autovivified (here a number)
That you need an .Exists check for values like Arrays, ArrayLists, or Dictionaries

Convert Latitude/Longitude to decimal degrees

i need to convert a large txt file with latitudes, and a large txt file with longitudes into decimal degrees.
The data i have is in the current format:
7d44'31.495"W for longitude
and
41d3'40.313"N for latitude
i need to convert both of this files to decimal degrees (using a script preferably). How can i do this?
Knowing nothing about *itudes, I can only give you a general idea about how
to solve your problem:
Use a RegExp to cut the numbers from your data and feed them in a trusted formula
To give you some confidence in my proposal, I show you, how I would tackle
the two sub-problems of your task.
(1) Apply a RegExp on an input string and calculate.
Based on this section
Conversion from DMS to Decimal Degree
Given a DMS (Degrees, Minutes, Seconds) coordinate such as W87°43'41",
convert it to a number of decimal degrees using the following method:
Calculate the total number of seconds:
43'41" = (43*60 + 41) = 2621 seconds.
The fractional part is total number of seconds divided by 3600:
2621 / 3600 = ~0.728056
Add fractional degrees to whole degrees to produce the final result:
87 + 0.728056 = 87.728056
Since it is a West longitude coordinate, negate the result.
The final result is -87.728056.
found here
Code:
Dim oFmt : Set oFmt = New cFormat
Dim oRE : Set oRE = New RegExp
' 0 1 2 3
oRE.Pattern = "^([W])(\d+)°(\d+)'(\d+)""$"
Dim aTests : aTests = Array( _
Array("W87°43'41""", -87.728056) _
)
Dim aTest
For Each aTest In aTests
Dim sInp : sInp = aTest(0)
Dim nExp : nExp = aTest(1)
Dim oMTS : Set oMTS = oRE.Execute(sInp)
Dim sMsg
If 1 <> oMTS.Count Then
sMsg = oFmt.formatTwo("|{0}| didn't match /{1}/", sInp, oRE.Pattern)
Else
Dim sLoLa : sLoLa = oMTS(0).SubMatches(0)
Dim nDegrees : nDegrees = CDbl(oMTS(0).SubMatches(1))
Dim nMinutes : nMinutes = CDbl(oMTS(0).SubMatches(2))
Dim nSeconds : nSeconds = CDbl(oMTS(0).SubMatches(3))
Dim nRes
' Calculate the total number of seconds:
' 43'41" = (43*60 + 41) = 2621 seconds.
nRes = nMinutes * 60 + nSeconds
' WScript.Echo "***", nRes
' The fractional part is total number of seconds divided by 3600:
' 2621 / 3600 = ~0.728056
nRes = nRes / 3600
' WScript.Echo "***", nRes
' Add fractional degrees to whole degrees to produce the final result:
' 87 + 0.728056 = 87.728056
nRes = nDegrees + nRes
' WScript.Echo "***", nRes
' Since it is a West longitude coordinate, negate the result.
' The final result is -87.728056.
Select Case sLoLa
Case "W"
nRes = -nRes
End Select
sMsg = oFmt.formatArray(_
"{0,-12}: R: {1,12:N6} E: {2,12:N6} D: {3,12:N6}" _
, Array(sInp, nRes, nExp, nRes - nExp) _
)
End If
WScript.Echo sMsg
Next
Output:
Step00 - conversion a la wikipedia
================================================================
W87°43'41" : R: -87,728056 E: -87,728056 D: 0,000000
================================================================
xpl.vbs: Erfolgreich beendet. (0) [0.08594 secs]
Starting from an input sample, I derive (a first attempt at) the Regexp
pattern
" W 87 ° 43 ' 41 "" "
' 0 1 2 3
oRE.Pattern = "^([W])(\d+)°(\d+)'(\d+)""$"
For your data, something like this
" 7 d 44 ' 31.495 "" W "
" 41 d 3 ' 40.313 "" N "
' 0 1 2 3
oRE.Pattern = "^(\d+)d(\d+)'(\d+\.\d+)""([WN])$"
may be appropriate.
To get the parts captured by the RegExps group ()s, I access and convert
the match's submatches
Dim sLoLa : sLoLa = oMTS(0).SubMatches(0)
Dim nDegrees : nDegrees = CDbl(oMTS(0).SubMatches(1))
Dim nMinutes : nMinutes = CDbl(oMTS(0).SubMatches(2))
Dim nSeconds : nSeconds = CDbl(oMTS(0).SubMatches(3))
Then it's just computing according to the algorithm/formulas stolen
from Wikipedia (see the code/comments).
(2) Get the data from your files
If the files are not to big, you can .ReadAll() them into memory and
apply the RegExp in multiline mode:
Dim oFmt : Set oFmt = New cFormat
Dim oRE : Set oRE = New RegExp
oRE.Global = True
oRE.Multiline = True
' 0 1 2 3
oRE.Pattern = "^(\d+)d(\d+)'(\d+\.\d+)""([WN])$"
Dim sAll : sAll = goFS.OpenTextFile("..\data\f00.txt").ReadAll()
WScript.Echo sAll
WScript.Echo oFmt.formatArray( _
"|{0,-5}|{1,-11}|{2,-11}|{3,-15}|" _
, Array("LoLa", "Degrees", "Minutes", "Seconds") _
)
Dim oMTS : Set oMTS = oRE.Execute(sAll)
Dim oMT
For Each oMT In oMTS
Dim sLoLa : sLoLa = oMT.SubMatches(3)
Dim nDegrees : nDegrees = CDbl(oMT.SubMatches(0))
Dim nMinutes : nMinutes = CDbl(oMT.SubMatches(1))
Dim nSeconds : nSeconds = CDbl(oMT.SubMatches(2))
WScript.Echo oFmt.formatArray( _
"|{0,-5}|{1,11:N2}|{2,11:N2}|{3,15:N6}|" _
, Array(sLoLa, nDegrees, nMinutes, nSeconds) _
)
Next
output:
======================================================
7d44'31.495"W
41d3'40.313"N
|LoLa |Degrees |Minutes |Seconds |
|W | 7,00| 44,00| 31,495000|
|N | 41,00| 3,00| 40,313000|
======================================================
Get the cFormat class from here

Data report in VB 6.0

I'm using data report in VB 6 and trying to display images from database. It retrieves the image but showing the same image for all output
the code i'm using are given below
Dim rs As ADODB.Recordset, rs1 As ADODB.Recordset
Dim a As String
k = 0
i = 0
j = 0
k = 0
Set rs = New ADODB.Recordset
With rs
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = conn
.Source = "SELECT patientid FROM Inpatients_Maintenance WHERE (ModDate >= '" & frmDate & "') AND (ModDate <= '" & endDate & "')"
.CursorLocation = adUseClient
.Open
Do Until rs.EOF
If (rs.EOF = False And rs.BOF = False) Then
pid(i) = rs.Fields(0).Value
End If
i = i + 1
rs.MoveNext
Loop
End With
Set rs = Nothing
Set rs1 = New ADODB.Recordset
Dim id As String
With rs1
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.ActiveConnection = conn
For j = 0 To i - 1
id = pid(j)
.Source = "Select photo from patientImage where patientid='" & id & "'"
.CursorLocation = adUseClient
.Open
If (rs1.EOF = False And rs1.BOF = False) Then
p(j) = App.Path + "\patients\" + rs1.Fields(0).Value
a = p(j)
Set RptInpatientMaster.Sections("Section1").Controls("Image2").Picture = LoadPicture(a)
End If
.Close
Next j
End With
Do you only see the last one?
Set RptInpatientMaster.Sections("Section1").Controls("Image2").Picture = LoadPicture(a)
you always refer to same picture inside your report, isn't it?

Resources