Ein weiterer Beitrag von mir zu meinem Studium.
Das Syntax-Highlighting von blogengine.net funktioniert hier nicht korrekt.
Option Explicit
' allgemein: _ bedeutet, das die darauffolgende Zeile zur vorangegangenen gehört
' bitte angeben, ob jeder Durchlauf im Quicksort ausgegeben werden soll, 1 = ja
' ACHTUNG, macht nur Sinn wenn die einzelnen Zeilen der Textdatei jeweils nur 1 Zeichen enthalten!
Const mache_ausgabe = 1
' bitte angeben, ob der Vollständigkeitscheck gemacht werden soll, 1 = ja
Const mache_vergleich = 0
' Konstante für numerischen Wert deklarieren...
Const Reading = 1
Dim fso, File, WFile, WLogFile, sText
Dim FILENAME, WRITE_FILENAME, LOG_FILENAME
Dim i, t, x
Dim Durchlaeufe, zeit_start, zeit_ende, zeit_aufwand
' ein dynamisches Array wird mit ReDim statt mit Dim angelegt
ReDim a(1)
' um einen Vollständigkeitscheck durchzuführen, brauchen wir ein zweites Array...
' dieses wird später mit dem ersten verglichen, ob auch kein Datensatz verloren
' gegangen ist
ReDim b(1)
' Dateiname fürs Einlesen, also Ursprungsdatei
FILENAME="C:\users\thomas\documents\unsortiert.txt"
' Dateiname fürs Schreiben, also sortierte Datei = Ergebnis
WRITE_FILENAME="C:\users\thomas\documents\sortiert.txt"
' Dateiname fürs stufenweise Ausgeben aller Durchläufe des Quicksort-Algorithmus
LOG_FILENAME="C:\users\thomas\documents\sortierung_log.txt"
' zuerst muss das FileSystemObject erstellt (instanziiert) werden, bevor
' seine Funktionen angewandt werden können
Set fso = CreateObject("Scripting.FileSystemObject")
' nur fortfahren, wenn die Ursprungsdatei existiert...
If (fso.FileExists(FILENAME)) Then
' ------------------------------------ Einlesen der Datei ----------------------------------------
' eigentlichen Dateizeiger erstellen, im Lese-Modus (1)
set File = fso.OpenTextFile(FILENAME, Reading, false)
' Schleifen bei VBScript siehe hier:
' http://www.html-world.de/program/vbs_5.php
i=0
' einlesen der Ursprungsdatei, bis Ende erreicht ist...
' Schleife mit Prüfung am Schleifenkopf
Do while not File.AtEndOfStream
' zeilenweise einlesen, in Hilfsvariable
sText = File.ReadLine()
' Zeile aus Hilfsvariable ins eigentliche Array kopieren
a(i)=sText
' zeilenzähler um 1 erhöhen, wird benötigt um das Array richtig zu dimensionieren
i=i+1
' dynamisches Array neu dimensionieren, wobei die Datensätze erhalten bleiben sollen -
' das passiert mit dem Stichwort "preserve"
' http://www.aspheute.com/artikel/19990807.htm
ReDim Preserve A(i+1)
' (ReDim bezieht sich auf die Arraygröße (Anzahl!), i ist dagegen ein Indexzähler, insofern muss 1
' dazu addiert werden (ist oben schon geschehen), um die -bisherige- Größe zu erhalten...
' und wir wollen nun das Array um 1 erhöhen, also nochmal +1)
Loop
' Dateizeiger schließen
File.Close
' --------------------------- Logdatei zum Schreiben öffnen --------------------------------------
if mache_ausgabe=1 then
Set WLogFile = fso.CreateTextFile(LOG_FILENAME, True)
WLogFile.WriteLine("Ausgangszustand:")
end if
' Arraygrößen von A und B müssen übereinstimmen
ReDim B(i+1)
' Array A nach B kopieren, für den Vollständigkeitscheck später wird das zweite Array benötigt
' (das kopieren in B habe ich nicht beim Einlesen gemacht um die Zeit für das laufende ReDim von B einzusparen,
' dabei wird das Array schließlich umkopiert)
' i ist zwar Indexzähler, wird aber oben nachträglich erhöht, deswegen bis i-1
for t=0 to i-1
B(t)=A(t)
next
' letztlich Zeiger entfernen
Set File = nothing
' Ausgangszustand von B() (nach dem kopieren) in LogDatei schreiben
write_in_logfile
' ----------------------- Laufzeitanalyse und Aufruf von Quicksort -------------------------------
' Durchlaeufe zuerst auf 0 setzen
Durchlaeufe=0
' Startzeit für Sortierung nehmen
zeit_start = time
' Startzeit ausgeben (erstmal auskommentiert)
' x=msgbox("Startzeit für Sortierung, Fenster bitte sofort wegklicken. " & zeit_start,vbOkOnly,"Sortierungsstart")
' eigentlicher Aufruf des Quicksort-Algorithmus, mit Übergabe der Array-Größen
QuickSort 0, i-1
' Endzeit für Sortierung nehmen
zeit_ende = time
' Differenz berechnen, das ist dann die aufgewandte Zeit für die Sortierung
zeit_aufwand = zeit_ende-zeit_start
' Zeitaufwand in hh:mm:ss umrechnen, mit FormatDateTime
' ---> mögliche Variablenwerte bei vBS siehe hier:
' http://www.asphelper.de/referenz/vbscript/formatdatetime.asp
zeit_aufwand = FormatDateTime(zeit_aufwand, vbLongTime)
' Ergebnis der Laufzeitanalyse ausgeben - mögliche Schaltflächen für msgbox siehe hier:
' http://www.vbarchiv.net/commands/MsgBox.php
' ("Laufzeitmessung" ist der Titel der Box, der zusammengesetzte String dagegen das, was in der
' Box angezeigt wird. Der zweite Parameter gibt die Anzahl der angezeigten Schaltflächen an,
' in x wird die betätigte Schaltfläche als Integerwert zurückgegeben)
x=MsgBox("Durchläufe: " & Durchlaeufe & _
", Endzeit: " & zeit_ende & _
", benötigte Zeit für Sortierung: " & zeit_aufwand, _
vbOkOnly, _
"Laufzeitmessung")
' Vollständigkeitscheck ausführen, kein Wert darf verloren gehen durch Quicksort
if mache_Vergleich=1 then
if Vollstaendigkeitscheck then
msgbox("Sortiertes Array B ist vollständig")
else
msgbox("Fehler, Sortiertes Array B ist NICHT vollständig")
end if
end if
' LogFile wieder schließen, wurde ja nur benötigt um jeden Durchlauf von Quicksort zu dokumentieren
if mache_ausgabe=1 then
WLogFile.Close
end if
' -------------------------------- sortierte Datei schreiben -------------------------------------
Set WFile = fso.CreateTextFile(WRITE_FILENAME, True)
For t=0 to i-1
WFile.WriteLine(a(t))
next
WFile.Close
' Zeiger entfernen
Set WLogFile = nothing
Set WFile = nothing
Set fso = nothing
end if
' -------------------------------- Quicksort-Algorithmus -----------------------------------------
' Der Quicksort wird hartkodiert auf das Array B angewandt
sub QuickSort(anfang, ende)
dim links, rechts, mitte, h
' Grenzen festlegen
links = anfang
rechts = ende
' Pivot-Element in der Mitte festlegen
mitte = b((anfang + ende) / 2)
do
' finde im Array von unten nach oben das erste Element das nicht in die Ordnung passt, also größer als das
' Pivot-Element ist - und erhöhe bis dahin den Zeiger "links" um 1
while b(links)<pivot
links=links+1
wend
' finde im Array von oben nach unten das erste Element das nicht in die Ordnung passt, also kleiner als das
' Pivot-Element ist - und verringere bis dahin den Zeiger "rechts" um 1
while pivot<b(rechts)
rechts=rechts-1
wend
' solange sich Untergrenzen-Zeiger und Obergrenzen-Zeiger nicht kreuzen...
if links <= rechts then
' ... Elemente vertauschen an den gefundenen Positionen
h = b(links)
b(links) = b(rechts)
b(rechts) = h
' dadurch...
' automatisch untere Grenze erhöhen,
' automatisch obere Grenze verringern
links=links+1
rechts=rechts-1
' nach jedem Vertauschen im LogFile dokumentieren
write_in_logfile
end if
' Schleife fortfahren wie der Zeiger für die zu untersuchende Untergrenze tatsächlich kleiner
' als die Obergrenze ist
loop until links > rechts
' Beginn Rekursion
' von Indexpositionen "anfang" (ursprünglicher Wert) bis "rechts" (errechneter Wert des letztkleineren Elements
' (im Vergleich zum Pivotelement)) Bereich des Arrays neu sortieren
if anfang < rechts then
' Anzahl Rekursiondurchläufe berechnen
Durchlaeufe=Durchlaeufe+1
QuickSort anfang, rechts
end if
' von Indexpositionen links (errechneter Wert des erstgrößeren Elements im Vergleich zum Pivotelement) bis ende
' (ursprünglicher Wert) Bereich des Arrays neu sortieren
if links < ende then
' Anzahl Rekursiondurchläufe berechnen
Durchlaeufe=Durchlaeufe+1
QuickSort links, ende
end if
end sub
' -------------------- vergleiche Array B mit A auf Vollständigkeit-------------------------------
' brich mit FALSE ab, wennn eine Zeile in B nicht mehr in A enthalten ist
' ansonsten TRUE
' Aufruf mit "mache_vergleich=1" ganz oben aktivieren
' Achtung, ist durch Vorgehensweise sehr langsam. Also nur mit kleinen Datenmengen testen
function vollstaendigkeitscheck
Dim t,i, gefunden
gefunden=true
' auskommentierte Zeile, um Vollständigkeitscheck zu testen
'b(2)="abc"
' ubound liefert die höchste Indexposition des Arrays zurück
for t=0 to ubound(b)
gefunden=false
for i=0 to ubound(a)
if a(i)=b(t) then
gefunden=true
exit for
end if
next
if not gefunden then
exit for
end if
next
Vollstaendigkeitscheck = gefunden
end function
' -------------------- Ausgabe des Zustands des Arrays in Logdatei ---------------------------------
' Aufruf dieser Funktion macht nur Sinn, wenn jede Zeile der Quelldatei nur jeweils 1 Zeichen enthält
'
' Aufruf mit "mache_ausgabe=1" ganz oben aktivieren
function write_in_logfile
Dim t
if mache_ausgabe=1 then
for t=0 to ubound(b)
WLogFile.Write(b(t))
next
WLogFile.WriteLine(" ")
WLogFile.WriteLine(" ")
end if
end function