'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei:  sort-heapsort.vbs
' Autor:  dieseyer@gmx.de
' Auf:    www.dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch.
' 
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 2:30 min
' mit 100% CPU-Last
'
'************************************************************

Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl

Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs

Dim StartZeit : StartZeit = Timer()

Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso      = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs    = Wscript.Arguments

' Fals ein Argument übergeben wurde, sollte es einen Dateinamen 
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1     ' hole alle Argumente 
  if i = 0 then Datei = oArgs.item(i)
Next 


' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts 
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName

  Text = Text & now() & vbCRLF

' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn  = FSO.OpenTextFile(Datei, 1 )                    ' Datei zum Lesen öffnen 
i=0
  Do While Not (FileIn.atEndOfStream)                           ' wenn Datei nicht zu ende ist, weiter machen
      ReDim Preserve arrTest(i)
                     arrTest(i) = FileIn.Readline
      i = i + 1
  Loop
    FileIn.Close
Set FileIn  = nothing

  Text =        UBound(arrTest) & "   Zeilen der Datei   " & Datei & "   werden jetzt (" & now() & ") durch   " & WScript.ScriptName & "   sortiert." & vbCRLF


  arrSort = HeapSort ( arrTest )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrSort = QuickSort(arrTest, LBound(arrTest), UBound(arrTest))

  Text = Text & UBound(arrTest) & "   Zeilen der Datei   " & Datei & "    sind  jetzt (" & now() & ") durch   " & WScript.ScriptName & "   sortiert."


' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"


' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut  = FSO.OpenTextFile(Datei, 2, true)                    ' Datei zum Lesen öffnen 

'   FileOut.WriteLine( Text & vbCRLF )                             ' nur Für Testzwecke

  for i = 0 to ubound(arrTest)
    FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
  next

'   FileOut.WriteLine( vbCRLF & vbCRLF & now() )                   ' nur Für Testzwecke
   Text = Text & now() 
    FileOut.Close
Set FileOuT  = nothing

' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei

MsgBox i & " Zeilen sind nach " & Timer() - StartZeit & "s sortiert.", 4096, WScript.ScriptName

WScript.Sleep 3000


' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )

WScript.Quit 


'*** v3.6 *** www.dieseyer.de *******************************
' function QuickSort(vntArray, intVon, intBis) ' funtion Anfang
Function HeapSort(ByRef A)
'************************************************************
' Aus der MS-NG am 13.03.2003 von von Hubert Daubmeier
  Dim HeapSize, i
  HeapSize = UBound(A) + 1
  BuildHeap A, HeapSize
  For i = UBound(A) To 1 Step -1
    Swap A(0), A(i)
    HeapSize = HeapSize - 1
    Heapify A, 0, HeapSize
  Next
End Function ' Function HeapSort(ByRef A)

'*** v3.6 *** www.dieseyer.de *******************************
Sub BuildHeap(ByRef A, ByVal HeapSize)
'************************************************************
  Dim i
  For i = Int(HeapSize / 2) To 0 Step -1
    Heapify A, i, HeapSize
  Next
End Sub ' BuildHeap(ByRef A, ByVal HeapSize)

'*** v3.6 *** www.dieseyer.de *******************************
Sub Heapify(ByRef A, ByVal i, ByVal HeapSize)
'************************************************************
  Dim l, r, Largest
  l = 2 * i + 1
  r = 2 * i + 2
  Largest = i
  If l < HeapSize Then
'   If UCase( A(l) ) > UCase( A(i) ) Then Largest = l
    If        A(l)   >        A(i)   Then Largest = l
  End If
  If r < HeapSize Then
    If        A(r) >          A(Largest)   Then Largest = r
'   If UCase( A(r) ) > UCase( A(Largest) ) Then Largest = r
  End If
  If Largest <> i Then
    Swap A(i), A(Largest)
    Heapify A, Largest, HeapSize
  End If
End Sub ' Heapify(ByRef A, ByVal i, ByVal HeapSize)


'*** v3.6 *** www.dieseyer.de *******************************
Sub Swap(ByRef L, ByRef R)
'************************************************************
  Dim Temp
  Temp = R
  R = L
  L = Temp
End Sub ' Swap(ByRef L, ByRef R)