Čtyři testy připravenosti diskety

Private Declare Function LoadLibrary Lib "kernel32" Alias _
"LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long,  ByVal lpProcName As String) As Long

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
"GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
lpFreeBytesAvailableToCaller As Any, lpTotalNumberOfBytes As Any, _
lpTotalNumberOfFreeBytes As Any) As Long

Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias _
"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long


Sub GetDiskFreeBytes(driveName As String, FreeBytesAvailableToCaller As _
Currency, TotalBytesAvailableToCaller As Currency, _
TotalFreeBytes As Currency)

' Pokud systém nemá zavedeno přidělování místa, třetí a první 
' argument budou mít stejnou hodnotu

' driveName je jméno disku nebo adresáře. Pokud pracujete na
' Windows 95 OSR2 nebo pozdějších verzích, lze použít i UNC cestu, ale pak
' je nutné přidat backslash, např. "\\MyServer\MyShare\". Pokud použijete
' nulový řetězec, je použit aktuální disk .
' Funkce vrátí do třech parametrů požadované hodnoty.

' Výhodou je, že tato funkce je založena na API
' GetDiskFreeSpaceEx, která je přístupná pouze ve  Windows 95 OSR2, 
' Windows 98, Windows NT4 a pozdějších verzích. Před voláním API
' si tato routina ověří, zda je API funkce dostupná, a pokud ne,
' použije starší API funkci GetDiskFreeSpace.
' Navíc, funkce GetDiskFreeSpaceEx očekává ukazatele struktury
' LARGE_INTEGER, které ale VB nepodporuje. Proto tato routina používá
' typ  Currency, a zaokrouhluje je na 4 desetinná místa.

    Dim hModule As Long, procAddr As Long, res As Long
    
    ' nejprve zjistíme použitelnost API  GetDiskFreeSpaceEx
    hModule = LoadLibrary("kernel32.Dll")
    If hModule Then
        procAddr = GetProcAddress(hModule, "GetDiskFreeSpaceExA")
        If procAddr Then
            ' Volání API GetDiskFreeSpaceEx
            res = GetDiskFreeSpaceEx(driveName, FreeBytesAvailableToCaller, _
            TotalBytesAvailableToCaller, TotalFreeBytes)
            FreeLibrary hModule
            
            If res = 0 Then
                ' nulová hodnota znamená chybu (pravděpodobně chybný disk)
                Err.Raise 5, , Err.LastDllError
            Else
                ' převod hodnoty Currency pomocí faktoru 10,000
                FreeBytesAvailableToCaller = FreeBytesAvailableToCaller * 10000
                TotalBytesAvailableToCaller = TotalBytesAvailableToCaller * _
                    10000
                TotalFreeBytes = TotalFreeBytes * 10000
                Exit Sub
            End If
        End If
        FreeLibrary hModule
    End If
    
    ' Pokud jsme zde, pak GetDiskFreeSpaceEx není k dispozici nebo se vyskytla chyba
    Dim lpSectorsPerCluster As Long
    Dim lpBytesPerSector As Long
    Dim lpNumberOfFreeClusters As Long
    Dim lpTotalNumberOfClusters As Long
    
    res = GetDiskFreeSpace(driveName, lpSectorsPerCluster, lpBytesPerSector, _
        lpNumberOfFreeClusters, lpTotalNumberOfClusters)
    If res = 0 Then
        ' nulová hodnota znamená chybu (pravděpodobně chybný disk)
        Err.Raise 5, , Err.LastDllError
    Else
        ' Návratové parametry
        FreeBytesAvailableToCaller = lpNumberOfFreeClusters * _
        lpSectorsPerCluster * lpBytesPerSector
        TotalBytesAvailableToCaller = lpTotalNumberOfClusters * _
        lpSectorsPerCluster * lpBytesPerSector
        ' Bez přidělování prostoru je tato hodnota identická s FreeBytesAvailableToCaller
        TotalFreeBytes = FreeBytesAvailableToCaller
    End If
End Sub

Zpět