Buchempfehlung
Visual Basic 6 Kochbuch
Visual Basic 6 Kochbuch
Viele praktische Tipps zum Programmieren mit Visual Basic 6, die sich oft auch auf FB übertragen lassen. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Dateien und Laufwerke

Fragmentierung überprüfen

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.Redakteurytwinky 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 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

Anmerkung:
In der Spalte unter Defrag bedeutet:

kanneine 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 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

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


Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 16.01.2011 von Redakteurytwinky angelegt.
  • Die aktuellste Version wurde am 16.01.2011 von Redakteurytwinky gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen