#ifndef False
	Const False=0, True=Not False
#endif
#include "crt.bi"
#include once "windows.bi"
#include "vbcompat.bi"
#define ArgC ((*__p___argc())-1)
#undef GoTo 'Jojo hat Recht, danke ;-))
#define auf ,

'+-----------------------------------------------------------------------------------+
'|    Header: Bestimmen der Übergabeparameter                                        |
'|    AnzeigeCheck:|Il1 sind Alt-0124, Großes i, kleines L, Eins „ä”ö�üáߎę֚Üñ±ø°¸©|
Const Autor="ChkFrag.Bas v0.21.1 ¸2011 by ytwinky, MD"'                              |
'|           (Tastenkombination: keine)                                              |
'|                                                                                   |
'|    Zweck : Fragmentrierung prüfen                                                 |
'+-----------------------------------------------------------------------------------+
'(Anmerkung zu den Sonderzeichen: zuerst steht das DOS-Zeichen, danach das Windowszeichen)
Const VerfLimit=12, hell=8, rot=hell+4, weiss=7, schwarz=0, Lf=!"\n"

Type LwRec
	As String LwChar, Empfehlung, Gesamt, Verf, VerfP, Fragm, DatFrag
End Type

Function IsAdmin() As Integer 'Schönen Dank an yetifoot und oldirty für die Vorarbeit ;-))
  Dim HKey_ As HKEY
	Dim As String RegKey="Software\Microsoft\WBEM" 'nur Admins können hier schreiben
	Dim As String KeyName="IsAdmin" 'dieser String 'IsAdmin' ist absolut unschädlich..
	'(der Inhalt ist völlig belanglos, 'No' falls ein Schlaumeier den Wert ausliest ^^)
  RegCreateKeyEx(HKEY_LOCAL_MACHINE, RegKey, 0, 0, REG_OPTION_NON_VOLATILE, KEY_SET_VALUE, NULL, @HKey_, 0)
  Function=RegSetValueEx(HKey_, KeyName, 0, REG_SZ, @"No", 3)=0 'True=Schreiben hat geklappt, also Admin..
  '..da das Schreiben funktioniert
  '..und die paar Byte schaden der Registry nicht, gemessen an dem Schrott, der sonst noch drinsteht!
  RegCloseKey(HKey_)
End Function

Function LaufwerksTyp(Drive As String) As String
  Var i=GetDriveType(Drive)
  Dim As String LwTyp(1 To 6)={"Medium unbekannt", "WechselMedium", "Festplatte", "Netzlaufwerk", "CD/DVD", "RamDisk"}
  LaufwerksTyp=LwTyp(IIF(i<2 Or i>6, 0, i))
End Function

Function GetAllDrives() As String
  Var s="", Drives="", Drive="", i=0, LwCh=""
  Dim Buffer As String*255
  i=GetLogicalDriveStrings(Len(Buffer), Buffer)
  Drives=Left(Buffer, i)
  For i=1 To Len(Drives) Step 4
    Drive=Mid(Drives, i, Instr(Drives, "\"))
    LwCh=Chr(Drive[0])
    If LwCh>"B" And InStr(LaufwerksTyp(LwCh &":"), "/")=0 Then s+=LwCh &":"
  Next
  Return s
End Function

Function ChkFrag(Lw As String) As String
  Dim As String s, z
  Dim As Integer DNr=FreeFile, i
  If Instr(Lw, ":")=0 Then Lw+=":"
	Open Pipe "Defrag.Exe -a " &Lw For Input As #DNr
	Do
		Line Input #DNr, z
		If Instr(z, "ragmentiert")=0 Then Continue Do
		s+=z &Lf
	Loop Until Eof(DNr)
	Close DNr
  Return s
End Function

Sub Hilfe()
	Var s=!"Korrekter Aufruf: ChkFrag [/Fx]|[/?] [/W] [/Z]\n"
	s &= !"wobei:\n\t/Fx\teine Fragmentierungsgrenze von x setzt..\n"
	s &= !"\t/?\tdiese Seite anzeigt(auch -?, /h, -h usw.)"
	s &= !"\n\t/W\tbewirkt ein Anhalten des Programmes, bis eine Taste gedr�ckt wird"
	s &= !"\n\t/Z\tunterdr�ckt die Zeitanzeige am Zeilenende"
	s &= !"\n(Gross-/Kleinschreibung ist egal..)"
	s &= !"\nDie Fragmentierungsgrenze bewirkt aber nur eine (rote) Farbe der angezeigten Zahl.."
	s &= !"\nDie Verf�gbarkeitsgrenze von 12% ist eine Windoze-Konstante,"
	s &= !"\ndas BS braucht den Platz, um eine Defragmentierung durchzuf�hren.."
	Print s
  End 194
End Sub

Function StringSplit( _
	Liste As String, _
	Trenner As String, _
	SplitArray() As String, _
	LeerZeilen As Integer=True _
	) As Integer

  Var Vorige=1, Gefunden=0, LenTren=Len(Trenner), Index=0, s="" ' der Var-Befehl funktioniert^^
  If Len(Liste)+LenTren=0 Then Return -1 'beide Längen=0? nix zu tun, fertig..
  Erase SplitArray 'alte Ergebnisse löschen
  Do While Instr(Vorige, Liste, Trenner) 'hier prüfen, kann ja sein, daß es Trenner nicht gibt
  	Gefunden=Instr(Vorige, Liste, Trenner)
  	ReDim Preserve SplitArray(Index) 'Preserve funktioniert mit 1-dimensionalen Arrays
  	s=Mid(Liste, Vorige, Gefunden-Vorige) 'Teilstring von Vorige bis Gefunden..
  	If s<>"" Then 'Keine Leerzeile?
		  SplitArray(Index)=s 'Alles klar, übernehmen..
		  Index+=1
  	Else 'Ooops, Leerstring, weiterprüfen..
  		If LeerZeilen Then 'Wenn False, werden leere Zeilen ausgefiltert
		  	SplitArray(Index)=s 'Also gut, Leerzeile übernehmen..
		  	Index+=1
		  End If
	  End If
  	Vorige=Gefunden+LenTren 'Vorige auf nächste Position
  Loop
  ReDim Preserve SplitArray(Index) 'Wenigstens Platz für EIN Element machen
  If Index Then 'Stringrest in SplitArray speichern..
 		SplitArray(Index)=Mid(Liste, Vorige, Gefunden-Vorige)
  Else 'nein, Trenner ist nicht in Liste..
 		SplitArray(Index)=Liste ' Liste in SplitArray speichern(Vorsicht:Speicherplatz!!)
  EndIf
 	Return Index 'UBound wäre hier ein unnötiger Funktionsaufruf..
End Function

Function Replace(byVal Text As String, byVal Suche As String, byVal ErsetzeMit As String) As String
  Var i=0, s=Text
  While Instr(s, Suche)
    i=Instr(s, Suche)
    s=Left(s, i-1) &ErsetzeMit &Mid(s, i+Len(Suche))
  Wend
  Return s
End Function

Function Check(Lw As String) As LwRec
	Dim h As LwRec, i As Integer, j As Integer, k As Integer, s() As String, st As String
	With h
		.LwChar=Lw
		StringSplit(ChkFrag(.LwChar), !"\n", s(), False)
		.Empfehlung="sollte"
		If InStr(s(1), .Empfehlung)=0 Then .Empfehlung="kann"
		st=s(0)
		i=StringSplit(st, ", ", s(), False)
		.Gesamt=LTrim(Left(s(0), InStr(s(0), "Gesamt")-2))
		j=InStr(s(1), "(")
		.Verf=LTrim(Left(s(1), j-2))
		.VerfP=Mid(s(1), j+1, InStr(s(1), ")")-j-1)
		.Fragm=LTrim(Left(s(2), InStr(s(2), "F")-2))
		j=InStr(s(2), "(")
		.DatFrag=Mid(s(2), j+1, InStr(s(2), "Dat")-1-j)
	End With
	Return h
End Function

Function Align(What As String, FieldWidth As Integer=11, How As String="r") As String
	Var Aligned=Space(FieldWidth), le=Len(What), Wie=IIf(How="", @"c", SAdd(How))
	Select Case LCase(Left(*Wie, 1)) 'ignore lowercase
		Case "r" 'it is ok to submit 'r' for 'Right', which is the default
			RSet Aligned, What
		Case "l" 'same with 'l' which aligns to the 'Left'
			LSet Aligned, What
		Case Else 'now there's only 'c' left
			LSet Aligned, What
			If le<FieldWidth Then
				Aligned=Left(Space((FieldWidth-le)\2) &Aligned, FieldWidth)
			End If
	End Select
	Return Aligned
End Function

Var i=0, AlleLw=GetAllDrives(), a=0.0, e=0.0, FragLimit=VerfLimit, m=Autor, t=True
Dim LwArray(1 To 26) As LwRec
Print Autor
For i=1 To ArgC
	If Command(i)<>"" Then
		Select Case Left(lcase(Command(1)), 2)
			Case "/f"
				FragLimit=Val(Mid(Command(1), 3))
				If FragLimit=0 Then FragLimit=12
			Case "/w"
			Case "/z"
				t=False
			Case Else
				Hilfe()
				End 27
		End Select
	EndIf
Next

If Not IsAdmin() Then
	m=!"Zur Ausf�hrung diese Programmes werden Admin-Rechte ben”tigt\n"
	m &= "Diese sind aber f�r " &ENVIRON("username") &!" nicht vorhanden..\n"
	m &= !"Wenden Sie sich an Ihren SystemAdministrator oder Bill Gates, aber\n"
  Print m &"keinesfalls an den Autor ;-))"
	Hilfe()
End If

Print "Fragmentierungsbericht der Partion" & *IIf(Len(AlleLw)>2, @"en", @"") &_
      !"\nLw      Gesamt   Verf�gbar Verf.% Fragm.% Dateifragm.% Defrag" &*IIf(t, @" Zeit[s]", @"")
For i=1 To Len(AlleLw) Step 2
	Print "w8, plz..";
	a=Timer
		LwArray(i)=Check(Mid(AlleLw, i, 2))
	e=Timer
	With LwArray(i)
		Print !"\r" & .LwChar &Align(.Gesamt, 12) &Align(Replace(.Verf, ".", ""), 12);
		If Val(.VerfP)<=VerfLimit Then Color hell+rot auf schwarz
		Print Align(.VerfP, 7);
		Color weiss auf schwarz
		If Val(.Fragm)>FragLimit Then Color hell+rot auf schwarz
		Print Align(.Fragm, 8);
		Color weiss auf schwarz
		m=Align(Format(e-a, " ##0.0"), 5)
		Print Align(.DatFrag, 14) &Align(.Empfehlung, 7, "l"); *IIf(t, SAdd(m), @"")
	End With
Next

If InStr(lCase(Command), "/w") Then
	Print "Eniki..";
	GetKey
End If