'*** 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)