Laufwerke

Eine Liste mit den verfügbaren Laufwerken wird erstellt. Als Infos werden geliefert:
Laufwerksbuchstabe,  Laufwerksart oder UNC-Name, Speicher Gesamt, Speicher Verfügbar, Speicher Frei, Datenträgername,  Filesystem,  Seriennummer.
Und zwar ohne das Filesystemobjekt, nur mit Windows-Bordmitteln. 

Beispielmappe (drives.zip 17 KB)

'########################################################
'# In ein Modul
'########################################################

Option Explicit
Private Declare Function GetLogicalDrives _
    Lib "Kernel32" () As Long
Private Declare Function GetDriveType Lib _
    "Kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
Private Declare Function GetDiskFreeSpaceEx Lib _
    "Kernel32" Alias "GetDiskFreeSpaceExA" _
    (ByVal lpRootPathName As String, _
    lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, _
    lpTotalNumberOfFreeBytes As Currency) As Long
Declare Function WNetGetConnection& Lib "mpr.dll" Alias _
    "WNetGetConnectionA" (ByVal lpszLocalName As String, _
    ByVal lpszRemoteName As String, cbRemoteName As Long)
Private Declare Function GetVolumeInformation Lib _
    "Kernel32" Alias "GetVolumeInformationA" _
    (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 Long
Private Const DRIVE_CDROM = 5
Private Const DRIVE_FIXED = 3
Private Const DRIVE_RAMDISK = 6
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_REMOVABLE = 2

Public Sub test()
Dim i As Long, k As Long
Dim Überschrift, Laufwerke
Laufwerke = LokaleLaufwerke()
Überschrift = Array("Laufwerksbuchstabe", "Laufwerksart", _
    "Speicher Gesamt", "Speicher Verfügbar", _
    "Speicher Frei", "Datenträgername", _
    "Filesystem", "Seriennummer")
With Worksheets("Tabelle1")
    For i = 0 To UBound(Laufwerke, 2)
        For k = 1 To 8
            If i = 0 Then
                .Cells(i + 1, k) = Überschrift(k - 1)
            Else
                .Cells(i + 1, k) = Laufwerke(k, i)
            End If
        Next
    Next
End With
End Sub

Public Function LokaleLaufwerke()
Dim a As Long, lngLW As Long, dummy As String
Dim Verfügbar As Currency, TotalVorhanden As Currency
Dim Frei As Currency, myName As String, Filesystem As String
Dim LL() As String, i As Long, k As Long, LW As String
lngLW = GetLogicalDrives()
For a = 97 To 123
    If lngLW And 2 ^ (a - 97) Then
        LW = Chr(a) & ":\"
        i = i + 1
        ReDim Preserve LL(1 To 8, 1 To i)
        LL(1, i) = Chr(a) & ":\"
        'Laufwerkart
        dummy = ""
        Select Case GetDriveType(LW)
            Case DRIVE_FIXED
                dummy = "DRIVE_FIXED"
            Case DRIVE_REMOVABLE
                dummy = "DRIVE_REMOVABLE"
            Case DRIVE_RAMDISK
                dummy = "DRIVE_RAMDISK"
            Case DRIVE_REMOTE
                'dummy = "DRIVE_REMOTE"
                dummy = PfadNachUnc(LW)
            Case DRIVE_CDROM
                dummy = "DRIVE_CDROM"
        End Select
        LL(2, i) = dummy
        'Speicherplatz
        Verfügbar = 0: TotalVorhanden = 0: Frei = 0
        GetDiskFreeSpaceEx LW, Verfügbar, TotalVorhanden, Frei
        LL(3, i) = Format$(TotalVorhanden * 10000, _
            "###,###,###,##0")
        LL(4, i) = Format$(Verfügbar * 10000, _
            "###,###,###,##0")
        LL(5, i) = Format$(Frei * 10000, _
            "###,###,###,##0")
        'Laufwerkinfos
        k = 0
        myName = String(255, 0)
        Filesystem = String(255, 0)
        GetVolumeInformation LW, myName, 255, _
            k, 0, 0, Filesystem, 255
        myName = Left(myName, InStr(1, myName, Chr$(0)) - 1)
        Filesystem = Left(Filesystem, InStr(1, Filesystem, Chr$(0)) - 1)
        LL(6, i) = myName
        LL(7, i) = Filesystem
        LL(8, i) = CStr(k)
    End If
Next
LokaleLaufwerke = LL
End Function

Function PfadNachUnc(ByVal Pfadname As String) As String
Dim dummy, UncLaufwerk$, Laufwerk$, Pfad$
On Error GoTo Fehlerbehandlung
    Laufwerk = Left(Pfadname, 2)
    Pfad = Right(Pfadname, Len(Pfadname) - 2)
    If InStr(1, Laufwerk, ":") = 2 Then
        UncLaufwerk = String(1001, 0)
        dummy = WNetGetConnection(Laufwerk, _
            UncLaufwerk, 1000)
        If dummy <> 0 Then UncLaufwerk = Pfadname: GoTo _
            Fehlerbehandlung
        UncLaufwerk = Left(UncLaufwerk, InStr(1, UncLaufwerk, _
            Chr(0)) - 1) & Pfad
    Else
        UncLaufwerk = Pfadname
    End If
Fehlerbehandlung:
PfadNachUnc = UncLaufwerk
End Function