Code-Beispiel

Fragmentierung überprüfen

Lizenz:	Erster Autor:	Letzte Bearbeitung:
k. A.	ytwinky	16.01.2011

Zum Überprüfen der Fragmentierung bietet Windows einen relativ einfachen Befehl:
(Wenn der Benutzer über Admin-Rechte verfügt, aber solange das UAC-Problem nicht gelöst ist, bleiben vista- und win7-Benutzer außen vor..)

Defrag /a Lw:

wobei Lw: für das zu überprüfende Laufwerk steht(z. B. Defrag /a C:).
Nun ist die Ausgabe(in bester m$-Manier) aber alles andere als übersichtlich.
Wer also mehrere Partitonen, mehrere externe Laufwerke und auch USB-Sticks in Betrieb
hat, vermißt möglicherweise eine geordnete Auflistung seiner Datenträger. Dies bietet
das Programm ChkFrag, was für Check Fragmentation steht:

#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 : Schablone für neue Dateien                                             |

'+-----------------------------------------------------------------------------------+

'(Anmerkung zu den Sonderzeichen: zuerst steht das DOS-Zeichen, danach das Windowszeichen)

#include "ChkFrag.bi"

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 Ausfhrung diese Programmes werden Admin-Rechte ben”tigt\n"

    m &= "Diese sind aber fr " &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   Verfgbar 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

Anmerkung:
In der Spalte unter Defrag bedeutet:

kann	eine Defragmentierung ist nicht unbedingt erforderlich
sollte	eine Defragmentierung sollte in absehbarer Zeit erfolgen (mit welchem Defragmentierungsprogramm auch immer..)

Beim ersten Programmstart ist der Aufruf ChkFrag -? oder ChkFrag /? empfohlen, falls aus dem Quelltext nicht hervorgeht, was das Programm macht, bzw. welche Parameter es verarbeitet.
Voraussetzung hierfür ist aber, daß wir uns auf der Befehlszeile im Verzeichnis befinden, das auch ChkDefrag enthält.
Wenig Freude werden linux-benutzer an diesem Programm haben, doch einen Grund zur Freude
haben sie: Es wird unter linux auch gar nicht benötigt..
Die Anweisungen, die nicht in der Befehlsreferenz erläutert werden,
stammen aus folgender .bi-Datei:

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 gedrckt wird"

    s &= !"\n\t/Z\tunterdrckt die Zeitanzeige am Zeilenende"

    s &= !"\n(Gross-/Kleinschreibung ist egal..)"

    s &= !"\nDie Fragmentierungsgrenze bewirkt aber nur eine (rote) Farbe der angezeigten Zahl.."

    s &= !"\nDie Verfgbarkeitsgrenze von 12% ist eine Windoze-Konstante,"

    s &= !"\ndas BS braucht den Platz, um eine Defragmentierung durchzufhren.."

    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

(Ohne diese .bi-Datei läuft das Programm nicht..)
Beide Dateien zusammen alsDownload
Gruß
ytwinky

Zusätzliche Informationen und Funktionen

Das Code-Beispiel wurde am 16.01.2011 von ytwinky angelegt.
Die aktuellste Version wurde am 16.01.2011 von ytwinky gespeichert.

Bearbeiten

Versionen