http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** 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)
http://dieseyer.de • all rights reserved • © 2011 v11.4