XProfan

Deutsch

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Laufwerk: Test, ob ein Laufwerk bereit ist
PRFellow-Vorlage
Autor: Thomas Hölzer
3 Routinen zum Testen, ob ein Laufwerk bereit ist
a) IsDriveReady: alle neueren 16+32 Bit Profan-Versionen
Funktioniert auch mit Partitionen > 2 GB, bei denen DiskSize
einen negativen Wert wg. Integerüberlauf zurückliefert.
2 weitere Prozeduren nur um die ErrorMode-Funktionen
vorzustellen, was aber bei Profan nicht unbedigt sein muß,
weil die an sich fällige  kritische Fehlermeldung offenbar
schon von Profan abgeschaltet wird.
b) IsDriveOK : ab Profan 5.0 - 32
c) CheckDrive: ab Profan 6.1 - 32 (wg. Addr-Funktion)
Als Parameter kann jeweils ein einzelner LW-Buchstabe oder
auch ein kompletter Pfad übergeben werden
Ergebnis: 1 = OK; 0 = Fehler
Def IsDriveReady(1) If(And(Gt(DiskSize($(1)),-2),Lt(DiskSize($(1)),1)),0,1)
Def GetVolumeInformation(8) !KERNEL32,GetVolumeInformationA
Def SetCurrentDirectory(1) !KERNEL32,SetCurrentDirectoryA
Def SetErrorMode(1) !KERNEL32,SetErrorMode
Declare dirbuf#

Proc IsDriveOK

    Parameters drive$
    Declare result&,olddir$,olderrormode&
    Let olderrormode&=SetErrorMode(1)
    Let olddir$=GetDir$(@)
    Let drive$=Upper$(Mid$(drive$,1,1));:
    Dim dirbuf#,Add(Len(olddir$),2)
    String dirbuf#,0=drive$
    Let result&=SetCurrentDirectory(dirbuf#)
    String dirbuf#,0=olddir$
    SetCurrentDirectory(dirbuf#)
    SetErrorMode(olderrormode&)
    Dispose dirbuf#
    Return result&

EndProc

Proc CheckDrive

    Parameters drive$
    Declare result&,olderrormode&,dw1&,dw2&
    Let olderrormode&=SetErrorMode(1)
    Let drive$=Upper$(Mid$(drive$,1,1));:
    Dim dirbuf#,Add(Len(drive$),2)
    String dirbuf#,0=drive$
    Let result&=GetVolumeInformation(dirbuf#,0,0,0,Addr(dw1&),Addr(dw2&),0,0)
    SetErrorMode(olderrormode&)
    Dispose dirbuf#
    Return result&

EndProc

Beispiel
SetErrorLevel 2  nur zum Testen - max. Fehlerausgabe
WindowTitle Weiter mit Taste oder Mausklick ...
Cls
Print IsDriveReady für C:
Print IsDriveReady(C:)
WaitInput
Cls
Print IsDriveOK für A:
IsDriveOK A
Print &(0)
WaitInput
Cls
Print CheckDrive für C:
CheckDrive C:
Print &(0)
WaitInput