Laufwerke

VBA stellt schon von Haus aus einige Funktionen für den Zugriff auf Dateien und Verzeichnisse zur Verfügung, weitere können mit dem FileSystemObject eingebunden werden. Darüber hinaus kann mit den hier vorgestellten API-Funktionen aber noch die ein oder andere weitere Information ermittelt werden.

GetDiskFreeSpaceEx

Ermittelt, wieviel Speicherplatz ein Laufwerk insgesamt hat, wieviel davon frei ist und wieviel davon für den aktuellen User verfügbar ist. Der eigentliche Rückgabewert der Funktion ist postiv, wenn die Funktion erfolgreich war.

Im Parameter lpDirectoryName kann ein beliebiges Verzeichnis angegeben werden. Es wird das angegebene Laufwerk zu diesem Verzeichnis ausgewertet. Ohne Angabe wird das aktuelle Laufwerk ausgewertet. Es kann auch ein Netzwerk angegeben werden.

GetDiskFreeSpaceEx gibt die Werte auf ein Byte genau zurück. In einem 32-Bit Office können Variablen allerdings maximal Werte bis zu 2 GB speichern, größere Werte verursachen einen Überlauf. Inzwischen ist es aber eher unwahrscheinlich, überhaupt noch Speichermedien unter 2 GB zu finden. Und da man sich normalerweise auch kaum für eine bytegenaue Angabe interessiert, speichern die folgenden Funktionen die Werte in Variablen vom Typ Currency, und geben die Ergebnisse in Gigabyte zurück.

#If VBA7 Then
    Private Declare PtrSafe Function GetDiskFreeSpaceExA Lib "kernel32" _
        (ByVal lpDirectoryName As String, _
        lpFreeBytesAvailable As Currency, _
        lpTotalNumberOfBytes As Currency, _
        lpTotalNumberOfFreeBytes As Currency) _
    As Boolean
#Else
    Private Declare Function GetDiskFreeSpaceExA Lib "kernel32" _
        (ByVal lpDirectoryName As String, _
        lpFreeBytesAvailable As Currency, _
        lpTotalNumberOfBytes As Currency, _
        lpTotalNumberOfFreeBytes As Currency) _
    As Boolean
#End If


Public Function apiTotalGB(Optional strDirectory As String) As Long
Dim curAvailable As Currency, curTotal As Currency, curNumber As Currency

If GetDiskFreeSpaceExA(strDirectory, curAvailable, curTotal, curNumber) Then
    apiTotalGB = curTotal * 10000 / 1024 / 1024 / 1024  'Currency / KB / MB / GB
End If
End Function


Public Function apiFreeGB(Optional strDirectory As String) As Long
Dim curAvailable As Currency, curTotal As Currency, curNumber As Currency

If GetDiskFreeSpaceExA(strDirectory, curAvailable, curTotal, curNumber) Then
    apiFreeGB = curNumber * 10000 / 1024 / 1024 / 1024
End If
End Function


Public Function apiAvailableGB(Optional strDirectory As String) As Long
Dim curAvailable As Currency, curTotal As Currency, curNumber As Currency

If GetDiskFreeSpaceExA(strDirectory, curAvailable, curTotal, curNumber) Then
    apiAvailableGB = curAvailable * 10000 / 1024 / 1024 / 1024
End If
End Function

GetDriveType

Ermittelt, um was für eine Art von Laufwerk es sich handelt.

Im Parameter nDrive muss ein beliebiges, existierendes Verzeichnis angegeben werden. Es wird das angegebene Laufwerk zu diesem Verzeichnis ausgewertet. Es kann auch ein Netzwerk angegeben werden.

#If VBA7 Then
    Public Declare PtrSafe Function GetDriveType Lib "kernel32" _
        Alias "GetDriveTypeA" (ByVal nDrive As String) As eDriveType
#Else
    Public Declare PtrSafe Function GetDriveType Lib "kernel32" _
        Alias "GetDriveTypeA" (ByVal nDrive As String) As eDriveType
#End If

Public Enum eDriveType
    DRIVE_UNKNOWN = 0       'Typ nicht ermittelbar
    DRIVE_NO_ROOT_DIR = 1   'Pfad ungültig
    DRIVE_REMOVABLE = 2     'z.B. Floppy, SD Karte, USB-Stick, ...
    DRIVE_FIXED = 3         'Festplatte etc.
    DRIVE_REMOTE = 4        'Netzwerk
    DRIVE_CDROM = 5         'CD-ROM
    DRIVE_RAMDISK = 6       'RAM
End Enum

GetLogicalDrives

Gibt einen Longwert zurück, der eine Bitmaske darstellt. Jedes der ersten 26 Bit steht für je einen Laufwerksbuchstaben. Das erste Bit steht also für „A:\“, das zweite für „B:\“ usw. Die folgende Tabelle zeigt die entsprechenden Bitwerte. Ist der entsprechende Laufwerksbuchstabe momentan vorhanden, steht das Bit auf „1“, sonst auf „0“.

Bitmaske GetLogicalDrives
ABCDEFGH IJKLMNOP QRSTUVWX YZ
1
2
4
8
16
32
64
128
256
512
1024
2048
4096
8192
16384
32768
65536
131072
262144
524288
1048576
2097152
4194304
8388608
16777216
33554432

Die folgende Beispielfunktion erwartet einen Laufwerksbuchstaben als Parameter und gibt True zurück, wenn es dieses Laufwerk gibt.

#If VBA7 Then
    Private Declare PtrSafe Function GetLogicalDrives Lib "kernel32" () As Long
#Else
    Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
#End If


Public Function apiDriveExists(strDrive As String) As Boolean
Dim lngDrive As Long

'Falls strDrive mit einem ungültigen Zeichen beginnt, wird False zurückgegeben
On Error Resume Next

lngDrive = 2 ^ (Asc(UCase(Left(strDrive, 1))) - 65)
apiDriveExists = GetLogicalDrives And lngDrive

End Function

Um die Existenz eines einzigen, bestimmten Laufwerksbuchstaben zu prüfen, ist in der Praxis GetLogicalDriveStrings einfacher zu nutzen. GetLogicalDrives ist dagegen dann hilfreich, wenn in einem einzigen Aufruf auf mehrere Laufwerke gleichzeitig geprüft werden soll:

Debug.Print (GetLogicalDrives AND 6) > 0 'Gibt es B oder C?
Debug.Print (GetLogicalDrives AND 6) = 6 'Gibt es B und C?

GetLogicalDriveString

Ermittelt einen String, in dem alle derzeit vorhandenen Laufwerke aufgeführt werden. Der String kann etwa wie folgt aussehen:

C:\ D:\ F:\ Z:\

Die Laufwerksbezeichnungen werden dabei nicht etwa mit einem Leerzeichen (Chr(32)) getrennt, sondern mit vbNullChar (Chr(0)). Je nach Bedarf kann man im String z. B. mit InStr nach einem Laufwerk suchen, oder mit Split ein Array erzeugen, das man anschließend vielleicht in einer Schleife verwenden will. Diese beiden Anwendungsfälle werden in den folgenden Funktionen aufgezeigt. In apiLogicalDriveString werden außerdem die trennenden vbNullChar-Zeichen gelöscht, weil der Puffer strDrives sonst überzählige vbNullChar-Zeichen am Ende aufweist.

#If VBA7 Then
    Private Declare PtrSafe Function GetLogicalDriveStringsA Lib "kernel32" _
        (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#Else
    Private Declare Function GetLogicalDriveStringsA Lib "kernel32" _
        (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#End If


Public Function apiLogicalDriveString() As String
    Dim strDrives As String * 104   '26 Buchstaben * 4 Zeichen

    If GetLogicalDriveStringsA(104, strDrives) > 0 Then
        apiLogicalDriveString = Replace(strDrives, vbNullChar, "")
    End If
End Function


Public Function apiLogicalAllDrives() As String()
    Dim strDrives As String * 104   '26 Buchstaben * 4 Zeichen

    If GetLogicalDriveStringsA(104, strDrives) > 0 Then
        apiLogicalAllDrives = Split(strDrives, ":\" & vbNullChar)
    End If
End Function

GetVolumeInformation

Gibt verschiedene Informationen zu einem Laufwerk zurück, wie z. B. Laufwerksnamen und Seriennummer.

lpFileSystemNameBuffer gibt das verwendete Dateisystem zurück, also z. B. FAT32 oder NTFS. apiFileComponentLen gibt an, wie viele Zeichen ein Datei- oder Verzeichnisname maximal lang sein kann. lpFileSystemFlags gibt eine Reihe von Flags zurück, mit denen weitere Eigenschaften abgefragt werden können. Sie sind im Beispielcode unter eFileSystemFlags aufgeführt.

Im Parameter lpRootPathName kann ein beliebiges, existierendes Verzeichnis angegeben werden. Es wird das angegebene Laufwerk zu diesem Verzeichnis ausgewertet. Ohne Angabe wird das aktuelle Laufwerk ausgewertet. Es kann auch ein Netzwerk angegeben werden.

#If VBA7 Then
    Private Declare PtrSafe Function GetVolumeInformationA Lib "kernel32" _
        (ByVal lpRootPathName As String, _
        ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
        lpVolumeSerialNumber As LongPtr, _
        lpMaximumComponentLength As LongPtr, _
        lpFileSystemFlags As LongPtr, _
        ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) _
    As Boolean
#Else
    Private Declare PtrSafe Function GetVolumeInformationA Lib "kernel32" _
        (ByVal lpRootPathName As String, _
        ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
        lpVolumeSerialNumber As Long, _
        lpMaximumComponentLength As Long, _
        lpFileSystemFlags As Long, _
        ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) _
    As Boolean
#End If

Public Enum eFileSystemFlags              'Das Laufwerk ....
    FILE_CASE_PRESERVED_NAMES = &H2       'behält Groß-/Kleinschreibung der Dateinamen
    FILE_CASE_SENSITIVE_SEARCH = &H1      'unterstützt Groß-/Kleinschreibung der Dateinamen
    FILE_FILE_COMPRESSION = &H10          'unterstützt dateibasiertes Komprimieren
    FILE_NAMED_STREAMS = &H40000          'unterstützt Dateistreams
    FILE_PERSISTENT_ACLS = &H8            'speichert Zugriffskontrolllisten (ACL)
    FILE_READ_ONLY_VOLUME = &H80000       'ist nur lesbar
    FILE_SEQUENTIAL_WRITE_ONCE = &H100000 'unterstützt einzelsequentielles Schreiben
    FILE_SUPPORTS_ENCRYPTION = &H20000    'unterstützt verschlüsselte Dateisysteme (EFS)
    FILE_SUPPORSTS_EXTENDED_ATTRIBUTES = &H800000 'unterstützt applikationsspezifische Attribute
    FILE_SUPPORTS_HARD_LINKS = &H400000   'unterstützt Hard Links
    FILE_SUPPORTS_OBJECT_IDS = &H10000    'unterstützt Objekt IDs
    FILE_SUPPORTS_OPEN_BY_FILE_ID = &H1000000     'unterstützt Open By File ID
    FILE_SUPPORTS_REPARSE_POINTS = &H80   'unterstützt Reparse-Punkte
    FILE_SUPPORTS_SPARSE_FILES = &H40     'unterstützt Sparse-Dateien
    FILE_SUPPORTS_TRNSACTIONS = &H200000  'unterstützt Transaktionen
    FILE_SUPPORTS_USN_JOURNAL = &H2000000 'unterstützt Update Sequence Number (USN) Journale
    FILE_UNICODE_ON_DISK = &H4            'speichert Dateinamen als Unicode-Strings
    FILE_VOLUME_IS_COMPRESSED = &H8000    'ist komprimiert
    FILE_VOLUME_QUOTAS = &H20             'unterstützt Laufwerksanteile

    'Ab Windows 10, Version 1607:
    FILE_DAX_VOLUME = &H20000000          'ist ein direct access system (DAX)
End Enum


Public Function apiVolumeName(Optional strDirectory As String) As String
    Dim strVolumeName As String * 255

    GetVolumeInformationA strDirectory, strVolumeName, 255, 0, 0, 0, vbNullString, 0
    apistrVolumeName = Replace(strVolumeName, vbNullChar, "")
End Function


Public Function apiSerienNummer(Optional strDirectory As String)
    #If VBA7 Then
        Dim lngSerialNumber As LongPtr
    #Else
        Dim lngSerialNumber As Long
    #End If

    GetVolumeInformationA strDirectory, vbNullString, 0, lngSerialNumber, 0, 0, vbNullString, 0
    apiSerienNummer = lngSerialNumber
End Function


Public Function apiFileComponentLen(Optional strDirectory As String)
    #If VBA7 Then
        Dim lngMaxLen As LongPtr
    #Else
        Dim lngMaxLen As Long
    #End If

    GetVolumeInformationA strDirectory, vbNullString, 0, 0, lngMaxLen, 0, vbNullString, 0
    apiFileComponentLen = lngMaxLen
End Function


Public Function apilngFileSystem(Optional strDirectory As String, _
        Optional Flags As eFileSystemFlags = &HFFFFFFFF)
    #If VBA7 Then
        Dim lngFileSystem As LongPtr
    #Else
        Dim lngFileSystem As Long
    #End If

    GetVolumeInformationA strDirectory, vbNullString, 0, 0, 0, lngFileSystem, vbNullString, 0
    apilngFileSystem = lngFileSystem And Flags
End Function